Merge pull request #101 from andrjohns/standalone-functions

Fix compatibility for exporting standalone functions, add tests

.github/workflows/check-standalone.yaml

@@ -0,0 +1,76 @@
+# Workflow derived from https://github.com/r-lib/actions/tree/master/examples
+# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+    branches: [main, master]
+
+name: Stanfunctions Support
+
+jobs:
+  stanfunctions-support:
+    runs-on: ${{ matrix.config.os }}
+
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+
+    strategy:
+      fail-fast: false
+      matrix:
+        config:
+          - {os: ubuntu-latest,   r: 'devel', http-user-agent: 'release'}
+          - {os: ubuntu-latest,   r: 'release'}
+
+    env:
+      GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }}
+      R_KEEP_PKG_SOURCE: yes
+
+    steps:
+      - uses: actions/checkout@v3
+
+      - uses: r-lib/actions/setup-pandoc@v2
+
+      - uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: ${{ matrix.config.r }}
+          http-user-agent: ${{ matrix.config.http-user-agent }}
+          use-public-rspm: true
+
+      - uses: r-lib/actions/setup-r-dependencies@v2
+        with:
+          extra-packages: local::. rcmdcheck BH RcppParallel RcppEigen Rcpp rstan StanHeaders RCurl
+
+      - name: Checkout lgpr package
+        run: |
+          git clone https://github.com/andrjohns/lgpr
+          cd lgpr && git checkout function-exports
+
+      - name: Check against CRAN StanHeaders and CRAN RStan
+        run: |
+          rcmdcheck::rcmdcheck(path = "lgpr", args = c("--no-manual", "--as-cran"), build_args = "--no-manual")
+        shell: Rscript {0}
+
+      - name: Install Development StanHeaders and CRAN RStan
+        run: |
+          Sys.setenv(MAKEFLAGS=paste0("-j",parallel::detectCores()))
+          install.packages("StanHeaders", repos = c("https://mc-stan.org/r-packages/", getOption("repos")))
+          install.packages('rstan', type='source')
+        shell: Rscript {0}
+
+      - name: Check against Development StanHeaders and CRAN RStan
+        run: |
+          rcmdcheck::rcmdcheck(path = "lgpr", args = c("--no-manual", "--as-cran"), build_args = "--no-manual")
+        shell: Rscript {0}
+
+      - name: Install Development StanHeaders and Development RStan
+        run: |
+          Sys.setenv(MAKEFLAGS=paste0("-j",parallel::detectCores()))
+          install.packages("StanHeaders", repos = c("https://mc-stan.org/r-packages/", getOption("repos")))
+          install.packages("rstan", repos = c("https://mc-stan.org/r-packages/", getOption("repos")))
+        shell: Rscript {0}
+
+      - name: Check against Development StanHeaders and Development RStan
+        run: |
+          rcmdcheck::rcmdcheck(path = "lgpr", args = c("--no-manual", "--as-cran"), build_args = "--no-manual")
+        shell: Rscript {0}
+

.github/workflows/check-standard.yaml

@@ -30,7 +30,7 @@ jobs:
       R_KEEP_PKG_SOURCE: yes
 
     steps:
-      - uses: actions/checkout@v2
+      - uses: actions/checkout@v3
 
       - uses: r-lib/actions/setup-pandoc@v2
 

R/rstan_config.R

@@ -179,9 +179,9 @@ rstan_config <- function(pkgdir = ".") {
   if (grepl("\\.stanfunctions$", file_name) &&
       (utils::packageVersion('rstan') < 2.29)) {
     mod <- readLines(file_name)
-    file_name <- paste0(.basename_noext(file_name), "_wrapped.stanfunctions")
-    cat("functions {", mod, "}", sep = "\n",
-        file = file_name)
+    if (!any(grepl("\\bfunctions(\\s*|)\\{", mod))) {
+      writeLines(c("functions {", mod, "}"), sep = "\n", con = file_name)
+    }
   }
   stanc_ret <- rstan::stanc(file_name, allow_undefined = TRUE,
                             obfuscate_model_name = FALSE,
@@ -215,7 +215,7 @@ rstan_config <- function(pkgdir = ".") {
     }
     cat("#include <exporter.h>",
         "#include <stan/math/prim/mat/fun/Eigen.hpp>",
-        "#include <stan/model/standalone_functions_header.hpp>",
+        "#include <stan/math/prim/meta.hpp>",
         file = file.path(pkgdir, "src",
                          paste(basename(pkgdir), "types.h", sep = "_")),
         sep = "\n")
@@ -351,41 +351,23 @@ rstan_config <- function(pkgdir = ".") {
 # Replace auto return type in function exports with the plain type from the main body.
 .replace_auto <- function(decl_line, cppcode, cpp_lines) {
   # Extract the name of function
-  decl <- cpp_lines[decl_line]
-  decl <- gsub("auto ","",decl,fixed=T)
-  decl <- sub("\\(.*","",decl,perl=T)
-
-  # Replace newlines with blank spaces
-  t3 <- gsub("\n"," ",cppcode,fixed=T)
-
-  # Identify code segment containing first declaration of function
-  sf1 <- strsplit(t3,decl,fixed=T)[[1]][1]
-  sf2 <- utils::tail(strsplit(sf1,";",fixed=T)[[1]],1)
-
-  # Get location of type promotion (if present)
-  promote_start <- regexec("stan::promote_args_t<",sf2)[[1]]
+  fun_name <- cpp_lines[decl_line]
+  fun_name <- gsub("auto ","",fun_name,fixed=T)
+  fun_name <- sub("\\(.*","",fun_name,perl=T)
 
-  if(promote_start > 0) {
+  struct_start <- grep(paste0("struct ", fun_name, "_functor"), cpp_lines)
+  struct_op_start <- grep("operator()", cpp_lines[-(1:struct_start)])[1] + struct_start
 
-    str_t <- strsplit(sf2,"")[[1]]
-    promote_end <- promote_start + attr(promote_start,'match.length')
+  rtn_type <- paste0(cpp_lines[struct_start:struct_op_start], collapse = " ")
 
-    count <- 1
+  rm_operator <- gsub("operator().*", "", rtn_type)
+  rm_struct_decl <- gsub(".*\\{", "", rm_operator)
+  repl_dbl <- gsub("T([0-9])*__", "double", rm_struct_decl)
 
-    while(count > 0 & promote_end < length(str_t)) {
-      count <- count + ifelse(str_t[promote_end] == "<", 1,
-                             ifelse(str_t[promote_end] == ">", -1,0))
-      promote_end <- promote_end + 1
-    }
-
-    sf2 <- paste0(c(str_t[1:(promote_start-1)], "double",
-                   str_t[promote_end:length(str_t)]),
-                 collapse = "")
-  }
 
   # Extract return type declaration and replace promoted scalar
   #  type with double
-  rtn_type <- gsub("template <typename(.*?)> ","",sf2)
+  rtn_type <- gsub("template <typename(.*?)> ", "", repl_dbl)
 
   # Update model code with type declarations
   gsub("auto ", rtn_type, cpp_lines[decl_line],fixed=T)