Improve Handling of cpp_options

R/args.R

@@ -715,12 +715,6 @@ validate_cmdstan_args <- function(self) {
   }
   validate_init(self$init, num_inits)
   validate_seed(self$seed, num_procs)
-  if (!is.null(self$opencl_ids)) {
-    if (cmdstan_version() < "2.26") {
-      stop("Runtime selection of OpenCL devices is only supported with CmdStan version 2.26 or newer.", call. = FALSE)
-    }
-    checkmate::assert_vector(self$opencl_ids, len = 2)
-  }
   invisible(TRUE)
 }
 

R/path.R

@@ -234,8 +234,16 @@ unset_cmdstan_path <- function() {
 }
 
 # fake a cmdstan version (only used in tests)
-fake_cmdstan_version <- function(version) {
+fake_cmdstan_version <- function(version, mod=NULL) {
   .cmdstanr$VERSION <- version
+  if(!is.null(mod)) {
+    if (!is.null(mod$.__enclos_env__$private$exe_info_)) {
+      mod$.__enclos_env__$private$exe_info_$stan_version <- version
+    }
+    if (!is.null(mod$.__enclos_env__$private$cmdstan_version_)) {
+      mod$.__enclos_env__$private$cmdstan_version_ <- version
+    }
+  }
 }
 reset_cmdstan_version <- function() {
   .cmdstanr$VERSION <- read_cmdstan_version(cmdstan_path())

tests/testthat/helper-custom-expectations.R

@@ -100,3 +100,11 @@ expect_noninteractive_silent <- function(object) {
   rlang::with_interactive(value = FALSE,
     expect_silent(object))
 }
+
+expect_equal_ignore_order <- function(object, expected, ...){
+  object <- expected[sort(names(object))]
+  expected <- expected[sort(names(expected))]
+  expect_equal(object, expected, ...)
+}
+
+expect_not_true <- function(...) expect_false(isTRUE(...))

tests/testthat/helper-mock-cli.R

@@ -0,0 +1,22 @@
+real_wcr <- wsl_compatible_run
+
+with_mocked_cli <- function(code, compile_ret, info_ret){
+  with_mocked_bindings(
+    code,
+    wsl_compatible_run = function(command, args, ...) {
+      if (
+        !is.null(command)
+        && command == 'make'
+        && !is.null(args)
+        && startsWith(basename(args[1]), 'model-')
+      ) {
+        message("mock-compile-was-called")
+        compile_ret
+      } else if (!is.null(args) && args[1] == "info") info_ret
+      else real_wcr(command = command, args = args, ...)
+    }
+  )
+}
+
+expect_mock_compile <- function(object, ...) expect_message(object, regexp = 'mock-compile-was-called', ...)
+expect_no_mock_compile <- function(object, ...) expect_no_message(object, message = 'mock-compile-was-called' , ...)

tests/testthat/helper-models.R

@@ -14,6 +14,11 @@ cmdstan_example_file <- function() {
   file.path(cmdstan_path(), "examples", "bernoulli", "bernoulli.stan")
 }
 
+cmdstan_example_exe_file <- function() {
+  # stan program in different directory from the others
+  file.path(cmdstan_path(), "examples", "bernoulli", "bernoulli.stan")
+}
+
 testing_model <- function(name) {
   cmdstan_model(stan_file = testing_stan_file(name))
 }

tests/testthat/test-example.R

@@ -1,7 +1,7 @@
 context("cmdstanr_example")
 
 test_that("cmdstanr_example works", {
-  fit_mcmc <- cmdstanr_example("logistic", chains = 2)
+  fit_mcmc <- cmdstanr_example("logistic", chains = 2, force_recompile = TRUE)
   checkmate::expect_r6(fit_mcmc, "CmdStanMCMC")
   expect_equal(fit_mcmc$num_chains(), 2)
 

tests/testthat/test-model-compile-user_header.R

@@ -0,0 +1,104 @@
+
+file_that_exists <- 'placeholder_exists'
+file_that_doesnt_exist <- 'placeholder_doesnt_exist'
+file.create(file_that_exists)
+on.exit(if(file.exists(file_that_exists)) file.remove(file_that_exists), add=TRUE, after=FALSE)
+
+make_local_orig <- cmdstan_make_local()
+cmdstan_make_local(cpp_options = list("PRECOMPILED_HEADERS"="false"))
+on.exit(cmdstan_make_local(cpp_options = make_local_orig, append = FALSE), add = TRUE, after = FALSE)
+
+test_that("cmdstan_model works with user_header with mock", {
+  skip_if(os_is_macos())
+  tmpfile <- tempfile(fileext = ".hpp")
+  hpp <-
+  "
+  #include <stan/math.hpp>
+  #include <boost/math/tools/promotion.hpp>
+  #include <ostream>
+
+  namespace bernoulli_external_model_namespace
+  {
+      template <typename T0__,
+            stan::require_all_t<stan::is_stan_scalar<T0__>>* = nullptr>
+      inline typename boost::math::tools::promote_args<T0__>::type make_odds(const T0__ &
+                                                                                 theta,
+                                                                             std::ostream *pstream__)
+      {
+          return theta / (1 - theta);
+      }
+  }"
+  cat(hpp, file = tmpfile, sep = "\n")
+
+  with_mocked_cli(compile_ret = list(status = 0), info_ret = list(), code = expect_mock_compile(
+    expect_warning(
+      expect_no_warning({
+        mod <- cmdstan_model(
+          stan_file = testing_stan_file("bernoulli_external"),
+          exe_file = file_that_exists,
+          user_header = tmpfile
+        )
+      }, message = 'Recompiling is recommended'), # this warning should not occur because recompile happens automatically
+      'Retrieving exe_file info failed' # this warning should occur
+    )
+  ))
+
+  with_mocked_cli(compile_ret = list(status = 0), info_ret = list(), code = expect_mock_compile({
+    mod_2 <- cmdstan_model(
+      stan_file = testing_stan_file("bernoulli_external"),
+      exe_file = file_that_doesnt_exist,
+      cpp_options=list(USER_HEADER=tmpfile),
+      stanc_options = list("allow-undefined")
+    )
+  }))
+
+  # Check recompilation upon changing header
+  file.create(file_that_exists)
+  with_mocked_cli(compile_ret = list(status = 0), info_ret = list(), code = expect_no_mock_compile({
+    mod$compile(quiet = TRUE, user_header = tmpfile)
+  }))
+
+  Sys.setFileTime(tmpfile, Sys.time() + 1) # touch file to trigger recompile
+  with_mocked_cli(compile_ret = list(status = 0), info_ret = list(), code = expect_mock_compile({
+    mod$compile(quiet = TRUE, user_header = tmpfile)
+  }))
+
+  # mock does not automatically update file mtime
+  Sys.setFileTime(mod$exe_file(), Sys.time() + 1) # touch file to trigger recompile
+
+  # Alternative spec of user header
+  with_mocked_cli(compile_ret = list(status = 0), info_ret = list(), code = expect_no_mock_compile({
+  mod$compile(
+    quiet = TRUE,
+    cpp_options = list(user_header = tmpfile),
+    dry_run = TRUE
+  )}))
+
+  # Error/warning messages
+  with_mocked_cli(compile_ret = list(status = 1), info_ret = list(), code = expect_error(
+    cmdstan_model(
+      stan_file = testing_stan_file("bernoulli_external"),
+      cpp_options = list(USER_HEADER = "non_existent.hpp"),
+      stanc_options = list("allow-undefined")
+    ),
+    "header file '[^']*' does not exist"
+  ))
+
+  with_mocked_cli(compile_ret = list(status = 1), info_ret = list(), code = expect_warning(
+    cmdstan_model(
+      stan_file = testing_stan_file("bernoulli_external"),
+      cpp_options = list(USER_HEADER = tmpfile, user_header = tmpfile),
+      dry_run = TRUE
+    ),
+    "User header specified both"
+  ))
+  with_mocked_cli(compile_ret = list(status = 1), info_ret = list(), code = expect_warning(
+    cmdstan_model(
+      stan_file = testing_stan_file("bernoulli_external"),
+      user_header = tmpfile,
+      cpp_options = list(USER_HEADER = tmpfile),
+      dry_run = TRUE
+    ),
+    "User header specified both"
+  ))
+})

tests/testthat/test-model-compile.R

@@ -2,19 +2,25 @@ context("model-compile")
 
 set_cmdstan_path()
 stan_program <- cmdstan_example_file()
+exe <- cmdstan_ext(strip_ext(stan_program))
+if (file.exists(exe)) file.remove(exe)
+
 mod <- cmdstan_model(stan_file = stan_program, compile = FALSE)
+
+make_local_orig <- cmdstan_make_local()
 cmdstan_make_local(cpp_options = list("PRECOMPILED_HEADERS"="false"))
+on.exit(cmdstan_make_local(cpp_options = make_local_orig, append = FALSE), add = TRUE, after = FALSE)
 
 test_that("object initialized correctly", {
   expect_equal(mod$stan_file(), stan_program)
-  expect_equal(mod$exe_file(), character(0))
+  expect_equal(mod$exe_file(), exe)
+  expect_false(file.exists(mod$exe_file()))
   expect_error(
     mod$hpp_file(),
     "The .hpp file does not exists. Please (re)compile the model.",
     fixed = TRUE
   )
 })
-
 test_that("error if no compile() before model fitting", {
   expect_error(
     mod$sample(),
@@ -25,7 +31,6 @@ test_that("error if no compile() before model fitting", {
 
 test_that("compile() method works", {
   # remove executable if exists
-  exe <- cmdstan_ext(strip_ext(mod$stan_file()))
   if (file.exists(exe)) {
     file.remove(exe)
   }
@@ -381,7 +386,6 @@ test_that("check_syntax() works with pedantic=TRUE", {
     fixed = TRUE
   )
 })
-
 test_that("check_syntax() works with include_paths", {
   stan_program_w_include <- testing_stan_file("bernoulli_include")
 
@@ -391,15 +395,20 @@ test_that("check_syntax() works with include_paths", {
 
 })
 
+
+# Test Failing Due to Side effect -----
+
 test_that("check_syntax() works with include_paths on compiled model", {
   stan_program_w_include <- testing_stan_file("bernoulli_include")
 
   mod_w_include <- cmdstan_model(stan_file = stan_program_w_include, compile=TRUE,
-                                 include_paths = test_path("resources", "stan"))
+                                 include_paths = test_path("resources", "stan"),
+                                 force_recompile = TRUE)
   expect_true(mod_w_include$check_syntax())
 
 })
 
+
 test_that("check_syntax() works with pedantic=TRUE", {
   model_code <- "
   transformed data {
@@ -496,15 +505,22 @@ test_that("cpp_options work with settings in make/local", {
 
   rebuild_cmdstan()
   mod <- cmdstan_model(stan_file = stan_program)
-  expect_null(mod$cpp_options()$STAN_THREADS)
+  expect_null(
+    expect_warning(mod$cpp_options()$stan_threads, "Use mod\\$exe_info()")
+  )
+  expect_false(mod$exe_info()$stan_threads)
+  expect_null(mod$precompile_cpp_options()$stan_threads)
 
   file.remove(mod$exe_file())
 
   cmdstan_make_local(cpp_options = list(stan_threads = TRUE), append = TRUE)
 
   file <- file.path(cmdstan_path(), "examples", "bernoulli", "bernoulli.stan")
   mod <- cmdstan_model(file)
-  expect_true(mod$cpp_options()$STAN_THREADS)
+  expect_true(
+    expect_warning(mod$cpp_options()$stan_threads, "Use mod\\$exe_info()")
+  )
+  expect_true(mod$exe_info()$stan_threads)
 
   file.remove(mod$exe_file())
 
@@ -761,7 +777,8 @@ test_that("format() works with include_paths on compiled model", {
   stan_program_w_include <- testing_stan_file("bernoulli_include")
 
   mod_w_include <- cmdstan_model(stan_file = stan_program_w_include, compile=TRUE,
-                                 include_paths = test_path("resources", "stan"))
+                                 include_paths = test_path("resources", "stan"),
+                                 force_recompile = TRUE)
   expect_output(
     mod_w_include$format(),
     "#include ",
@@ -789,6 +806,8 @@ test_that("overwrite_file works with format()", {
   }
   "
   stan_file_tmp <- write_stan_file(code)
+  on.exit(file.remove(stan_file_tmp))
+
   mod_1 <- cmdstan_model(stan_file_tmp, compile = FALSE)
   expect_false(
     any(
@@ -852,4 +871,4 @@ test_that("STANCFLAGS included from make/local", {
   }
   expect_output(print(out), out_w_flags)
   cmdstan_make_local(cpp_options = make_local_old, append = FALSE)
-})
+})

tests/testthat/test-model-generate_quantities.R

@@ -21,7 +21,6 @@ bad_arg_values <- list(
   parallel_chains = -20
 )
 
-
 test_that("generate_quantities() method runs when all arguments specified validly", {
   # specifying all arguments validly
   expect_gq_output(fit1 <- do.call(mod_gq$generate_quantities, ok_arg_values))
@@ -52,7 +51,11 @@ test_that("generate_quantities work for different chains and parallel_chains", {
   expect_gq_output(
     mod_gq$generate_quantities(data = data_list, fitted_params = fit, parallel_chains = 4)
   )
-  mod_gq <- cmdstan_model(testing_stan_file("bernoulli_ppc"), cpp_options = list(stan_threads = TRUE))
+
+  expect_call_compilation({
+    mod_gq <- cmdstan_model(testing_stan_file("bernoulli_ppc"), cpp_options = list(stan_threads = TRUE))
+  })
+
   expect_gq_output(
     mod_gq$generate_quantities(data = data_list, fitted_params = fit_1_chain, threads_per_chain = 2)
   )
@@ -91,4 +94,4 @@ test_that("generate_quantities() warns if threads specified but not enabled", {
     expect_gq_output(fit_gq <- mod_gq$generate_quantities(data = data_list, fitted_params = fit, threads_per_chain = 4)),
     "'threads_per_chain' will have no effect"
   )
-})
+})