remove unused code and improve test coverage

Author: jgabry

NAMESPACE

@@ -206,5 +206,3 @@ importFrom(dplyr,top_n)
 importFrom(dplyr,ungroup)
 importFrom(dplyr,vars)
 importFrom(ggplot2,"%+replace%")
-importFrom(ggridges,geom_density_ridges)
-importFrom(ggridges,geom_density_ridges2)

R/helpers-gg.R

@@ -21,22 +21,6 @@ geom_ignore <- function(...) {
     show.legend = FALSE, inherit.aes = FALSE)
 }
 
-#' Wrappers for ggridges
-#'
-#' The "area ridges" are for use in `mcmc_areas()`. The scale of 1 and the
-#' identity statistic prevent the ridges from overlapping.
-#' `geom_density_ridges2()` draws closed polygons.
-#'
-#' @importFrom ggridges geom_density_ridges geom_density_ridges2
-#' @noRd
-geom_area_ridges <- function(...) {
-  ggridges::geom_density_ridges(..., stat = "identity", scale = .95)
-}
-
-geom_area_ridges2 <- function(...) {
-  ggridges::geom_density_ridges2(..., stat = "identity", scale = .95)
-}
-
 
 #' Add new aesthetic mappings to a list of aesthetic mappings
 #'

R/helpers-ppc.R

@@ -107,6 +107,10 @@ validate_predictions <- function(predictions, n_obs = NULL) {
 #' @return Either throws an error or returns a numeric vector.
 #' @noRd
 validate_pit <- function(pit) {
+  if (anyNA(pit)) {
+    abort("NAs not allowed in 'pit'.")
+  }
+
   stopifnot(is.numeric(pit))
 
   if (!is_vector_or_1Darray(pit)) {
@@ -117,10 +121,6 @@ validate_pit <- function(pit) {
     abort("'pit' must only contain values between 0 and 1.")
   }
 
-  if (anyNA(pit)) {
-    abort("NAs not allowed in 'pit'.")
-  }
-
   unname(pit)
 }
 
@@ -508,7 +508,7 @@ get_interpolation_values <- function(N, K, L, prob) {
       ".\n",
       "Try either setting a value of 'K' >= ",
       min(vals[vals$N <= N, ]$K),
-      "or 'interpolate_adj' = FALSE.",
+      " or 'interpolate_adj' = FALSE.",
       sep = ""
     ))
   }

R/ppc-loo.R

@@ -165,7 +165,7 @@ ppc_loo_pit_overlay <- function(y,
       grid_len = grid_len
     )
 
-  if (all(data$value[data$is_y] %in% 0:1)) {
+  if (!missing(y) && all(y %in% 0:1)) {
     warning(
       "This plot is not recommended for binary data. ",
       "For plots that are more suitable see ",
@@ -667,7 +667,7 @@ ppc_loo_ribbon <-
   }
 
   if (grid_len < 100){
-    grid_len = 100
+    grid_len <- 100
   }
 
   # Get relative frequency boundaries and counts for input vector

tests/testthat/test-aesthetics.R

@@ -157,6 +157,16 @@ test_that("theme_default creates ggplot theme", {
   expect_equal(thm2[["text"]][["size"]], 13)
 })
 
+test_that("bayesplot_theme_set warns of missing theme elements", {
+  dark2 <- ggplot2::theme_dark()
+  dark2$line <- NULL
+  expect_warning(
+    bayesplot_theme_set(dark2),
+    "New theme missing the following elements: line"
+  )
+  bayesplot_theme_set()
+})
+
 test_that("bayesplot_theme_set/get work", {
   bayesplot_theme_set()
   expect_identical(bayesplot_theme_get(), default)

tests/testthat/test-helpers-ppc.R

@@ -105,6 +105,15 @@ test_that("get_interpolation_values catches impossible values", {
     get_interpolation_values(0, 1000, 4, .95),
     "No precomputed values to interpolate from for sample length of 0."
   )
+  expect_error(
+    get_interpolation_values(1e5, 10, 4, .95),
+    "No precomputed values to interpolate from for sample length of 1e+05",
+    fixed = TRUE
+  )
+  expect_error(
+    get_interpolation_values(100, 300, 4, .95),
+    "No precomputed values available for interpolation for 'K' = 300"
+  )
 })
 
 # ecdf_intervals ---------------------------------------------------------

tests/testthat/test-mcmc-diagnostics.R

@@ -21,6 +21,10 @@ test_that("rhat and neff plots return a ggplot object", {
   # named ok
   rhat <- setNames(runif(5, 1, 1.5), paste0("alpha[", 1:5, "]"))
   expect_gg(mcmc_rhat(rhat))
+
+  # doesn't error with ratios > 1 (not common but can happen)
+  expect_gg(mcmc_neff(ratio = c(0.5, 1, 1.25)))
+  expect_gg(mcmc_neff(ratio = c(0.5, 1, 2)))
 })
 
 test_that("rhat and neff plot functions throw correct errors & warnings", {

tests/testthat/test-ppc-distributions.R

@@ -61,6 +61,11 @@ test_that("ppc_dens,pp_hist,ppc_freqpoly,ppc_boxplot return ggplot objects", {
 test_that("ppc_pit_ecdf, ppc_pit_ecdf_grouped returns a ggplot object", {
   expect_gg(ppc_pit_ecdf(y, yrep, interpolate_adj = FALSE))
   expect_gg(ppc_pit_ecdf_grouped(y, yrep, group = group, interpolate_adj = FALSE))
+  expect_message(ppc_pit_ecdf(pit = runif(100)), "'pit' specified")
+  expect_message(
+    ppc_pit_ecdf_grouped(pit = runif(length(group)), group = group, interpolate_adj = FALSE),
+    "'pit' specified"
+  )
 })
 
 test_that("ppc_freqpoly_grouped returns a ggplot object", {

tests/testthat/test-ppc-input-validation.R

@@ -3,7 +3,6 @@ context("PPC: input validation")
 
 source(test_path("data-for-ppc-tests.R"))
 
-# validating y ------------------------------------------------------------
 test_that("validate_y works", {
   expect_identical(validate_y(y), y)
   expect_identical(validate_y(as.array(y)), y)
@@ -19,7 +18,6 @@ test_that("validate_y throws errors", {
   expect_error(validate_y(c(y, NA)), "NAs not allowed")
 })
 
-# validating yrep ----------------------------------------------------------
 test_that("validate_predictions works", {
   expect_identical(validate_predictions(yrep, length(y)), yrep)
   expect_equal(validate_predictions(yrep2, length(y2)), yrep2)
@@ -35,7 +33,6 @@ test_that("validate_predictions throws errors", {
   expect_error(validate_predictions(yrep, length(y2)), "must be equal to ")
 })
 
-# validating group --------------------------------------------------------
 test_that("validate_group works", {
   expect_identical(validate_group(1:3, n_obs = 3), as.factor(1:3))
   expect_identical(validate_group(as.numeric(1:3), n_obs = 3), as.factor(1:3))
@@ -49,8 +46,6 @@ test_that("validate_group throws errors", {
                "must be equal to the number of observations")
 })
 
-
-# validating x --------------------------------------------------------
 test_that("validate_x works", {
   x <- rnorm(3)
   expect_identical(validate_x(x, y = 1:3), x)
@@ -65,3 +60,11 @@ test_that("validate_x throws errors", {
   expect_error(validate_x(c(1,2,NA), y = 1:3), "NAs not allowed")
   expect_error(validate_x(1:4, y = 1:3), "must be equal to")
 })
+
+test_that("validate_pit works", {
+  expect_error(validate_pit("pit"), "is.numeric")
+  expect_error(validate_pit(cbind(1, 2)), "vector")
+  expect_error(validate_pit(-1), "between 0 and 1")
+  expect_error(validate_pit(NA), "NAs not allowed")
+  expect_identical(validate_pit(c(name = 0.5)), 0.5)
+})

tests/testthat/test-ppc-loo.R

@@ -34,7 +34,16 @@ test_that("ppc_loo_pit gives deprecation warning but still works", {
 test_that("ppc_loo_pit_overlay returns ggplot object", {
   skip_if_not_installed("rstanarm")
   skip_if_not_installed("loo")
-  expect_gg(p1 <- ppc_loo_pit_overlay(y, yrep, lw, samples = 25))
+  expect_gg(ppc_loo_pit_overlay(y, yrep, lw, samples = 25))
+})
+
+test_that("ppc_loo_pit_overlay warns about binary data", {
+  skip_if_not_installed("rstanarm")
+  skip_if_not_installed("loo")
+  expect_warning(
+    ppc_loo_pit_overlay(rep(1, length(y)), yrep, lw),
+    "not recommended for binary data"
+  )
 })
 
 test_that("ppc_loo_pit_overlay works with boundary_correction=TRUE", {