Merge branch 'master' into laplace-sample

Author: jgabry

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: cmdstanr
 Title: R Interface to 'CmdStan'
-Version: 0.6.0.9000
-Date: 2023-07-25
+Version: 0.6.1.9000
+Date: 2023-08-25
 Authors@R:
     c(person(given = "Jonah", family = "Gabry", role = c("aut", "cre"),
            email = "jsg2201@columbia.edu"),

NEWS.md

@@ -1,6 +1,19 @@
-# cmdstanr 0.6.0.9000
+# cmdstanr 0.6.1.9000
+
+# cmdstanr 0.6.1
+
+* Store return codes instead of always querying exit status by @jgabry in #798
+* enable jacobian argument for optimization by @jgabry in #799
+* Fix init_model_methods for models with no data by @andrjohns in #801
+* Document a CmdStan-focused way to pre-compile Stan models in R packages by @wlandau in #809
+* Describe how to efficiently save model fit objects by @wlandau in #816
+* fix errors in doc for new methods by @jgabry in #823
+* Give informative error when exposing stan functions with precompiled model by @andrjohns in #831
+* Bugfixes in .stanfunctions, hessian model method, and exposing RNG functions by @andrjohns in #811
+* Fix variable_skeleton() with containers by @andrjohns in #832
+* Improve handling of user header by @martinmodrak in #818
+* change duplicate stdout_file to stderr_file by @jgabry in #834
 
-Items for next release
 
 # cmdstanr 0.6.0
 

R/model.R

@@ -191,6 +191,12 @@ cmdstan_model <- function(stan_file = NULL, exe_file = NULL, compile = TRUE, ...
 #'  [`$save_hpp_file()`][model-method-compile] |  Save the `.hpp` file containing the generated C++ code. |
 #'  [`$expose_functions()`][model-method-expose_functions] |  Expose Stan functions for use in R. |
 #'
+#'  ## Diagnostics
+#'
+#'  |**Method**|**Description**|
+#'  |:----------|:---------------|
+#'  [`$diagnose()`][model-method-diagnose] |  Run CmdStan's `"diagnose"` method to test gradients, return [`CmdStanDiagnose`] object. |
+#'
 #'  ## Model fitting
 #'
 #'  |**Method**|**Description**|
@@ -231,7 +237,7 @@ CmdStanModel <- R6::R6Class(
       self$functions <- new.env()
       self$functions$compiled <- FALSE
       if (!is.null(stan_file)) {
-        assert_file_exists(stan_file, access = "r", extension = "stan")
+        assert_file_exists(stan_file, access = "r", extension = c("stan", "stanfunctions"))
         checkmate::assert_flag(compile)
         private$stan_file_ <- absolute_path(stan_file)
         private$stan_code_ <- readLines(stan_file)
@@ -398,6 +404,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.
@@ -451,8 +459,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)
   }
@@ -501,15 +511,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) {
@@ -520,6 +578,7 @@ compile <- function(quiet = TRUE,
     private$precompile_cpp_options_ <- NULL
     private$precompile_stanc_options_ <- NULL
     private$precompile_include_paths_ <- NULL
+    self$functions$existing_exe <- TRUE
     self$exe_file(exe)
     return(invisible(self))
   } else {
@@ -530,14 +589,14 @@ 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
     compile_hessian_method <- FALSE
   }
 
-  temp_stan_file <- tempfile(pattern = "model-", fileext = ".stan")
+  temp_stan_file <- tempfile(pattern = "model-", fileext = paste0(".", tools::file_ext(self$stan_file())))
   file.copy(self$stan_file(), temp_stan_file, overwrite = TRUE)
   temp_file_no_ext <- strip_ext(temp_stan_file)
   tmp_exe <- cmdstan_ext(temp_file_no_ext) # adds .exe on Windows
@@ -548,23 +607,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")
   }
@@ -587,10 +629,18 @@ compile <- function(quiet = TRUE,
   stancflags_standalone <- c("--standalone-functions", stancflags_val, stancflags_combined)
   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(),

R/run.R

@@ -564,8 +564,8 @@ CmdStanRun$set("private", name = "run_variational_", value = .run_other)
     if (file.exists(stdout_file)) {
       cat(readLines(stdout_file), sep = "\n")
     }
-    if (file.exists(stdout_file)) {
-      cat(readLines(stdout_file), sep = "\n")
+    if (file.exists(stderr_file)) {
+      cat(readLines(stderr_file), sep = "\n")
     }
     stop(
       "Diagnose failed with the status code ", ret$status, "!\n",

R/utils.R

@@ -748,7 +748,8 @@ expose_model_methods <- function(env, verbose = FALSE, hessian = FALSE) {
                                   package = "cmdstanr", mustWork = TRUE)))
 
   if (hessian) {
-    code <- c(code,
+    code <- c("#include <stan/math/mix.hpp>",
+            code,
             readLines(system.file("include", "hessian.cpp",
                                   package = "cmdstanr", mustWork = TRUE)))
   }
@@ -758,9 +759,8 @@ expose_model_methods <- function(env, verbose = FALSE, hessian = FALSE) {
   invisible(NULL)
 }
 
-initialize_model_pointer <- function(env, data, seed = 0) {
-  datafile_path <- ifelse(is.null(data), "", data)
-  ptr_and_rng <- env$model_ptr(datafile_path, seed)
+initialize_model_pointer <- function(env, datafile_path, seed = 0) {
+  ptr_and_rng <- env$model_ptr(ifelse(is.null(datafile_path), "", datafile_path), seed)
   env$model_ptr_ <- ptr_and_rng$model_ptr
   env$model_rng_ <- ptr_and_rng$base_rng
   env$num_upars_ <- env$get_num_upars(env$model_ptr_)
@@ -780,7 +780,11 @@ create_skeleton <- function(param_metadata, model_variables,
                        names(model_variables$generated_quantities))
   }
   lapply(param_metadata[target_params], function(par_dims) {
-    array(0, dim = ifelse(length(par_dims) == 0, 1, par_dims))
+    if ((length(par_dims) == 0)) {
+      array(0, dim = 1)
+    } else {
+      array(0, dim = par_dims)
+    }
   })
 }
 
@@ -863,8 +867,8 @@ prep_fun_cpp <- function(fun_start, fun_end, model_lines) {
   fun_body <- gsub("auto", get_plain_rtn(fun_start, fun_end, model_lines), fun_body)
   fun_body <- gsub("// [[stan::function]]", "// [[Rcpp::export]]\n", fun_body, fixed = TRUE)
   fun_body <- gsub("std::ostream\\*\\s*pstream__\\s*=\\s*nullptr", "", fun_body)
-  fun_body <- gsub("boost::ecuyer1988& base_rng__", "size_t seed = 0", fun_body, fixed = TRUE)
-  fun_body <- gsub("base_rng__,", "*(new boost::ecuyer1988(seed)),", fun_body, fixed = TRUE)
+  fun_body <- gsub("boost::ecuyer1988&\\s*base_rng__", "SEXP base_rng_ptr", fun_body)
+  fun_body <- gsub("base_rng__,", "*(Rcpp::XPtr<boost::ecuyer1988>(base_rng_ptr).get()),", fun_body, fixed = TRUE)
   fun_body <- gsub("pstream__", "&Rcpp::Rcout", fun_body, fixed = TRUE)
   fun_body <- paste(fun_body, collapse = "\n")
   gsub(pattern = ",\\s*)", replacement = ")", fun_body)
@@ -904,6 +908,30 @@ compile_functions <- function(env, verbose = FALSE, global = FALSE) {
   } else {
     rcpp_source_stan(mod_stan_funs, env, verbose)
   }
+
+  # If an RNG function is exposed, initialise a Boost RNG object stored in the
+  # environment
+  rng_funs <- grep("rng\\b", env$fun_names, value = TRUE)
+  if (length(rng_funs) > 0) {
+    rng_cpp <- system.file("include", "base_rng.cpp", package = "cmdstanr", mustWork = TRUE)
+    rcpp_source_stan(paste0(readLines(rng_cpp), collapse="\n"), env, verbose)
+    env$rng_ptr <- env$base_rng(seed=0)
+  }
+
+  # For all RNG functions, pass the initialised Boost RNG by default
+  for (fun in rng_funs) {
+    if (global) {
+      fun_env <- globalenv()
+    } else {
+      fun_env <- env
+    }
+    fundef <- get(fun, envir = fun_env)
+    funargs <- formals(fundef)
+    funargs$base_rng_ptr <- env$rng_ptr
+    formals(fundef) <- funargs
+    assign(fun, fundef, envir = fun_env)
+  }
+
   env$compiled <- TRUE
   invisible(NULL)
 }
@@ -914,6 +942,10 @@ expose_stan_functions <- function(function_env, global = FALSE, verbose = FALSE)
           "WSL CmdStan and will not be compiled",
           call. = FALSE)
   }
+  if (function_env$existing_exe) {
+    stop("Exporting standalone functions is not possible with a pre-compiled Stan model!",
+          call. = FALSE)
+  }
   if (function_env$external && cmdstan_version() < "2.32") {
     stop("Exporting standalone functions with external C++ is not available before CmdStan 2.32",
          call. = FALSE)