Add handling for models with cpp changes

Author: andrjohns

R/rstan_config.R

@@ -39,19 +39,27 @@
 #'
 rstan_config <- function(pkgdir = ".") {
   pkgdir <- .check_pkgdir(pkgdir) # check if package root directory
+  pkg_dcf <- read.dcf(file.path(pkgdir, "DESCRIPTION"))
+  pkg_name <- pkg_dcf[1, "Package"]
+  pkg_ver <- pkg_dcf[1, "Version"]
+
   # get stan model files
   stan_files <- list.files(file.path(pkgdir, "inst", "stan"),
                            full.names = TRUE,
                            pattern = "(\\.stan$)|(\\.stanfunctions$)")
   if (length(stan_files) != 0) {
-    if (is_excepted(pkgdir) && (utils::packageVersion("StanHeaders") >= "2.36")) {
-      .update_deprecations(pkgdir, stan_files)
+    is_excepted <- isTRUE(stanc_exceptions[[pkg_name]] == pkg_ver) && (utils::packageVersion("StanHeaders") >= "2.36")
+
+    if (is_excepted) {
+      .update_deprecations(pkg_name, stan_files)
     }
+
     # add R & src folders in case run from configure[.win] script
     .add_standir(pkgdir, "R", msg = FALSE, warn = FALSE)
     .add_standir(pkgdir, "src", msg = FALSE, warn = FALSE)
     # convert all .stan files to .cc/.hpp pairs
-    sapply(stan_files, .make_cc, pkgdir = pkgdir)
+    sapply(stan_files, .make_cc, pkgdir = pkgdir, pkg_name = pkg_name,
+          is_excepted = is_excepted)
     # update package Makevars
     acc <- .setup_Makevars(pkgdir, add = TRUE)
     ## .add_Makevars(pkgdir)
@@ -68,7 +76,7 @@ rstan_config <- function(pkgdir = ".") {
   # register exported modules as native routines
   Rcpp::compileAttributes(pkgdir)
   # update R/stanmodels.R with current set of models
-  stanmodels <- .update_stanmodels(pkgdir)
+  stanmodels <- .update_stanmodels(pkgdir, pkg_name, is_excepted)
   acc <- acc | .add_stanfile(stanmodels, pkgdir, "R", "stanmodels.R")
   invisible(acc)
 }
@@ -170,7 +178,7 @@ rstan_config <- function(pkgdir = ".") {
 # If the .stan file has a functions block but no parameters block, then there
 # is no module definition but the functions are compiled and exported to the
 # package's namespace.
-.make_cc <- function(file_name, pkgdir) {
+.make_cc <- function(file_name, pkgdir, pkg_name, is_excepted) {
   model_name <- sub("[.]stan$", "", basename(file_name)) # model name
   ## path to src/stan_files
   ## stan_path <- file.path(pkgdir, "src", "stan_files")
@@ -248,6 +256,9 @@ rstan_config <- function(pkgdir = ".") {
     if (utils::packageVersion('StanHeaders') >= "2.34") {
       cppcode <- gsub("boost::ecuyer1988", "stan::rng_t", cppcode, fixed = TRUE)
     }
+    if (is_excepted && !is.null(cpp_pre_process[[pkg_name]])) {
+      cppcode <- cpp_pre_process[[pkg_name]](cppcode)
+    }
     # Stan header file
     hdr_name <- .stan_prefix(model_name, ".h")
     # get license file (if any)
@@ -319,7 +330,7 @@ rstan_config <- function(pkgdir = ".") {
 }
 
 # rewrites stanmodels.R reflecting current list of stan files
-.update_stanmodels <- function(pkgdir) {
+.update_stanmodels <- function(pkgdir, pkg_name, is_excepted) {
   model_names <- list.files(file.path(pkgdir, "inst", "stan"),
                             pattern = "*.stan$")
   only_functions <- sapply(model_names, FUN = function(nm) {
@@ -357,6 +368,23 @@ rstan_config <- function(pkgdir = ".") {
                     stanmodels[(model_line+2):load_line],
                     load_module,
                     stanmodels[(load_line+2):nlines])
+    if (is_excepted && !is.null(cpp_pre_process[[pkg_name]])) {
+      process_fun <- c("process_fun <- ", deparse(cpp_pre_process[[pkg_name]]))
+
+      process_text <- c(
+        "process_fun <- ", deparse(cpp_pre_process[[pkg_name]]),
+        "stanfit$model_code <- process_fun(stanfit$model_code)",
+        "stanfit$model_cpp$model_cppcode <- process_fun(stanfit$model_cpp$model_cppcode)"
+      )
+
+      insert_loc <- grep("# create stanmodel object$", stanmodels)
+      nlines <- length(stanmodels)
+      stanmodels <- c(
+        stanmodels[1:(insert_loc-1)],
+        process_text,
+        stanmodels[insert_loc:nlines]
+      )
+    }
   }
   stanmodels
 }
@@ -406,11 +434,8 @@ rstan_config <- function(pkgdir = ".") {
   gsub("auto", rtn_type, cpp_lines[decl_line], fixed = TRUE)
 }
 
-.update_deprecations <- function(pkgdir, stan_files) {
-  pkg_dcf <- read.dcf(file.path(pkgdir, "DESCRIPTION"))
-  pkg_nm <- pkg_dcf[1, "Package"]
-
-  post_process <- post_processing[[pkg_nm]]
+.update_deprecations <- function(pkg_name, stan_files) {
+  post_process <- stan_post_process[[pkg_name]]
   if (is.null(post_process)) {
     post_process <- function(x) x
   }

R/stanc_exceptions.R

@@ -1,11 +1,3 @@
-is_excepted <- function(pkgdir) {
-  pkg_dcf <- read.dcf(file.path(pkgdir, "DESCRIPTION"))
-  pkg_nm <- pkg_dcf[1, "Package"]
-  pkg_ver <- pkg_dcf[1, "Version"]
-
-  isTRUE(stanc_exceptions[[pkg_nm]] == pkg_ver)
-}
-
 stanc_exceptions <- list(
   AovBay = "0.1.0",
   baggr = "0.8.2",
@@ -52,7 +44,7 @@ stanc_exceptions <- list(
 )
 
 # Additional deprecations not covered by 2.32 stanc3 canonicalise
-post_processing <- list(
+stan_post_process <- list(
   publipha = function(model_code) {
     model_code <- gsub("real (lower|upper)", "real \\1_par", model_code)
     model_code <- gsub("normal_(cdf|lccdf|lcdf)\\((-)?(upper|lower)(,| \\|)", "normal_\\1(\\2\\3_par |", model_code)
@@ -67,3 +59,14 @@ post_processing <- list(
     model_code
   }
 )
+
+cpp_pre_process <- list(
+  survstan = function(cpp_code) {
+    cpp_code <- gsub("offset_par", "offset", cpp_code, fixed = TRUE)
+    cpp_code
+  },
+  cbq = function(cpp_code) {
+    cpp_code <- gsub("offset_par", "offset", cpp_code, fixed = TRUE)
+    cpp_code
+  }
+)