Support model methods & standalone functions for models with external C++ (user_header)

NEWS.md

@@ -1,5 +1,11 @@
 # cmdstanr (development version)
 
+* `compile_model_methods = TRUE` and `compile_standalone = TRUE` now work for
+models that use an external C++ `user_header`. The standalone / model-methods
+code is generated in the same namespace as the rest of the model (rather than a
+mangled `'foo_model'_namespace`), and the user header is force-included when
+those translation units are compiled, mirroring CmdStan's
+`-include $(USER_HEADER)`. (#1197)
 * `pathfinder()` now respects `save_single_paths = TRUE` instead of always
 passing `0` to CmdStan.
 * `pathfinder()` now uses `threads` argument (`num_threads` is deprecated),

R/model.R

@@ -616,27 +616,47 @@ compile <- function(quiet = TRUE,
   if (is.null(stanc_options[["name"]])) {
     stanc_options[["name"]] <- paste0(self$model_name(), "_model")
   }
+  # Two forms of the stanc options are needed. The quoted form is embedded in
+  # the STANCFLAGS string passed to make(), where it is processed by a shell and
+  # the quotes guard against spaces. The unquoted form is for get_standalone_hpp(),
+  # which calls stanc directly (no shell) via an argument vector, so quotes would
+  # otherwise become literal characters in option values - e.g. --name='foo_model'
+  # would produce the namespace 'foo_model'_namespace and hide external C++
+  # functions from the standalone / model-methods code. (#1197)
   stanc_built_options <- c()
+  stanc_built_options_unquoted <- c()
   for (i in seq_len(length(stanc_options))) {
     option_name <- names(stanc_options)[i]
     if (isTRUE(as.logical(stanc_options[[i]]))) {
-      stanc_built_options <- c(stanc_built_options, paste0("--", option_name))
+      opt <- paste0("--", option_name)
+      stanc_built_options <- c(stanc_built_options, opt)
+      stanc_built_options_unquoted <- c(stanc_built_options_unquoted, opt)
     } else if (is.null(option_name) || !nzchar(option_name)) {
-      stanc_built_options <- c(stanc_built_options, paste0("--", stanc_options[[i]]))
+      opt <- paste0("--", stanc_options[[i]])
+      stanc_built_options <- c(stanc_built_options, opt)
+      stanc_built_options_unquoted <- c(stanc_built_options_unquoted, opt)
     } else {
       stanc_built_options <- c(stanc_built_options, paste0("--", option_name, "=", "'", stanc_options[[i]], "'"))
+      stanc_built_options_unquoted <- c(stanc_built_options_unquoted, paste0("--", option_name, "=", stanc_options[[i]]))
     }
   }
   stancflags_combined <- stanc_built_options
+  stancflags_combined_unquoted <- stanc_built_options_unquoted
   stancflags_local <- get_cmdstan_flags("STANCFLAGS")
   if (length(stancflags_local) > 0) {
     stancflags_combined <- c(stancflags_combined, stancflags_local)
+    stancflags_combined_unquoted <- c(stancflags_combined_unquoted, stancflags_local)
   }
   stanc_inc_paths <- include_paths_stanc3_args(include_paths, standalone_call = TRUE)
-  stancflags_standalone <- c("--standalone-functions", stanc_inc_paths, stancflags_combined)
+  stancflags_standalone <- c("--standalone-functions", stanc_inc_paths, stancflags_combined_unquoted)
   self$functions$hpp_code <- get_standalone_hpp(temp_stan_file, stancflags_standalone)
   private$model_methods_env_ <- new.env()
-  private$model_methods_env_$hpp_code_ <- get_standalone_hpp(temp_stan_file, c(stanc_inc_paths, stancflags_combined))
+  private$model_methods_env_$hpp_code_ <- get_standalone_hpp(temp_stan_file, c(stanc_inc_paths, stancflags_combined_unquoted))
+  # Make the external C++ header available when the standalone functions and
+  # model methods are compiled via Rcpp::sourceCpp() (see rcpp_source_stan()),
+  # mirroring the -include $(USER_HEADER) that CmdStan's makefile adds. (#1197)
+  private$model_methods_env_$user_header_ <- user_header
+  self$functions$user_header_ <- user_header
   self$functions$external <- !is.null(user_header)
   self$functions$existing_exe <- FALSE
 

R/utils.R

@@ -800,6 +800,13 @@ rcpp_source_stan <- function(code, env, verbose = FALSE, ...) {
   cppflags <- get_cmdstan_flags("CPPFLAGS")
   cmdstanr_includes <- system.file("include", package = "cmdstanr", mustWork = TRUE)
   cmdstanr_includes <- paste0(" -I\"", cmdstanr_includes,"\"")
+  # When the model uses an external C++ header, force-include it (as CmdStan's
+  # makefile does with -include $(USER_HEADER)) so that functions declared in the
+  # Stan program and defined in the header are available here too. (#1197)
+  user_header_include <- ""
+  if (!is.null(env$user_header_)) {
+    user_header_include <- paste0(" -include \"", env$user_header_, "\"")
+  }
   libs <- c("LDLIBS", "LIBSUNDIALS", "TBB_TARGETS", "LDFLAGS_TBB", "SUNDIALS_TARGETS")
   libs <- paste(sapply(libs, get_cmdstan_flags), collapse = " ")
   if (.Platform$OS.type == "windows") {
@@ -810,7 +817,7 @@ rcpp_source_stan <- function(code, env, verbose = FALSE, ...) {
       c(
         USE_CXX14 = 1,
         PKG_CPPFLAGS = cppflags,
-        PKG_CXXFLAGS = paste0(cxxflags, cmdstanr_includes, collapse = " "),
+        PKG_CXXFLAGS = paste0(cxxflags, cmdstanr_includes, user_header_include, collapse = " "),
         PKG_LIBS = libs
       ),
       Rcpp::sourceCpp(code = code, env = env, verbose = verbose, ...)

tests/testthat/test-model-methods.R

@@ -339,3 +339,56 @@ test_that("Variable skeleton returns correct dimensions for matrices", {
   expect_equal(fit$variable_skeleton(),
                 target_skeleton)
 })
+
+test_that("Model methods compile and run with an external C++ user_header (#1197)", {
+  # External C++ functions are defined in the model's namespace; previously the
+  # standalone / model-methods code was generated in a mangled, quoted namespace
+  # ('foo_model'_namespace) and the user header was not -include-d in the Rcpp
+  # compilation, so model methods could not be built for models using a custom
+  # header. See https://github.com/stan-dev/cmdstanr/issues/1116
+  ext_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);
+    }
+}"
+  header <- withr::local_tempfile(lines = ext_hpp, fileext = ".hpp")
+
+  # external C++ and CmdStan's precompiled headers do not mix on some platforms
+  make_local_orig <- cmdstan_make_local()
+  cmdstan_make_local(cpp_options = list("PRECOMPILED_HEADERS" = "false"))
+  withr::defer(cmdstan_make_local(cpp_options = make_local_orig, append = FALSE))
+
+  mod <- cmdstan_model(
+    testing_stan_file("bernoulli_external"),
+    user_header = header,
+    compile_model_methods = TRUE,
+    force_recompile = TRUE
+  )
+  data_list <- testing_data("bernoulli")
+  utils::capture.output(
+    fit <- mod$sample(data = data_list, chains = 1, refresh = 0)
+  )
+
+  expect_no_error(fit$init_model_methods())
+
+  lp <- fit$log_prob(unconstrained_variables = c(0.1))
+  expect_true(is.finite(lp))
+  expect_no_error(fit$grad_log_prob(unconstrained_variables = c(0.1)))
+
+  # generated quantities exercise the external make_odds(theta) = theta / (1 - theta)
+  theta <- stats::plogis(0.1)
+  cpars <- fit$constrain_variables(c(0.1))
+  expect_equal(cpars$odds, theta / (1 - theta))
+})