testthat 3e

DESCRIPTION

@@ -41,7 +41,7 @@ Depends:
 Imports:
     checkmate,
     data.table,
-    jsonlite (>= 1.2.0),
+    jsonlite (>= 1.8.7),
     posterior (>= 1.5.0),
     processx (>= 3.5.0),
     R6 (>= 2.4.0),
@@ -55,6 +55,7 @@ Suggests:
     loo (>= 2.0.0),
     qs2,
     rmarkdown,
-    testthat (>= 2.1.0),
+    testthat (>= 3.3.0),
     Rcpp
 VignetteBuilder: knitr
+Config/testthat/edition: 3

tests/testthat/_snaps/model-code-print.md

@@ -0,0 +1,21 @@
+# code() and print() methods work
+
+    data {
+      int<lower=0> N;
+      array[N] int<lower=0, upper=1> y;
+    }
+    parameters {
+      real<lower=0, upper=1> theta;
+    }
+    model {
+      theta ~ beta(1, 1); // uniform prior on interval 0,1
+      y ~ bernoulli(theta);
+    }
+
+---
+
+    c("data {", "  int<lower=0> N;", "  array[N] int<lower=0, upper=1> y;", 
+    "}", "parameters {", "  real<lower=0, upper=1> theta;", "}", 
+    "model {", "  theta ~ beta(1, 1); // uniform prior on interval 0,1", 
+    "  y ~ bernoulli(theta);", "}")
+

tests/testthat/helper-custom-expectations.R

@@ -11,7 +11,11 @@ expect_compilation <- function(mod, ...) {
   }
   if(!is.null(before_mtime)) {
     after_mtime <- file.mtime(mod$exe_file())
-    expect(before_mtime != after_mtime, sprintf("Exe file '%s' has NOT changed, despite expecting (re)compilation", mod$exe_file()))
+    expect_gt(
+      after_mtime,
+      before_mtime,
+      sprintf("Exe file '%s' has NOT changed, despite expecting (re)compilation", mod$exe_file())
+    )
   }
   invisible(mod)
 }
@@ -26,7 +30,11 @@ expect_call_compilation <- function(constructor_call) {
     fail(sprint("Model executable '%s' does not exist after compilation.", mod$exe_file()))
   }
   after_mtime <- file.mtime(mod$exe_file())
-  expect(before_time <= after_mtime, sprintf("Exe file '%s' has old timestamp, despite expecting (re)compilation", mod$exe_file()))
+  expect_gt(
+    after_mtime,
+    before_time,
+    sprintf("Exe file '%s' has old timestamp, despite expecting (re)compilation", mod$exe_file())
+  )
   invisible(mod)
 }
 
@@ -40,7 +48,7 @@ expect_no_recompilation <- function(mod, ...) {
   before_mtime <- file.mtime(mod$exe_file())
   expect_interactive_message(mod$compile(...), "Model executable is up to date!")
   after_mtime <- file.mtime(mod$exe_file())
-  expect(before_mtime == after_mtime, sprintf("Model executable '%s' has changed, despite expecting no recompilation", mod$exe_file()))
+  expect_true(before_mtime == after_mtime, sprintf("Model executable '%s' has changed, despite expecting no recompilation", mod$exe_file()))
   invisible(mod)
 }
 
@@ -92,8 +100,19 @@ expect_gq_output <- function(object, num_chains = NULL) {
 }
 
 expect_interactive_message <- function(object, regexp = NULL) {
-  rlang::with_interactive(value = TRUE,
-    expect_message(object = object, regexp = regexp))
+  object <- substitute(object)
+  env <- parent.frame()
+  value <- NULL
+  rlang::with_interactive(value = TRUE, {
+    expect_message(
+      object = {
+        value <- rlang::eval_bare(object, env)
+        value
+      },
+      regexp = regexp
+    )
+  })
+  invisible(value)
 }
 
 expect_noninteractive_silent <- function(object) {

tests/testthat/helper-mock-cli.R

@@ -1,8 +1,9 @@
 real_wcr <- wsl_compatible_run
 
 with_mocked_cli <- function(code, compile_ret, info_ret) {
-  with_mocked_bindings(
-    code,
+  code <- substitute(code)
+  caller <- parent.frame()
+  local_mocked_bindings(
     wsl_compatible_run = function(command, args, ...) {
       if (
         !is.null(command)
@@ -17,8 +18,11 @@ with_mocked_cli <- function(code, compile_ret, info_ret) {
       } else {
         real_wcr(command = command, args = args, ...)
       }
-    }
+    },
+    .package = "cmdstanr",
+    .env = caller
   )
+  rlang::eval_bare(code, env = caller)
 }
 
 ######## Mock Compile Expectations #######

tests/testthat/setup.R

@@ -0,0 +1,17 @@
+cleanup_stan_artifacts <- function() {
+  all_files_in_stan <- list.files(
+    test_path("resources", "stan"),
+    full.names = TRUE,
+    recursive = TRUE
+  )
+  files_to_remove <- all_files_in_stan[!grepl("\\.stan$", all_files_in_stan)]
+
+  if (length(files_to_remove) > 0) {
+    unlink(files_to_remove, force = TRUE)
+  }
+
+  invisible(files_to_remove)
+}
+
+cleanup_stan_artifacts()
+withr::defer(cleanup_stan_artifacts(), testthat::teardown_env())

tests/testthat/test-csv.R

@@ -1,5 +1,3 @@
-context("read_cmdstan_csv")
-
 set_cmdstan_path()
 fit_bernoulli_optimize <- testing_fit("bernoulli", method = "optimize", seed = 1234)
 fit_bernoulli_variational <- testing_fit("bernoulli", method = "variational", seed = 123)
@@ -519,9 +517,10 @@ test_that("returning time works for read_cmdstan_csv", {
 
 test_that("time from read_cmdstan_csv matches time from fit$time()", {
   fit <- fit_bernoulli_thin_1
-  expect_equivalent(
+  expect_equal(
     read_cmdstan_csv(fit$output_files())$time$chains,
-    fit$time()$chains
+    fit$time()$chains,
+    ignore_attr = TRUE
   )
 })
 

tests/testthat/test-data.R

@@ -1,5 +1,3 @@
-context("data-utils")
-
 set_cmdstan_path()
 fit <- testing_fit("bernoulli", method = "sample", seed = 123)
 fit_vb <- testing_fit("bernoulli", method = "variational", seed = 123)

tests/testthat/test-example.R

@@ -1,4 +1,15 @@
-context("cmdstanr_example")
+stan_program <- "
+  data {
+    int<lower=0> N;
+    array[N] int<lower=0,upper=1> y;
+  }
+  parameters {
+    real<lower=0,upper=1> theta;
+  }
+  model {
+    y ~ bernoulli(theta);
+  }
+  "
 
 test_that("cmdstanr_example works", {
   fit_mcmc <- cmdstanr_example("logistic", chains = 2, force_recompile = TRUE)
@@ -13,26 +24,10 @@ test_that("cmdstanr_example works", {
 
   fit_vb <- cmdstanr_example("logistic", method = "variational")
   checkmate::expect_r6(fit_vb, "CmdStanVB")
-
   expect_output(print_example_program("schools"), "vector[J] theta", fixed=TRUE)
   expect_output(print_example_program("schools_ncp"), "vector[J] theta_raw", fixed=TRUE)
 })
 
-
-# used in multiple tests below
-stan_program <- "
-  data {
-    int<lower=0> N;
-    array[N] int<lower=0,upper=1> y;
-  }
-  parameters {
-    real<lower=0,upper=1> theta;
-  }
-  model {
-    y ~ bernoulli(theta);
-  }
-  "
-
 test_that("write_stan_file writes Stan file correctly", {
   skip_if_not_installed("rlang")
   f1 <- write_stan_file(stan_program)
@@ -47,17 +42,16 @@ test_that("write_stan_file writes Stan file correctly", {
 })
 
 test_that("write_stan_file writes to specified directory and filename", {
-  dir <- file.path(test_path(), "answers")
+  dir <- withr::local_tempdir()
+  explicit_dir <- withr::local_tempdir()
   expect_equal(dirname(f1 <- write_stan_file(stan_program, dir = dir, basename = "pasta")),
                absolute_path(dir))
   expect_equal(f2 <- write_stan_file(stan_program, dir = dir, basename = "fruit.stan"),
                absolute_path(file.path(dir, "fruit.stan")))
   expect_equal(f3 <- write_stan_file(stan_program, dir = dir, basename = "vegetable"),
                absolute_path(file.path(dir, "vegetable.stan"))) # should add .stan extension if missing
-  expect_equal(f4 <- write_stan_file(stan_program, dir = tempdir(), basename = "test"),
-               absolute_path(file.path(tempdir(), "test.stan")))
-
-  try(file.remove(f1, f2, f3, f4), silent = TRUE)
+  expect_equal(f4 <- write_stan_file(stan_program, dir = explicit_dir, basename = "test"),
+               absolute_path(file.path(explicit_dir, "test.stan")))
 })
 
 test_that("write_stan_file creates dir if necessary", {
@@ -69,7 +63,7 @@ test_that("write_stan_file creates dir if necessary", {
 
 test_that("write_stan_file by default creates the same file for the same Stan model", {
   skip_if_not_installed("rlang")
-  dir <- file.path(test_path(), "answers")
+  dir <- withr::local_tempdir()
 
   f1 <- write_stan_file(stan_program, dir = dir)
   mtime1 <- file.info(f1)$mtime
@@ -95,24 +89,16 @@ test_that("write_stan_file by default creates the same file for the same Stan mo
 
   mtime5 <- file.info(f5)$mtime
   expect_true(mtime1 < mtime5)
-
-
-  try(file.remove(f1, f2, f4), silent = TRUE)
 })
 
 test_that("cmdstanr_write_stan_file_dir option works", {
   base_dir <- tempdir()
-  test_dir <- file.path(base_dir, "option_test")
-  if (!dir.exists(test_dir)) {
-    dir.create(test_dir)
-  }
-  options("cmdstanr_write_stan_file_dir" = test_dir)
-  file <- write_stan_file(stan_program)
-  expect_equal(repair_path(dirname(file)), repair_path(test_dir))
-  options("cmdstanr_write_stan_file_dir" = NULL)
+  test_dir <- withr::local_tempdir(pattern = "option_test")
+  local({
+    withr::local_options(list("cmdstanr_write_stan_file_dir" = test_dir))
+    file <- write_stan_file(stan_program)
+    expect_equal(repair_path(dirname(file)), repair_path(test_dir))
+  })
   file <- write_stan_file(stan_program)
   expect_equal(repair_path(dirname(file)), repair_path(base_dir))
-  if (!dir.exists(test_dir)) {
-    file.remove(test_dir)
-  }
 })

tests/testthat/test-failed-chains.R

@@ -1,4 +1,3 @@
-context("failed chains")
 set_cmdstan_path()
 stan_program <- testing_stan_file("chain_fails")
 stan_program_init_warnings <- testing_stan_file("init_warnings")

tests/testthat/test-fit-gq.R

@@ -1,5 +1,3 @@
-context("fitted-gq")
-
 set_cmdstan_path()
 fit <- testing_fit("bernoulli", method = "sample", seed = 123)
 fit_gq <- testing_fit("bernoulli_ppc", method = "generate_quantities", seed = 123, fitted_params = fit)
@@ -78,7 +76,7 @@ test_that("print() method works after gq", {
     fit_gq$print(variable = "unknown", max_rows = 20),
     "Can't find the following variable(s): unknown",
     fixed = TRUE
-  ) # unknown parameter
+  )
 
   out <- capture.output(fit_gq$print("y_rep"))
   expect_length(out, 11) # columns names + 1 y_rep

tests/testthat/test-fit-init.R

@@ -1,4 +1,3 @@
-context("fitted-inits")
 set_cmdstan_path()
 
 data_list_schools <- testing_data("schools")

tests/testthat/test-fit-laplace.R

@@ -1,5 +1,3 @@
-context("fitted-laplace")
-
 set_cmdstan_path()
 fit_laplace <- testing_fit("logistic", method = "laplace", seed = 100)
 PARAM_NAMES <- c("alpha", "beta[1]", "beta[2]", "beta[3]")

tests/testthat/test-fit-mcmc.R

@@ -1,5 +1,3 @@
-context("fitted-mcmc")
-
 set_cmdstan_path()
 fit_mcmc <- testing_fit("logistic", method = "sample",
                         seed = 123, chains = 2)
@@ -139,7 +137,7 @@ test_that("print() method works after mcmc", {
     fit$print(variable = "unknown", max_rows = 20),
     "Can't find the following variable(s): unknown",
     fixed = TRUE
-  ) # unknown parameter
+  )
 
   out <- capture.output(fit$print("theta"))
   expect_length(out, 9) # columns names + 8 thetas
@@ -331,23 +329,20 @@ test_that("loo works for all draws storage formats", {
   skip_if_not_installed("loo")
   fit <- testing_fit("bernoulli_log_lik")
 
-  options(cmdstanr_draws_format = "draws_array")
+  withr::local_options(list(cmdstanr_draws_format = "draws_array"))
   expect_s3_class(suppressWarnings(fit$loo()), "loo")
 
-  options(cmdstanr_draws_format = "draws_df")
+  withr::local_options(list(cmdstanr_draws_format = "draws_df"))
   expect_s3_class(suppressWarnings(fit$loo()), "loo")
 
-  options(cmdstanr_draws_format = "draws_matrix")
+  withr::local_options(list(cmdstanr_draws_format = "draws_matrix"))
   expect_s3_class(suppressWarnings(fit$loo()), "loo")
 
-  options(cmdstanr_draws_format = "draws_list")
+  withr::local_options(list(cmdstanr_draws_format = "draws_list"))
   expect_s3_class(suppressWarnings(fit$loo()), "loo")
 
-  options(cmdstanr_draws_format = "draws_rvars")
+  withr::local_options(list(cmdstanr_draws_format = "draws_rvars"))
   expect_s3_class(suppressWarnings(fit$loo()), "loo")
-
-  # reset option
-  options(cmdstanr_draws_format = NULL)
 })
 
 test_that("draws() works for different formats", {

tests/testthat/test-fit-mle.R

@@ -1,5 +1,3 @@
-context("fitted-mle")
-
 set_cmdstan_path()
 fit_mle <- testing_fit("logistic", method = "optimize", seed = 123)
 mod <- testing_model("bernoulli")

tests/testthat/test-fit-shared.R

@@ -1,5 +1,3 @@
-context("fitted-shared-methods")
-
 set_cmdstan_path()
 fits <- list()
 fits[["sample"]] <- testing_fit("logistic", method = "sample",

tests/testthat/test-fit-vb.R

@@ -1,5 +1,3 @@
-context("fitted-vb")
-
 set_cmdstan_path()
 fit_vb <- testing_fit("logistic", method = "variational", seed = 123)
 fit_vb_sci_not <- testing_fit("logistic", method = "variational", seed = 123, iter = 200000, adapt_iter = 100000)