Allow deprecated syntax for specified versions of specified packages

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

@@ -44,6 +44,9 @@ rstan_config <- function(pkgdir = ".") {
                            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)
+    }
     # 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)
@@ -402,3 +405,24 @@ rstan_config <- function(pkgdir = ".") {
   # Update model code with type declarations
   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]]
+  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
+    model_code <- post_process(model_code)
+    writeLines(model_code, con = stanfile)
+    invisible(NULL)
+  })
+  invisible(NULL)
+}

R/stanc_exceptions.R

@@ -0,0 +1,69 @@
+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",
+  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
+post_processing <- 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)
+    model_code
+  },
+  survstan = function(model_code) {
+    model_code <- gsub("offset", "offset_par", model_code, fixed = TRUE)
+    model_code
+  },
+  cbq = function(model_code) {
+    model_code <- gsub("offset", "offset_par", model_code, fixed = TRUE)
+    model_code
+  }
+)