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,54 @@
+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, ...)
+      }
+    }
+  )
+}
+
+######## Mock Compile Expectations #######
+
+# These helpers mimic `assert_called` and `assert_not_called` in other languages.
+#
+# Logic
+# `expect_mock_compile`
+#     passes if mock_compile is called (at all, doesn't matter how many times)
+#     fails if mock_compile is never called
+# `expect_no_mock_compile` is the inverse. It
+#      passes if mock_compile is *not* called at all
+#      fails if mock_compile is called (even once)
+#
+# Implementation:
+# `with_mocked_cli`
+#    if a compile is triggered
+#      emits a message with the contents `mock-compile-was-called`
+#      (defined as wsl_compatible_run being called with make model-*)
+# `expect_mock_compile` checks for this message:
+#     passes if it detects such a message
+#     fails if it does not
+# `expect_no_mock_compile`
+#      fails if a message with exactly this text is detected
+#      passes if no such message is detected
+#      messages with any other text does not impact `expect_no_mock_compile`
+
+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,207 @@
+
+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
+)
+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);
+    }
+}"
+
+test_that("cmdstan_model works with user_header with mock", {
+  skip_if(os_is_macos())
+  tmpfile <- tempfile(fileext = ".hpp")
+  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"
+    )
+  )
+})
+
+test_that("user_header precedence order is correct", {
+
+  tmp_files <- lapply(1:3, function(n) tempfile(fileext = ".hpp"))
+  lapply(tmp_files, function(filename) cat(hpp, file = filename, sep = "\n"))
+  on.exit(
+    {lapply(tmp_files, function(filename) file.remove(filename))},
+    add = TRUE
+  )
+
+  with_mocked_cli(
+    compile_ret = list(status = 1),
+    info_ret = list(),
+    code = expect_warning({
+      mod <- cmdstan_model(
+        stan_file = testing_stan_file("bernoulli_external"),
+        user_header = tmp_files[[1]],
+        cpp_options = list(
+          USER_HEADER = tmp_files[[2]],
+          user_header = tmp_files[[3]]
+        ),
+        dry_run = TRUE
+      )
+    }, "User header specified both")
+  )
+  expect_equal(mod$precompile_cpp_options()$user_header, tmp_files[[1]])
+
+  with_mocked_cli(
+    compile_ret = list(status = 1),
+    info_ret = list(),
+    code = expect_warning({
+      mod <- cmdstan_model(
+        stan_file = testing_stan_file("bernoulli_external"),
+        cpp_options = list(
+          USER_HEADER = tmp_files[[2]],
+          user_header = tmp_files[[3]]
+        ),
+        dry_run = TRUE
+      )
+    }, "User header specified both")
+  )
+  expect_equal(mod$precompile_cpp_options()$user_header, tmp_files[[2]])
+
+  with_mocked_cli(
+    compile_ret = list(status = 1),
+    info_ret = list(),
+    code = expect_warning({
+      mod <- cmdstan_model(
+        stan_file = testing_stan_file("bernoulli_external"),
+        cpp_options = list(
+          user_header = tmp_files[[3]],
+          USER_HEADER = tmp_files[[2]]
+        ),
+        dry_run = TRUE
+      )
+    }, "User header specified both")
+  )
+  expect_equal(mod$precompile_cpp_options()$user_header, tmp_files[[3]])
+
+})