improve test coverage

Author: jgabry

R/helpers-testthat.R

@@ -4,4 +4,15 @@ expect_gg <- function(x) {
 }
 expect_gtable <- function(x) testthat::expect_s3_class(x, "gtable")
 expect_mcmc_array <- function(x) testthat::expect_true(is_mcmc_array(x))
-expect_bayesplot_grid <- function(x) testthat::expect_s3_class(x, "bayesplot_grid")
+expect_bayesplot_grid <- function(x) testthat::expect_true(is_bayesplot_grid(x))
+
+
+# Insert fake divergences for testing purposes
+#
+# @param np Data frame returned by nuts_params
+# @return 'np' with every other iter marked as a divergence
+ensure_divergences <- function(np) {
+  divs <- rep_len(c(0,1), length.out = sum(np$Parameter=="divergent__"))
+  np$Value[np$Parameter=="divergent__"] <- divs
+  return(np)
+}

R/mcmc-traces.R

@@ -158,21 +158,18 @@ mcmc_trace <-
            divergences = NULL) {
 
     # deprecate 'divergences' arg in favor of 'np' (for consistency across functions)
-    if (!is.null(divergences)) {
+    if (!is.null(np) && !is.null(divergences)) {
+      stop(
+        "'np' and 'divergences' can't both be specified. ",
+        "Use only 'np' (the 'divergences' argument is deprecated)."
+      )
+    } else if (!is.null(divergences)) {
       warning(
         "The 'divergences' argument is deprecated ",
         "and will be removed in a future release. ",
         "Use the 'np' argument instead."
       )
-
-      if (is.null(np)) {
-        np <- divergences
-      } else {
-        stop(
-          "'np' and 'divergences' can't both be specified. ",
-          "Use only 'np' (the 'divergences' argument is deprecated)."
-        )
-      }
+      np <- divergences
     }
 
     check_ignored_arguments(...)

tests/testthat/test-aesthetics.R

@@ -75,6 +75,8 @@ test_that("color_scheme_set throws correct errors for custom schemes ", {
                "not found: not_a_color1, not_a_color2")
   expect_error(color_scheme_set(c("red", "blue")),
                "should be a character vector of length 1 or 6")
+  expect_error(prepare_custom_colors(c("red", "blue")),
+               "Custom color schemes must contain exactly 6 colors")
 })
 
 test_that("mixed_scheme internal function doesn't error", {
@@ -180,3 +182,4 @@ test_that("ggplot2::theme_set overrides bayesplot theme", {
 })
 
 bayesplot_theme_set(bayesplot::theme_default())
+color_scheme_set()

tests/testthat/test-extractors.R

@@ -5,7 +5,8 @@ context("Extractors")
 ITER <- 1000
 CHAINS <- 3
 fit <- stan_glm(mpg ~ wt + am, data = mtcars,
-                  iter = ITER, chains = CHAINS, refresh = 0)
+                iter = ITER, chains = CHAINS,
+                refresh = 0)
 
 x <- list(cbind(a = 1:3, b = rnorm(3)), cbind(a = 1:3, b = rnorm(3)))
 
@@ -68,6 +69,8 @@ test_that("rhat.stanreg returns correct structure", {
 })
 
 test_that("neff_ratio.stanreg returns correct structure", {
+  expect_named(neff_ratio(fit, pars = c("wt", "am")), c("wt", "am"))
+
   ratio <- neff_ratio(fit)
   expect_named(ratio)
   ans <- summary(fit)[1:length(ratio), "n_eff"] / (floor(ITER / 2) * CHAINS)

tests/testthat/test-helpers-mcmc.R

@@ -138,6 +138,10 @@ test_that("validate_chain_list works", {
   colnames(chainlist2[[1]])[1] <- "AAA"
   expect_error(validate_chain_list(chainlist2), "parameters for each chain")
 
+  chainlist3 <- chainlist
+  colnames(chainlist3[[1]]) <- c("", colnames(chainlist[[1]])[-1])
+  expect_error(validate_chain_list(chainlist3), "Some parameters are missing names")
+
   chainlist[[1]] <- chainlist[[1]][-1, ]
   expect_error(validate_chain_list(chainlist),
                "Each chain should have the same number of iterations")
@@ -205,6 +209,10 @@ test_that("transformations recycled properly if not a named list", {
 
 
 # prepare_mcmc_array ------------------------------------------------------
+test_that("prepare_mcmc_array errors if NAs", {
+  arr[1,1,1] <- NA
+  expect_error(prepare_mcmc_array(arr), "NAs not allowed")
+})
 test_that("prepare_mcmc_array processes non-array input types correctly", {
   # errors are mostly covered by tests of the many internal functions above
 

tests/testthat/test-mcmc-nuts.R

@@ -4,10 +4,9 @@ context("MCMC: nuts")
 
 ITER <- 1000
 CHAINS <- 3
-capture.output(
-  fit <- stan_glm(mpg ~ wt + am, data = mtcars,
-                  iter = ITER, chains = CHAINS, refresh = 0)
-)
+fit <- stan_glm(mpg ~ wt + am, data = mtcars,
+                iter = ITER, chains = CHAINS,
+                refresh = 0)
 np <- nuts_params(fit)
 lp <- log_posterior(fit)
 
@@ -21,6 +20,7 @@ test_that("all mcmc_nuts_* (except energy) return gtable objects", {
   expect_gtable(mcmc_nuts_stepsize(np, lp))
   expect_gtable(mcmc_nuts_stepsize(np, lp, chain = CHAINS))
 
+  np <- ensure_divergences(np)
   expect_gtable(mcmc_nuts_divergence(np, lp))
   expect_gtable(mcmc_nuts_divergence(np, lp, chain = CHAINS))
 })

tests/testthat/test-mcmc-recover.R

@@ -5,9 +5,7 @@ context("MCMC: recover")
 alpha <- 1; beta <- c(-.5, .5); sigma <- 2
 X <- matrix(rnorm(200), 100, 2)
 y <- rnorm(100, mean = c(alpha + X %*% beta), sd = sigma)
-capture.output(
-  fit <- stan_glm(y ~ ., data = data.frame(y, X))
-)
+fit <- stan_glm(y ~ ., data = data.frame(y, X), refresh = 0, iter = 500, chains = 2)
 draws <- as.matrix(fit)
 true <- c(alpha, beta, sigma)
 

tests/testthat/test-mcmc-scatter-and-parcoord.R

@@ -5,15 +5,10 @@ context("MCMC: scatter and parallel coordinates plots")
 source(test_path("data-for-mcmc-tests.R"))
 
 # also fit an rstanarm model to use with mcmc_pairs
-capture.output(
-  fit <- stan_glm(mpg ~ wt + am, data = mtcars, iter = 1000, chains = 2, refresh = 0)
-)
+fit <- stan_glm(mpg ~ wt + am, data = mtcars, iter = 1000, chains = 2, refresh = 0)
 post <- as.array(fit)
 lp <- log_posterior(fit)
-np <- nuts_params(fit)
-divs <- sample(c(0,1), size = 1000, prob = c(0.25, 0.75), replace = TRUE)
-np$Value[np$Parameter=="divergent__"] <- divs # fake divergences
-
+np <- ensure_divergences(nuts_params(fit))
 
 test_that("mcmc_scatter returns a ggplot object", {
   expect_gg(mcmc_scatter(arr, pars = c("beta[1]", "beta[2]")))
@@ -50,7 +45,9 @@ test_that("mcmc_scatter accepts NUTS info", {
 
 # mcmc_pairs  -------------------------------------------------------------
 test_that("mcmc_pairs returns a bayesplot_grid object", {
-  expect_bayesplot_grid(mcmc_pairs(arr, pars = c("(Intercept)", "sigma")))
+  g <- mcmc_pairs(arr, pars = c("(Intercept)", "sigma"))
+  expect_bayesplot_grid(g)
+  expect_equal(print(g), plot(g))
   expect_bayesplot_grid(mcmc_pairs(arr, pars = "sigma", regex_pars = "beta"))
   expect_bayesplot_grid(mcmc_pairs(arr, regex_pars = "x:[1-3]",
                                    transformations = "exp",

tests/testthat/test-mcmc-traces.R

@@ -29,6 +29,10 @@ test_that("mcmc_trace_highlight throws error if 1 chain but multiple chains requ
   expect_error(mcmc_trace_highlight(arr1chain, highlight = 1), "requires multiple chains")
 })
 
+test_that("mcmc_trace_highlight throws error if highlight > number of chains", {
+  expect_error(mcmc_trace_highlight(arr, pars = "sigma", highlight = 7), "'highlight' is 7")
+})
+
 # options -----------------------------------------------------------------
 test_that("mcmc_trace options work", {
   expect_gg(g1 <- mcmc_trace(arr, regex_pars = "beta", window = c(5, 10)))
@@ -46,41 +50,44 @@ test_that("mcmc_trace options work", {
 
 # displaying divergences in traceplot -------------------------------------
 test_that("mcmc_trace 'np' argument works", {
+  skip_if_not_installed("rstanarm")
   suppressPackageStartupMessages(library(rstanarm))
-  suppressWarnings(capture.output(
-    fit <- stan_glm(mpg ~ ., data = mtcars, iter = 200, refresh = 0,
-                    prior = hs(), adapt_delta = 0.7)
-  ))
+  fit <- stan_glm(mpg ~ wt + am, data = mtcars, iter = 1000, chains = 2, refresh = 0)
   draws <- as.array(fit)
 
   # divergences via nuts_params
-  divs <- nuts_params(fit, pars = "divergent__")
-  g <- mcmc_trace(draws, pars = "sigma", np = divs)
+  divs1 <- ensure_divergences(nuts_params(fit, pars = "divergent__"))
+  g <- mcmc_trace(draws, pars = "sigma", np = divs1)
   expect_gg(g)
   l2_data <- g$layers[[2]]$data
   expect_equal(names(l2_data), "Divergent")
 
   # divergences as vector via 'divergences' arg should throw deprecation warning
-  divs2 <- sample(c(0,1), nrow(draws), replace = TRUE)
+  divs2 <- rep_len(c(0,1), length.out = nrow(draws))
   expect_warning(
     g2 <- mcmc_trace(draws, pars = "sigma", divergences = divs2),
     regexp = "deprecated"
   )
   expect_gg(g2)
 
+  expect_error(
+    mcmc_trace(draws, pars = "sigma", np = divs1, divergences = divs2),
+    "can't both be specified"
+  )
+
   # check errors & messages
   expect_error(mcmc_trace(draws, pars = "sigma", np = 1),
                "length(divergences) == n_iter is not TRUE",
                fixed = TRUE)
-  expect_error(mcmc_trace(draws[,1:2,], pars = "sigma", np = divs),
+  expect_error(mcmc_trace(draws[,1,], pars = "sigma", np = divs1),
                "num_chains(np) == n_chain is not TRUE",
                fixed = TRUE)
-  expect_error(mcmc_trace(draws, pars = "sigma", np = divs[1:10, ]),
+  expect_error(mcmc_trace(draws, pars = "sigma", np = divs1[1:10, ]),
                "num_iters(np) == n_iter is not TRUE",
                fixed = TRUE)
 
-  divs$Value[divs$Parameter == "divergent__"] <- 0
-  expect_message(mcmc_trace(draws, pars = "sigma", np = divs),
+  divs1$Value[divs1$Parameter == "divergent__"] <- 0
+  expect_message(mcmc_trace(draws, pars = "sigma", np = divs1),
                  "No divergences to plot.")
 })
 

tests/testthat/test-ppc-intervals.R

@@ -27,8 +27,8 @@ test_that("ppc_intervals_grouped returns ggplot object", {
 })
 
 test_that("ppc_ribbon_grouped returns ggplot object", {
-  expect_gg(
-    ppc_ribbon_grouped(y, yrep, x, group, facet_args = list(scales = "fixed")))
+  expect_gg(ppc_ribbon_grouped(y, yrep, x, group))
+  expect_gg(ppc_ribbon_grouped(y, yrep, x, group, facet_args = list(scales = "fixed")))
 })
 
 test_that("ppc_intervals_data returns correct structure", {