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

DESCRIPTION

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

NEWS.md

@@ -11,6 +11,8 @@ If you read this from a place other than <https://mc-stan.org/projpred/news/inde
 
 ## Bug fixes and maintenance
 
+* 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,17 @@
 
 # General setup -----------------------------------------------------------
 
+# 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 +167,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 +631,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 -------------------------------------------------------------
@@ -454,30 +444,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)]
@@ -526,7 +519,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:
@@ -548,9 +541,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)
+    }
   }
 })
 
@@ -606,7 +606,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
@@ -638,15 +638,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_cvindices.R

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

tests/testthat/test_datafit.R

@@ -1,5 +1,3 @@
-context("datafit")
-
 # Setup -------------------------------------------------------------------
 
 # Note: Since PR #351, offsets are not supported anymore for `datafit`s. Here,
@@ -194,6 +192,7 @@ if (run_vs) {
 ## Reference model --------------------------------------------------------
 
 test_that("init_refmodel(): `object` of class `datafit` works", {
+  skip_if_no_setups(datafits)
   for (tstsetup in names(datafits)) {
     tstsetup_fit <- args_datafit[[tstsetup]]$tstsetup_fit
     with_spclformul_crr <- grepl("\\.spclformul", tstsetup)
@@ -222,6 +221,7 @@ test_that("init_refmodel(): `object` of class `datafit` works", {
 })
 
 test_that("predict.refmodel(): `object` of class `datafit` fails", {
+  skip_if_no_setups(datafits)
   for (tstsetup in names(datafits)) {
     expect_error(
       predict(datafits[[tstsetup]], newdata = dat),
@@ -430,12 +430,12 @@ test_that(paste(
               info_str = paste(tstsetup, "with_args", sep = "__"))
     if (run_snaps) {
       if (testthat_ed_max2) local_edition(3)
-      width_orig <- options(width = 145)
-      expect_snapshot({
-        print(tstsetup)
-        print(rlang::hash(pl_with_args))
+      withr::with_options(list(width = 145), {
+        expect_snapshot({
+          print(tstsetup)
+          print(rlang::hash(pl_with_args))
+        })
       })
-      options(width_orig)
       if (testthat_ed_max2) local_edition(2)
     }
   }
@@ -471,12 +471,12 @@ test_that(paste(
               info_str = paste(tstsetup, "with_args", sep = "__"))
     if (run_snaps) {
       if (testthat_ed_max2) local_edition(3)
-      width_orig <- options(width = 145)
-      expect_snapshot({
-        print(tstsetup)
-        print(rlang::hash(pp_with_args))
+      withr::with_options(list(width = 145), {
+        expect_snapshot({
+          print(tstsetup)
+          print(rlang::hash(pp_with_args))
+        })
       })
-      options(width_orig)
       if (testthat_ed_max2) local_edition(2)
     }
   }
@@ -485,6 +485,7 @@ test_that(paste(
 ## summary.vsel() ---------------------------------------------------------
 
 test_that("summary.vsel(): `object` of class `datafit` fails", {
+  skip_if_no_setups(datafits)
   for (tstsetup in names(datafits)) {
     expect_error(
       summary.vsel(datafits[[tstsetup]]),
@@ -537,12 +538,12 @@ test_that(paste(
     )
     if (run_snaps) {
       if (testthat_ed_max2) local_edition(3)
-      width_orig <- options(width = 145)
-      expect_snapshot({
-        print(tstsetup)
-        print(smmry, digits = 6)
+      withr::with_options(list(width = 145), {
+        expect_snapshot({
+          print(tstsetup)
+          print(smmry, digits = 6)
+        })
       })
-      options(width_orig)
       if (testthat_ed_max2) local_edition(2)
     }
   }
@@ -580,12 +581,12 @@ test_that(paste(
     )
     if (run_snaps) {
       if (testthat_ed_max2) local_edition(3)
-      width_orig <- options(width = 145)
-      expect_snapshot({
-        print(tstsetup)
-        print(smmry, digits = 6)
+      withr::with_options(list(width = 145), {
+        expect_snapshot({
+          print(tstsetup)
+          print(smmry, digits = 6)
+        })
       })
-      options(width_orig)
       if (testthat_ed_max2) local_edition(2)
     }
   }
@@ -606,9 +607,7 @@ test_that(paste(
   # This test sometimes behaves inpredictably when run in `R CMD check`, so skip
   # it on CRAN:
   skip_on_cran()
-  if (exists(".Random.seed", envir = .GlobalEnv)) {
-    rng_old <- get(".Random.seed", envir = .GlobalEnv)
-  }
+  withr::local_preserve_seed()
   suppressWarnings(RNGversion("3.5.0"))
   set.seed(1235)
   n <- 100
@@ -754,5 +753,4 @@ test_that(paste(
     expect_identical(ind, predictor_ranking_lasso, info = as.character(i))
   }
   RNGversion(getRversion())
-  if (exists("rng_old")) assign(".Random.seed", rng_old, envir = .GlobalEnv)
 })