Tests: leave the R session unchanged after the tests and remove the manual cleanup

DESCRIPTION

@@ -72,6 +72,7 @@ Suggests:
     doRNG,
     unix,
     testthat (>= 3.1.7),
+    withr (>= 3.0.3),
     vdiffr,
     knitr,
     rmarkdown,

NEWS.md

@@ -34,6 +34,7 @@ If you read this from a place other than <https://mc-stan.org/projpred/news/inde
 * Filter the warning "non-integer response values in a poisson model" of lme4 (>= 2.1-1), which every projection onto a Poisson submodel with group-level terms would give. (GitHub: #585)
 * With `options(projpred.PQL = TRUE)`, remove the warnings that every projection gave: the "iteration" messages of `MASS::glmmPQL()`, the warnings about non-integer Poisson responses, and "Unrecognized submodel fit" in the convergence check. (GitHub: #585)
 * Tests: Add tests that run on CRAN for the submodel fitters from lme4, MASS, gamm4, ordinal and mclogit. (GitHub: #585)
+* Tests: Leave the options, the random seed and the global environment of the R session unchanged after the tests, also when a test fails, and remove the manual cleanup of the test workspace. (GitHub: #586)
 
 
 # projpred 2.11.0

tests/testthat/helpers/skips.R

@@ -0,0 +1,9 @@
+# Skips -----------------------------------------------------------------------
+
+# Skip a test that only loops over the test setups in `x` (for example
+# `refmods`) if `x` is empty. On CRAN, the setup fits no reference models, so
+# such a test would run no expectation; the skip reports the reason.
+skip_if_no_setups <- function(x) {
+  skip_if(length(x) == 0,
+          paste0("`", deparse(substitute(x)), "` is empty (no test setups)"))
+}

tests/testthat/setup.R

@@ -4,6 +4,22 @@
 
 # General setup -----------------------------------------------------------
 
+# withr::local_seed() restores the seed only since withr 3.0.3:
+if (utils::packageVersion("withr") < "3.0.3") {
+  stop("The tests need withr (>= 3.0.3), see DESCRIPTION.")
+}
+
+# When the tests end, restore the global options (and remove the ones that the
+# tests added). testthat restores its own options:
+opts_orig <- options()
+opts_orig <- opts_orig[!startsWith(names(opts_orig), "testthat")]
+withr::defer({
+  opts_new <- setdiff(names(options()), names(opts_orig))
+  opts_new <- opts_new[!startsWith(opts_new, "testthat")]
+  options(stats::setNames(vector("list", length(opts_new)), opts_new))
+  options(opts_orig)
+}, envir = testthat::teardown_env())
+
 options(warn = 1)
 
 # These switches may be set to `FALSE` to save time (e.g., when debugging
@@ -156,6 +172,9 @@ use_fac <- TRUE
 # Use polym() instead of poly()?:
 use_polym <- FALSE
 
+source(testthat::test_path("helpers", "skips.R"), local = TRUE)
+# When the tests end, restore the state of the random number generator:
+withr::local_preserve_seed(.local_envir = testthat::teardown_env())
 source(testthat::test_path("helpers", "unlist_cust.R"), local = TRUE)
 source(testthat::test_path("helpers", "testers.R"), local = TRUE)
 source(testthat::test_path("helpers", "args.R"), local = TRUE)
@@ -617,12 +636,17 @@ offss_tst <- list(with_offs = list(), # with_offs = list(offset = offs_tst),
 # rstanarm:::kfold.stanreg() seems to assume these objects to lie in the
 # global environment. Since `testthat` uses a new environment for running
 # the tests (see `?testthat::test_env`), we need the following code to be
-# able to run devtools::test():
+# able to run devtools::test(). The withr::defer() below removes them again
+# when the tests end:
+f_objs_global <- character()
 for (obj_symb_chr in c(paste0("f_", fam_nms_trad))) {
   if (!exists(obj_symb_chr, envir = .GlobalEnv)) {
     assign(obj_symb_chr, get(obj_symb_chr), envir = .GlobalEnv)
+    f_objs_global <- c(f_objs_global, obj_symb_chr)
   }
 }
+withr::defer(rm(list = f_objs_global, envir = .GlobalEnv),
+             envir = testthat::teardown_env())
 
 args_fit <- lapply(pkg_nms, function(pkg_nm) {
   # Depending on the package used for fitting the reference model, `mod_nms`

tests/testthat/test_as_matrix.R

@@ -1,5 +1,3 @@
-context("as.matrix.projection()")
-
 test_that("as.matrix.projection() works", {
   skip_if_not(run_prj)
   for (tstsetup in names(prjs)) {
@@ -221,12 +219,12 @@ test_that("as.matrix.projection() works", {
     ###
     if (run_snaps) {
       if (testthat_ed_max2) local_edition(3)
-      width_orig <- options(width = 145)
-      expect_snapshot({
-        print(tstsetup)
-        print(rlang::hash(m)) # message(m)
+      withr::with_options(list(width = 145), {
+        expect_snapshot({
+          print(tstsetup)
+          print(rlang::hash(m)) # message(m)
+        })
       })
-      options(width_orig)
       if (testthat_ed_max2) local_edition(2)
     }
   }
@@ -306,11 +304,11 @@ test_that(paste(
 
 if (run_snaps) {
   if (testthat_ed_max2) local_edition(3)
-  width_orig <- options(width = 145)
 
   test_that(paste(
     "as.matrix.projection() works for projections based on varsel() output"
   ), {
+    withr::local_options(list(width = 145))
     skip_if_not(run_vs)
     for (tstsetup in names(prjs_vs)) {
       if (args_prj_vs[[tstsetup]]$mod_nm == "gam") {
@@ -350,6 +348,7 @@ if (run_snaps) {
   test_that(paste(
     "as.matrix.projection() works for projections based on cv_varsel() output"
   ), {
+    withr::local_options(list(width = 145))
     skip_if_not(run_cvvs)
     for (tstsetup in names(prjs_cvvs)) {
       if (args_prj_cvvs[[tstsetup]]$mod_nm == "gam") {
@@ -386,6 +385,5 @@ if (run_snaps) {
     }
   })
 
-  options(width_orig)
   if (testthat_ed_max2) local_edition(2)
 }

tests/testthat/test_augdat.R

@@ -1,10 +1,3 @@
-context("augmented-data projection")
-
-# Setup -------------------------------------------------------------------
-
-# Needed to clean up the workspace afterwards (i.e, after this test file):
-ls_bu <- ls()
-
 # augdat.R ----------------------------------------------------------------
 
 nobs_orig_tst <- 4L
@@ -188,9 +181,7 @@ test_that(paste(
   "the traditional projection"
 ), {
   skip_if_not(run_prj)
-  if (exists(".Random.seed", envir = .GlobalEnv)) {
-    rng_old <- get(".Random.seed", envir = .GlobalEnv)
-  }
+  withr::local_preserve_seed()
   tstsetups <- grep("\\.brnll\\..*\\.augdat\\.", names(prjs), value = TRUE)
   for (tstsetup in tstsetups) {
     tstsetup_trad <- sub("\\.augdat\\.", ".trad_compare.", tstsetup)
@@ -214,7 +205,6 @@ test_that(paste(
     expect_equal(structure(unclass(eta_aug), ndiscrete = NULL), eta_trad,
                      info = tstsetup)
   }
-  if (exists("rng_old")) assign(".Random.seed", rng_old, envir = .GlobalEnv)
 })
 
 ## Projection -------------------------------------------------------------
@@ -458,30 +448,33 @@ test_that(paste(
     # Sometimes, there are seemingly large differences on logit scale which are
     # probably due to numerical overflow of probabilities (i.e., on probability
     # scale) towards 1 or underflow towards zero. Thus, compare on probability
-    # scale if the comparison on logit scale fails:
-    tryCatch(expect_equal(summs_sub_mu, summs_sub_mu_trad,
-                          tolerance = 1e-6, info = tstsetup),
-             error = function(e) {
-               stopifnot(is_kfold)
-               expect_equal(ilinkfun_raw(summs_sub_mu, link_nm = "logit"),
-                            ilinkfun_raw(summs_sub_mu_trad, link_nm = "logit"),
-                            tolerance = 1e-5, info = tstsetup)
-             })
+    # scale if the comparison on logit scale fails (only for K-fold CV):
+    if (is_kfold &&
+        !isTRUE(all.equal(summs_sub_mu, summs_sub_mu_trad, tolerance = 1e-6))) {
+      expect_equal(ilinkfun_raw(summs_sub_mu, link_nm = "logit"),
+                   ilinkfun_raw(summs_sub_mu_trad, link_nm = "logit"),
+                   tolerance = 1e-5, info = tstsetup)
+    } else {
+      expect_equal(summs_sub_mu, summs_sub_mu_trad, tolerance = 1e-6,
+                   info = tstsetup)
+    }
     summs_sub_lppd <- do.call(cbind, lapply(summs_sub, "[[", "lppd"))
     summs_sub_lppd_trad <- unname(
       do.call(cbind, lapply(summs_sub_trad, "[[", "lppd"))
     )
     # Sometimes, there are seemingly large differences on log scale which are
     # probably due to numerical overflow of probabilities (i.e., on exp scale)
     # towards 1 or underflow towards zero. Thus, compare on exp scale if the
-    # comparison on log scale fails:
-    tryCatch(expect_equal(summs_sub_lppd, summs_sub_lppd_trad,
-                          tolerance = 1e-6, info = tstsetup),
-             error = function(e) {
-               stopifnot(is_kfold)
-               expect_equal(exp(summs_sub_lppd), exp(summs_sub_lppd_trad),
-                            tolerance = 1e-5, info = tstsetup)
-             })
+    # comparison on log scale fails (only for K-fold CV):
+    if (is_kfold &&
+        !isTRUE(all.equal(summs_sub_lppd, summs_sub_lppd_trad,
+                          tolerance = 1e-6))) {
+      expect_equal(exp(summs_sub_lppd), exp(summs_sub_lppd_trad),
+                   tolerance = 1e-5, info = tstsetup)
+    } else {
+      expect_equal(summs_sub_lppd, summs_sub_lppd_trad, tolerance = 1e-6,
+                   info = tstsetup)
+    }
     summs_ref <- cvvs$summaries$ref
     summs_ref$mu <- structure(unclass(summs_ref$mu), ndiscrete = NULL)
     summs_ref$mu <- summs_ref$mu[(nobsv + 1):(2 * nobsv)]
@@ -530,7 +523,7 @@ test_that(paste(
     } else {
       tol_smmry <- 1e-6
     }
-    compare_exp <- function(e) {
+    compare_exp <- function() {
       stopifnot(is_kfold)
       # Check that we have the default `stats` in this case, meaning only the
       # ELPD:
@@ -552,9 +545,16 @@ test_that(paste(
       expect_equal(smmry_pd$elpd.se, smmry_pd_trad$elpd.se, tolerance = 1e-3,
                    info = tstsetup)
     }
-    tryCatch(expect_equal(smmry_cvvs$perf_sub, smmry_cvvs_trad$perf_sub,
-                          tolerance = tol_smmry, info = tstsetup),
-             error = compare_exp)
+    # For K-fold CV, compare on exp scale if the comparison on log scale fails
+    # (see compare_exp()):
+    if (is_kfold &&
+        !isTRUE(all.equal(smmry_cvvs$perf_sub, smmry_cvvs_trad$perf_sub,
+                          tolerance = tol_smmry))) {
+      compare_exp()
+    } else {
+      expect_equal(smmry_cvvs$perf_sub, smmry_cvvs_trad$perf_sub,
+                   tolerance = tol_smmry, info = tstsetup)
+    }
   }
 })
 
@@ -610,7 +610,7 @@ test_that(paste(
     } else {
       tol_smmry <- 1e-6
     }
-    compare_exp <- function(e) {
+    compare_exp <- function() {
       stopifnot(is_kfold)
 
       smmry_pd <- smmry_cvvs$perf_sub
@@ -642,15 +642,17 @@ test_that(paste(
                    smmry_pd_trad[se_cols_trad],
                    tolerance = 1e-3, info = tstsetup)
     }
-    tryCatch(expect_equal(smmry_cvvs$perf_sub, smmry_cvvs_trad$perf_sub,
-                          tolerance = tol_smmry, info = tstsetup),
-             error = compare_exp)
+    # For K-fold CV, compare on exp scale if the comparison on log scale fails
+    # (see compare_exp()):
+    if (is_kfold &&
+        !isTRUE(all.equal(smmry_cvvs$perf_sub, smmry_cvvs_trad$perf_sub,
+                          tolerance = tol_smmry))) {
+      compare_exp()
+    } else {
+      expect_equal(smmry_cvvs$perf_sub, smmry_cvvs_trad$perf_sub,
+                   tolerance = tol_smmry, info = tstsetup)
+    }
     expect_equal(smmry_cvvs$perf_ref, smmry_cvvs_trad$perf_ref,
                  tolerance = tol_smmry, info = tstsetup)
   }
 })
-
-# Teardown ----------------------------------------------------------------
-
-# Clean up the workspace:
-rm(list = setdiff(ls(), ls_bu))

tests/testthat/test_augdat_predict.R

@@ -1,12 +1,4 @@
-context("augdat_predict")
-
-# Needed to clean up the workspace afterwards (i.e, after this test file):
-ls_bu <- ls()
-
-if (exists(".Random.seed", envir = .GlobalEnv)) {
-  rng_old <- get(".Random.seed", envir = .GlobalEnv)
-}
-set.seed(97531)
+withr::local_seed(97531)
 n_ap <- 120
 dat_ap <- data.frame(a = rnorm(n_ap), b = rnorm(n_ap),
                      f = factor(sample(c("u", "v", "w"), n_ap, replace = TRUE)))
@@ -109,7 +101,3 @@ test_that("`ce_ptwise` of the augmented-data families sums over the categories",
     ce_expected
   )
 })
-
-if (exists("rng_old")) assign(".Random.seed", rng_old, envir = .GlobalEnv)
-# Clean up the workspace:
-rm(list = setdiff(ls(), ls_bu))

tests/testthat/test_categ_native.R

@@ -1,12 +1,4 @@
-context("categ_native")
-
-# Needed to clean up the workspace afterwards (i.e, after this test file):
-ls_bu <- ls()
-
-if (exists(".Random.seed", envir = .GlobalEnv)) {
-  rng_old <- get(".Random.seed", envir = .GlobalEnv)
-}
-set.seed(24680)
+withr::local_seed(24680)
 n_ca <- 150
 ncat_ca <- 4
 dat_ca <- data.frame(a = rnorm(n_ca), b = rnorm(n_ca),
@@ -81,10 +73,11 @@ test_that("categ_native_multi() returns usable `multinom` objects", {
   # Cases that use fit_categ() per draw:
   expect_null(categ_native_multi(y ~ a, data = daug, family = fam,
                                  ws_aug = ws, dot_args = list(Hess = TRUE)))
-  opts_old <- options(projpred.augdat_native = FALSE)
-  expect_null(categ_native_multi(y ~ a, data = daug, family = fam,
-                                 ws_aug = ws, dot_args = list()))
-  options(opts_old)
+  expect_null(withr::with_options(
+    list(projpred.augdat_native = FALSE),
+    categ_native_multi(y ~ a, data = daug, family = fam, ws_aug = ws,
+                       dot_args = list())
+  ))
   expect_null(categ_native_multi(y ~ a, data = daug[c(2:nrow(daug), 1), ],
                                  family = fam, ws_aug = ws, dot_args = list()))
 })
@@ -120,7 +113,3 @@ test_that("the native multinomial-logit fits handle non-finite input", {
   expect_null(categ_native_multi(y ~ a + b, data = daug, family = fam,
                                  ws_aug = as.vector(w), dot_args = list()))
 })
-
-if (exists("rng_old")) assign(".Random.seed", rng_old, envir = .GlobalEnv)
-# Clean up the workspace:
-rm(list = setdiff(ls(), ls_bu))

tests/testthat/test_cumul_native.R

@@ -1,12 +1,4 @@
-context("cumul_native")
-
-# Needed to clean up the workspace afterwards (i.e, after this test file):
-ls_bu <- ls()
-
-if (exists(".Random.seed", envir = .GlobalEnv)) {
-  rng_old <- get(".Random.seed", envir = .GlobalEnv)
-}
-set.seed(8642)
+withr::local_seed(8642)
 n_cn <- 200
 ncat_cn <- 4
 x_cn <- matrix(rnorm(n_cn * 3), n_cn, 3, dimnames = list(NULL, c("a", "b", "c")))
@@ -114,10 +106,11 @@ test_that("cumul_native_multi() returns usable `polr` objects", {
   # Cases that use fit_cumul() per draw:
   expect_null(cumul_native_multi(y ~ a + b, data = daug, family = fam,
                                  ws_aug = ws, dot_args = list(Hess = TRUE)))
-  opts_old <- options(projpred.augdat_native = FALSE)
-  expect_null(cumul_native_multi(y ~ a + b, data = daug, family = fam,
-                                 ws_aug = ws, dot_args = list()))
-  options(opts_old)
+  expect_null(withr::with_options(
+    list(projpred.augdat_native = FALSE),
+    cumul_native_multi(y ~ a + b, data = daug, family = fam,
+                       ws_aug = ws, dot_args = list())
+  ))
   daug_perm <- daug[c(2:nrow(daug), 1), ]
   expect_null(cumul_native_multi(y ~ a + b, data = daug_perm, family = fam,
                                  ws_aug = ws, dot_args = list()))
@@ -175,7 +168,3 @@ test_that("the native cumulative-link fits handle non-finite input", {
                                  ws_aug = replace(as.vector(w), 3, Inf),
                                  dot_args = list()))
 })
-
-if (exists("rng_old")) assign(".Random.seed", rng_old, envir = .GlobalEnv)
-# Clean up the workspace:
-rm(list = setdiff(ls(), ls_bu))

tests/testthat/test_cvindices.R

@@ -1,5 +1,3 @@
-context("cv-indices")
-
 # tests for cv_folds and cv_ids
 
 test_that("k is valid", {