Merge pull request #1158 from stan-dev/fix-reloaded-model-with-methods

Don't error when fitting a model using reloaded CmdStanModel with compiled model methods

Author: jgabry

NEWS.md

@@ -1,5 +1,9 @@
 # cmdstanr (development version)
 
+* CmdStanModel objects created using `compile_model_methods = TRUE` that are
+then saved and reloaded no longer error in model fitting methods. Model methods
+are recompiled lazily if needed.
+  
 * CmdStan versions older than 2.35.0 are no longer supported.
 * Minimum R version increased to 4.0.0.
 * Removed legacy Windows toolchain paths for older CmdStan releases.

R/fit.R

@@ -23,6 +23,7 @@ CmdStanFit <- R6::R6Class(
           assign(n, get(n, runset$model_methods_env()), private$model_methods_env_)
         }
       }
+      drop_stale_model_methods(private$model_methods_env_)
 
       self$functions <- new.env()
       if (!is.null(runset$standalone_env())) {
@@ -332,8 +333,11 @@ CmdStanFit$set("public", name = "init", value = init)
 #'   `log_prob`, `grad_log_prob`, `hessian`, `constrain_variables`,
 #'   `unconstrain_variables` and `unconstrain_draws` functions. These are then
 #'   available as methods of the fitted model object. This requires the
-#'   additional `Rcpp` package, which are not required for fitting models using
-#'   CmdStanR.
+#'   additional \pkg{Rcpp} package.
+#'
+#'   If a model or fit object was saved with [base::saveRDS()] and later
+#'   reloaded, any previously compiled model-method bindings will be rebuilt in
+#'   the current R session when this method is called.
 #'
 #'   Note: there may be many compiler warnings emitted during compilation but
 #'   these can be ignored so long as they are warnings and not errors.
@@ -357,6 +361,7 @@ init_model_methods <- function(seed = 1, verbose = FALSE) {
           call. = FALSE)
   }
   require_suggested_package("Rcpp")
+  drop_stale_model_methods(private$model_methods_env_)
   if (length(private$model_methods_env_$hpp_code_) == 0) {
     stop("Model methods cannot be used with a pre-compiled Stan executable, ",
           "the model must be compiled again", call. = FALSE)

R/model.R

@@ -422,7 +422,11 @@ CmdStanModel <- R6::R6Class(
 #'   via a global `cmdstanr_force_recompile` option.
 #' @param compile_model_methods (logical) Compile additional model methods
 #'   (`log_prob()`, `grad_log_prob()`, `constrain_variables()`,
-#'   `unconstrain_variables()`).
+#'   `unconstrain_variables()`). Note: the compiled model-method bindings are
+#'   not preserved in a usable form when saving a model object. If you plan to
+#'   save and reload the model object before model fitting, we recommend instead
+#'   waiting to compile the model methods until after fitting via
+#'   [`fit$init_model_methods()`][fit-method-init_model_methods].
 #' @param compile_standalone (logical) Should functions in the Stan model be
 #'   compiled for use in R? If `TRUE` the functions will be available via the
 #'   `functions` field in the compiled model object. This can also be done after

R/utils.R

@@ -792,6 +792,37 @@ rcpp_source_stan <- function(code, env, verbose = FALSE, ...) {
   invisible(NULL)
 }
 
+# Detect serialized sourceCpp wrappers whose native symbol was lost after reload.
+source_cpp_native_symbol_is_null <- function(fun) {
+  if (!is.function(fun)) {
+    return(FALSE)
+  }
+  fun_body <- body(fun)
+  if (!rlang::is_call(fun_body, ".Call") || length(fun_body) < 2) {
+    return(FALSE)
+  }
+  # Rcpp::sourceCpp() wrappers call into a NativeSymbol via `.Call(...)`.
+  # After reloading a serialized object that symbol can degrade to `<pointer: 0x0>`.
+  symbol <- fun_body[[2]]
+  if (!inherits(symbol, "NativeSymbol")) {
+    return(FALSE)
+  }
+  symbol_text <- paste(capture.output(print(symbol)), collapse = "")
+  grepl("<pointer: (0x0+|\\(nil\\))>", symbol_text)
+}
+
+# Drop stale compiled bindings but keep the generated C++ so model methods
+# can be rebuilt lazily in the current session if they are later requested.
+# This avoids an error when a CmdStanModel object with compiled bindings is
+# loaded from an older session: https://github.com/stan-dev/cmdstanr/issues/1157
+drop_stale_model_methods <- function(env) {
+  if (is.null(env$model_ptr) || !source_cpp_native_symbol_is_null(env$model_ptr)) {
+    return(invisible(FALSE))
+  }
+  rm(list = setdiff(ls(env, all.names = TRUE), "hpp_code_"), envir = env)
+  invisible(TRUE)
+}
+
 expose_model_methods <- function(env, verbose = FALSE) {
   if (rlang::is_interactive()) {
     message("Compiling additional model methods...")

man/cmdstanr-package.Rd

@@ -178,6 +178,27 @@ test_that("save_object() method works", {
   expect_identical(fit$summary(), s)
 })
 
+test_that("reloaded fits rebuild model methods lazily after save_object()", {
+  skip_if(os_is_wsl())
+  mod <- cmdstan_model(
+    testing_stan_file("bernoulli_log_lik"),
+    force_recompile = TRUE,
+    compile_model_methods = TRUE
+  )
+  utils::capture.output(
+    fit <- mod$optimize(data = testing_data("bernoulli"))
+  )
+
+  temp_rds_file <- tempfile(fileext = ".RDS")
+  fit$save_object(temp_rds_file)
+  fit2 <- readRDS(temp_rds_file)
+
+  expect_no_error(
+    lp <- fit2$log_prob(unconstrained_variables = c(0.1))
+  )
+  expect_equal(lp, -8.6327599208828509347)
+})
+
 test_that("save_object() method works with qs2 format", {
   skip_if_not_installed("qs2")
   fit <- fits[["sample"]]

man/fit-method-init_model_methods.Rd

@@ -149,6 +149,44 @@ test_that("Methods can be compiled with model", {
   expect_equal(unconstrained_variables, c(0.6))
 })
 
+test_that("Reloaded models recompile model methods lazily after saveRDS/readRDS", {
+  # Also tests that fitted model objects are returned without error after
+  # saveRDS/readRDS when model methods are compiled: https://github.com/stan-dev/cmdstanr/issues/1157
+  mod <- cmdstan_model(
+    testing_stan_file("bernoulli_log_lik"),
+    force_recompile = TRUE,
+    compile_model_methods = TRUE
+  )
+  temp_rds_file <- tempfile(fileext = ".RDS")
+  saveRDS(mod, temp_rds_file)
+  mod2 <- readRDS(temp_rds_file)
+
+  expect_no_error(
+    utils::capture.output(
+      fit <- mod2$optimize(data = data_list)
+    )
+  )
+  expect_equal(fit$log_prob(unconstrained_variables = c(0.1)),
+               -8.6327599208828509347)
+})
+
+test_that("stale model-method bindings are detected and dropped", {
+  mod <- cmdstan_model(
+    testing_stan_file("bernoulli_log_lik"),
+    force_recompile = TRUE,
+    compile_model_methods = TRUE
+  )
+  temp_rds_file <- tempfile(fileext = ".RDS")
+  saveRDS(mod, temp_rds_file)
+  mod2 <- readRDS(temp_rds_file)
+  model_methods_env <- mod2$.__enclos_env__$private$model_methods_env_
+
+  expect_true(source_cpp_native_symbol_is_null(model_methods_env$model_ptr))
+  expect_true(drop_stale_model_methods(model_methods_env))
+  expect_equal(ls(model_methods_env, all.names = TRUE), "hpp_code_")
+  expect_false(drop_stale_model_methods(model_methods_env))
+})
+
 test_that("unconstrain_variables correctly handles zero-length containers", {
   model_code <- "
   data {