Merge pull request #154 from stan-dev/compat

Allow deprecated syntax for specified versions of specified packages

Author: andrjohns

DESCRIPTION

@@ -28,9 +28,9 @@ Authors@R:
       person(given = "Stefan",
              family = "Siegert",
              role = "ctb"),
-      person(given = "Visruth", 
-             family = "Srimath Kandali", 
-             role = "ctb"),       
+      person(given = "Visruth",
+             family = "Srimath Kandali",
+             role = "ctb"),
       person(given = "Trustees of",
              family = "Columbia University",
              role = "cph"))
@@ -45,7 +45,7 @@ BugReports: https://github.com/stan-dev/rstantools/issues
 Encoding: UTF-8
 LazyData: true
 SystemRequirements: pandoc
-Imports: desc, stats, utils, Rcpp (>= 0.12.16), RcppParallel (>= 5.0.1)
+Imports: desc, stats, utils, Rcpp (>= 0.12.16), RcppParallel (>= 5.0.1), QuickJSR
 Suggests:
     rstan (>= 2.17.2),
     usethis (>= 1.5.1),

R/rstan_config.R

@@ -39,16 +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) {
+    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)
@@ -65,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)
 }
@@ -167,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")
@@ -221,6 +232,7 @@ rstan_config <- function(pkgdir = ".") {
     cat("#include <exporter.h>",
         eigen_incl,
         "#include <stan/math/prim/meta.hpp>",
+        "#include <stan/services/util/create_rng.hpp>",
         file = file.path(pkgdir, "src",
                          paste(pkgname, "types.h", sep = "_")),
         sep = "\n")
@@ -245,6 +257,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)
@@ -316,7 +331,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) {
@@ -354,6 +369,25 @@ rstan_config <- function(pkgdir = ".") {
                     stanmodels[(model_line+2):load_line],
                     load_module,
                     stanmodels[(load_line+2):nlines])
+    # disbayes does not need stanc exception, but uses a variable name ('mips') that
+    # gets mangled by stanc which rstan 2.32 does not support
+    if (!is.null(cpp_pre_process[[pkg_name]]) && (is_excepted || pkg_name == "disbayes")) {
+      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
 }
@@ -402,3 +436,25 @@ rstan_config <- function(pkgdir = ".") {
   # Update model code with type declarations
   gsub("auto", rtn_type, cpp_lines[decl_line], fixed = TRUE)
 }
+
+.update_deprecations <- function(pkg_name, stan_files) {
+  post_process <- stan_post_process[[pkg_name]]
+  if (is.null(post_process)) {
+    post_process <- function(x) x
+  }
+  ctx <- QuickJSR::JSContext$new(stack_size = 4 * 1024 * 1024)
+  ctx$source(system.file("stanc.2.32.js", package = "rstantools", mustWork = TRUE))
+  stanc_process <- utils::getFromNamespace("stanc_process", "rstan")
+  sapply(stan_files, function(stanfile) {
+    model_code <- stanc_process(stanfile)
+    model_code <- ctx$call("stanc", "dummy", model_code, as.array("print-canonical"))$result
+
+    # Only overwrite Stan file if stanc succeeded
+    if (!is.null(model_code)) {
+      model_code <- post_process(model_code)
+      writeLines(model_code, con = stanfile)
+    }
+    invisible(NULL)
+  })
+  invisible(NULL)
+}

R/stanc_exceptions.R

@@ -0,0 +1,77 @@
+stanc_exceptions <- list(
+  AovBay = "0.1.0",
+  baggr = "0.8.2",
+  BayesPET = "0.1.0",
+  bbmix = "1.0.0",
+  bclogit = "1.1",
+  BINtools = "0.2.0",
+  bmgarch = "2.1.0",
+  bmggum = "0.1.0",
+  BoundIRT = "0.5.0",
+  BRRAT = "0.0.2",
+  bsynth = "1.0",
+  bws = "0.1.0",
+  CARME = "0.1.1",
+  cbq = "0.2.0.4",
+  cloneRate = "0.2.3",
+  CNVRG = "1.0.0",
+  DCPO = "0.5.3",
+  densEstBayes = "1.0-2.2",
+  EcoEnsemble = "1.2.0",
+  EpiPvr = "0.0.1",
+  fcirt = "0.2.1",
+  FlexReg = "1.4.2",
+  glmmPen = "1.5.4.8",
+  HHBayes = "0.1.1",
+  hmde = "1.4.0",
+  imt = "1.0.0",
+  imuGAP = "0.1.0",
+  MetaStan = "1.0.0",
+  morseTKTD = "0.1.3",
+  multipleDL = "1.0.0",
+  networkscaleup = "0.2-2",
+  phacking = "0.2.1",
+  postlink = "0.1.0",
+  psBayesborrow = "1.1.0",
+  publipha = "0.1.2",
+  SLGP = "1.0.2",
+  survstan = "0.0.7.1",
+  trialr = "0.1.6",
+  truncnormbayes = "0.0.3",
+  WhiteLabRt = "1.0.1",
+  YPPE = "1.0.1",
+  zoid = "1.3.1"
+)
+
+# Additional deprecations not covered by 2.32 stanc3 canonicalise
+stan_post_process <- list(
+  publipha = function(model_code) {
+    model_code <- gsub("real \\b(lower|upper)\\b", "real \\1_par", model_code)
+    model_code <- gsub("normal_(cdf|lccdf|lcdf)\\((-)?\\b(upper|lower)\\b(,| \\|)", "normal_\\1(\\2\\3_par |", model_code)
+    model_code
+  },
+  survstan = function(model_code) {
+    model_code <- gsub("\\boffset\\b", "offset_par", model_code)
+    model_code
+  },
+  cbq = function(model_code) {
+    model_code <- gsub("\\boffset\\b", "offset_par", model_code)
+    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
+  },
+  # rstan 2.32 does not account for new stanc mangling
+  disbayes = function(cpp_code) {
+    cpp_code <- gsub("_stan_mips", "mips", cpp_code, fixed = TRUE)
+    cpp_code
+  }
+)