Merge pull request #818 from martinmodrak/813-user_header

Improve handling of user header

Author: rok-cesnovar

R/model.R

@@ -397,6 +397,8 @@ CmdStanModel <- R6::R6Class(
 #'   `functions` field in the compiled model object. This can also be done after
 #'   compilation using the
 #'   [`$expose_functions()`][model-method-expose_functions] method.
+#' @param dry_run (logical) If `TRUE`, the code will do all checks before compilation,
+#'   but skip the actual C++ compilation. Used to speedup tests.
 #'
 #' @param threads Deprecated and will be removed in a future release. Please
 #'   turn on threading via `cpp_options = list(stan_threads = TRUE)` instead.
@@ -450,8 +452,10 @@ compile <- function(quiet = TRUE,
                     compile_model_methods = FALSE,
                     compile_hessian_method = FALSE,
                     compile_standalone = FALSE,
+                    dry_run = FALSE,
                     #deprecated
                     threads = FALSE) {
+
   if (length(self$stan_file()) == 0) {
     stop("'$compile()' cannot be used because the 'CmdStanModel' was not created with a Stan file.", call. = FALSE)
   }
@@ -500,15 +504,63 @@ compile <- function(quiet = TRUE,
     exe <- self$exe_file()
   }
 
+  # Resolve stanc and cpp options
+  if (pedantic) {
+    stanc_options[["warn-pedantic"]] <- TRUE
+  }
+
+  if (isTRUE(cpp_options$stan_opencl)) {
+    stanc_options[["use-opencl"]] <- TRUE
+  }
+
+  # Note that unlike cpp_options["USER_HEADER"], the user_header variable is deliberately
+  # not transformed with wsl_safe_path() as that breaks the check below on WSLv1
+  if (!is.null(user_header)) {
+    if (!is.null(cpp_options[["USER_HEADER"]]) || !is.null(cpp_options[["user_header"]])) {
+      warning("User header specified both via user_header argument and via cpp_options arguments")
+    }
+
+    cpp_options[["USER_HEADER"]] <- wsl_safe_path(absolute_path(user_header))
+    stanc_options[["allow-undefined"]] <- TRUE
+    private$using_user_header_ <- TRUE
+  }
+  else if (!is.null(cpp_options[["USER_HEADER"]])) {
+    if(!is.null(cpp_options[["user_header"]])) {
+      warning('User header specified both via cpp_options[["USER_HEADER"]] and cpp_options[["user_header"]].', call. = FALSE)
+    }
+
+    user_header <- cpp_options[["USER_HEADER"]]
+    cpp_options[["USER_HEADER"]] <- wsl_safe_path(absolute_path(cpp_options[["USER_HEADER"]]))
+    private$using_user_header_ <- TRUE
+  }
+  else if (!is.null(cpp_options[["user_header"]])) {
+    user_header <- cpp_options[["user_header"]]
+    cpp_options[["user_header"]] <- wsl_safe_path(absolute_path(cpp_options[["user_header"]]))
+    private$using_user_header_ <- TRUE
+  }
+
+
+  if(!is.null(user_header)) {
+    user_header <- absolute_path(user_header) # As mentioned above, just absolute, not wsl_safe_path()
+    if(!file.exists(user_header)) {
+      stop(paste0("User header file '", user_header, "' does not exist."), call. = FALSE)
+    }
+  }
+
   # compile if:
   # - the user forced compilation,
   # - the executable does not exist
   # - the stan model was changed since last compilation
+  # - a user header is used and the user header changed since last compilation (#813)
   if (!file.exists(exe)) {
     force_recompile <- TRUE
   } else if (file.exists(self$stan_file())
              && file.mtime(exe) < file.mtime(self$stan_file())) {
     force_recompile <- TRUE
+  } else if (!is.null(user_header)
+             && file.exists(user_header)
+             && file.mtime(exe) < file.mtime(user_header)) {
+    force_recompile <- TRUE
   }
 
   if (!force_recompile) {
@@ -530,7 +582,7 @@ compile <- function(quiet = TRUE,
 
   if (os_is_wsl() && (compile_model_methods || compile_standalone)) {
     warning("Additional model methods and standalone functions are not ",
-            "currently available with WSL CmdStan and will not be compiled",
+            "currently available with WSLv1 CmdStan and will not be compiled.",
             call. = FALSE)
     compile_model_methods <- FALSE
     compile_standalone <- FALSE
@@ -548,23 +600,6 @@ compile <- function(quiet = TRUE,
 
   stancflags_val <- include_paths_stanc3_args(include_paths)
 
-  if (pedantic) {
-    stanc_options[["warn-pedantic"]] <- TRUE
-  }
-
-  if (isTRUE(cpp_options$stan_opencl)) {
-    stanc_options[["use-opencl"]] <- TRUE
-  }
-  if (!is.null(user_header)) {
-    cpp_options[["USER_HEADER"]] <- wsl_safe_path(user_header)
-    stanc_options[["allow-undefined"]] <- TRUE
-  }
-  if (!is.null(cpp_options[["USER_HEADER"]])) {
-    cpp_options[["USER_HEADER"]] <- wsl_safe_path(absolute_path(cpp_options[["USER_HEADER"]]))
-  }
-  if (!is.null(cpp_options[["user_header"]])) {
-    cpp_options[["user_header"]] <- wsl_safe_path(absolute_path(cpp_options[["user_header"]]))
-  }
   if (is.null(stanc_options[["name"]])) {
     stanc_options[["name"]] <- paste0(self$model_name(), "_model")
   }
@@ -588,10 +623,17 @@ compile <- function(quiet = TRUE,
   self$functions$hpp_code <- get_standalone_hpp(temp_stan_file, stancflags_standalone)
   self$functions$external <- !is.null(user_header)
   self$functions$existing_exe <- FALSE
+
+  stancflags_val <- paste0("STANCFLAGS += ", stancflags_val, paste0(" ", stancflags_combined, collapse = " "))
+
+  if (dry_run) {
+    return(invisible(self))
+  }
+
   if (compile_standalone) {
     expose_stan_functions(self$functions, !quiet)
   }
-  stancflags_val <- paste0("STANCFLAGS += ", stancflags_val, paste0(" ", stancflags_combined, collapse = " "))
+
   withr::with_path(
     c(
       toolchain_PATH_env_var(),

man/model-method-compile.Rd

@@ -1,3 +1,34 @@
+#' @param ... arguments passed to mod$compile()
+expect_compilation <- function(mod, ...) {
+  if(length(mod$exe_file()) > 0 && file.exists(mod$exe_file())) {
+    before_mtime <- file.mtime(mod$exe_file())
+  } else {
+    before_mtime <- NULL
+  }
+  expect_interactive_message(mod$compile(...), "Compiling Stan program...")
+  if(length(mod$exe_file()) == 0 || !file.exists(mod$exe_file())) {
+    fail(sprint("Model executable '%s' does not exist after compilation.", mod$exe_file()))
+  }
+  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()))
+  }
+  invisible(mod)
+}
+
+#' @param ... arguments passed to mod$compile()
+expect_no_recompilation <- function(mod, ...) {
+  if(length(mod$exe_file()) == 0 || !file.exists(mod$exe_file())) {
+    fail(sprint("Model executable '%s' does not exist, cannot test if recompilation is triggerred.", mod$exe_file()))
+  }
+
+  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()))
+  invisible(mod)
+}
+
 expect_sample_output <- function(object, num_chains = NULL) {
 
   output <- "Running MCMC with"

tests/testthat/helper-custom-expectations.R

@@ -4,6 +4,7 @@ set_cmdstan_path()
 stan_program <- cmdstan_example_file()
 mod <- cmdstan_model(stan_file = stan_program, compile = FALSE)
 
+
 test_that("object initialized correctly", {
   expect_equal(mod$stan_file(), stan_program)
   expect_equal(mod$exe_file(), character(0))
@@ -28,8 +29,8 @@ test_that("compile() method works", {
   if (file.exists(exe)) {
     file.remove(exe)
   }
-  expect_interactive_message(mod$compile(quiet = TRUE), "Compiling Stan program...")
-  expect_interactive_message(mod$compile(quiet = TRUE), "Model executable is up to date!")
+  expect_compilation(mod, quiet = TRUE)
+  expect_no_recompilation(mod, quiet = TRUE)
   checkmate::expect_file_exists(mod$hpp_file())
   checkmate::expect_file_exists(exe)
   file.remove(exe)
@@ -39,10 +40,7 @@ test_that("compile() method works", {
 
 test_that("compile() method forces recompilation force_recompile = TRUE", {
   mod$compile(quiet = TRUE)
-  expect_interactive_message(
-    mod$compile(quiet = TRUE, force_recompile = TRUE),
-    "Compiling Stan program..."
-  )
+  expect_compilation(mod, quiet = TRUE, force_recompile = TRUE)
 })
 
 test_that("compile() method forces recompilation if model modified", {
@@ -52,7 +50,7 @@ test_that("compile() method forces recompilation if model modified", {
     mod$compile(quiet = TRUE)
   }
   Sys.setFileTime(mod$stan_file(), Sys.time() + 1) #touch file to trigger recompile
-  expect_interactive_message(mod$compile(quiet = TRUE), "Compiling Stan program...")
+  expect_compilation(mod, quiet = TRUE)
 })
 
 test_that("compile() method works with spaces in path", {
@@ -70,7 +68,7 @@ test_that("compile() method works with spaces in path", {
   if (file.exists(exe)) {
     file.remove(exe)
   }
-  expect_interactive_message(mod_spaces$compile(), "Compiling Stan program...")
+  expect_compilation(mod_spaces)
   file.remove(stan_model_with_spaces)
   file.remove(exe)
   unlink(dir_with_spaces, recursive = TRUE)
@@ -156,6 +154,8 @@ test_that("switching threads on and off works without rebuild", {
   mod$compile(force_recompile = TRUE)
   after_mtime <- file.mtime(main_path_o)
   expect_equal(before_mtime, after_mtime)
+
+  expect_warning(mod$compile(threads = TRUE, dry_run = TRUE), "deprecated")
 })
 
 test_that("multiple cpp_options work", {
@@ -595,7 +595,7 @@ test_that("cmdstan_model errors with no args ", {
 })
 
 test_that("cmdstan_model works with user_header", {
-  skip_if(os_is_macos() | (os_is_windows() && !os_is_wsl()))
+  skip_if(os_is_macos())
   tmpfile <- tempfile(fileext = ".hpp")
   hpp <-
   "
@@ -627,6 +627,43 @@ test_that("cmdstan_model works with user_header", {
     stanc_options = list("allow-undefined")
   )
   expect_true(file.exists(mod_2$exe_file()))
+
+  # Check recompilation upon changing header
+  expect_no_recompilation(mod, quiet = TRUE, user_header = tmpfile)
+
+  Sys.setFileTime(tmpfile, Sys.time() + 1) #touch file to trigger recompile
+  expect_compilation(mod, quiet = TRUE, user_header = tmpfile)
+
+  # Alternative spec of user header
+  expect_no_recompilation(mod,
+    quiet = TRUE,
+    cpp_options = list(user_header = tmpfile),
+    dry_run = TRUE
+  )
+
+  # Error/warning messages
+  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"
+  )
+
+  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"
+  )
+  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("cmdstan_model cpp_options dont captialize cxxflags ", {