Merge branch 'master' into avehtari-patch-1

Author: jgabry

.github/workflows/R-CMD-check.yaml

@@ -69,11 +69,7 @@ jobs:
       - name: Install cmdstan
         run: |
           cmdstanr::check_cmdstan_toolchain(fix = TRUE)
-          if (Sys.getenv("CMDSTANR_USE_RTOOLS") == "TRUE") {
-            cmdstanr::install_cmdstan(cores = 2, version = "2.35.0-rc2")
-          } else {
-            cmdstanr::install_cmdstan(cores = 2)
-          }
+          cmdstanr::install_cmdstan(cores = 2)
         shell: Rscript {0}
 
       - name: Session info

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: cmdstanr
 Title: R Interface to 'CmdStan'
-Version: 0.8.0.9000
-Date: 2024-05-18
+Version: 0.8.1.9000
+Date: 2024-06-06
 Authors@R:
     c(person(given = "Jonah", family = "Gabry", role = "aut",
              email = "jsg2201@columbia.edu"),

NEWS.md

@@ -1,7 +1,23 @@
-# cmdstanr 0.8.0.9000
+# cmdstanr 0.8.1.9000
 
 Items for next release go here
 
+# cmdstanr 0.8.1
+
+## Minor changes
+
+* Added `CMDSTANR_USE_RTOOLS` environment variable to force stock RTools on Windows by @andrjohns in #980
+* Added support for Windows ARM64 by @andrjohns in #990
+* Automatically initialise model methods when called, add `inc_warmup` argument to `$unconstrain_draws()` by @andrjohns in #985
+
+## Bugfixes
+
+* Fix errors when using pathfinder object as initial values by @avehtari in #984
+* Fix error with `$unconstrain_draws()` returning incorrect assumptions in some cases by @andrjohns in #983
+* Fix spurious errors about missing CmdStan config files by @andrjohns in #981
+* Fix linking error when exposing SUNDIALS/KINSOL functions or model methods by @andrjohns in #977
+* Fix long-standing error with OneDrive paths on Windows by @andrjohns in #990
+
 # cmdstanr 0.8.0
 
 ## Major new features

R/args.R

@@ -1063,6 +1063,24 @@ process_init.default <- function(init, ...) {
   return(init)
 }
 
+#' Remove the leftmost dimension if equal to 1
+#' @noRd
+#' @param x An array like object
+.remove_leftmost_dim <- function(x) {
+  dims <- dim(x)
+  if (length(dims) == 1) {
+    return(drop(x))
+  } else if (dims[1] == 1) {
+    new_dims <- dims[-1]
+    # Create a call to subset the array, maintaining all remaining dimensions
+    subset_expr <- as.call(c(as.name("["), list(x), 1, rep(TRUE, length(new_dims)), drop = FALSE))
+    new_x <- eval(subset_expr)
+    return(array(new_x, dim = new_dims))
+  } else {
+    return(x)
+  }
+}
+
 #' Write initial values to files if provided as posterior `draws` object
 #' @noRd
 #' @param init A type that inherits the `posterior::draws` class.
@@ -1097,9 +1115,13 @@ process_init.draws <- function(init, num_procs, model_variables = NULL,
   draws_rvar <- posterior::subset_draws(draws_rvar, variable = variable_names)
   inits = lapply(1:num_procs, function(draw_iter) {
     init_i = lapply(variable_names, function(var_name) {
-      x = drop(posterior::draws_of(drop(
-        posterior::subset_draws(draws_rvar[[var_name]], draw=draw_iter))))
-      return(x)
+      x = .remove_leftmost_dim(posterior::draws_of(
+        posterior::subset_draws(draws_rvar[[var_name]], draw=draw_iter)))
+      if (model_variables$parameters[[var_name]]$dimensions == 0) {
+        return(as.double(x))
+      } else {
+        return(x)
+      }
     })
     bad_names = unlist(lapply(variable_names, function(var_name) {
       x = drop(posterior::draws_of(drop(
@@ -1295,13 +1317,13 @@ process_init_approx <- function(init, num_procs, model_variables = NULL,
   # Calculate unique draws based on 'lw' using base R functions
   unique_draws = length(unique(draws_df$lw))
   if (num_procs > unique_draws) {
-    if (inherits(init, " CmdStanPathfinder ")) {
+    if (inherits(init, "CmdStanPathfinder")) {
       algo_name = " Pathfinder "
       extra_msg = " Try running Pathfinder with psis_resample=FALSE."
     } else if (inherits(init, "CmdStanVB")) {
       algo_name = " CmdStanVB "
       extra_msg = ""
-    } else if (inherits(init, " CmdStanLaplace ")) {
+    } else if (inherits(init, "CmdStanLaplace")) {
       algo_name = " CmdStanLaplace "
       extra_msg = ""
     } else {

R/data.R

@@ -186,6 +186,18 @@ process_data <- function(data, model_variables = NULL) {
         # generating a decimal point in write_stan_json
         if (data_variables[[var_name]]$type == "int"
             && !is.integer(data[[var_name]])) {
+          if (!is.factor(data[[var_name]])) {
+            if (!isTRUE(all(is_wholenumber(data[[var_name]])))) {
+              # Don't warn for NULL/NA, as different warnings are used for those
+              if (!isTRUE(any(is.na(data[[var_name]])))) {
+                warning("A non-integer value was supplied for '", var_name, "'!",
+                        " It will be truncated to an integer.", call. = FALSE)
+              }
+            } else {
+              # Round before setting mode to integer to avoid floating point errors
+              data[[var_name]] <- round(data[[var_name]])
+            }
+          }
           mode(data[[var_name]]) <- "integer"
         }
       }

R/install.R

@@ -453,63 +453,72 @@ build_cmdstan <- function(dir,
   } else {
     run_cmd <- make_cmd()
   }
-  withr::with_path(
-    c(
-      toolchain_PATH_env_var(),
-      tbb_path(dir = dir)
-    ),
-    wsl_compatible_run(
-      command = run_cmd,
-      args = c(translation_args, paste0("-j", cores), "build"),
-      wd = dir,
-      echo_cmd = is_verbose_mode(),
-      echo = !quiet || is_verbose_mode(),
-      spinner = quiet,
-      error_on_status = FALSE,
-      stderr_callback = function(x, p) { if (quiet) message(x) },
-      timeout = timeout
+  withr::with_envvar(
+    c("HOME" = short_path(Sys.getenv("HOME"))),
+    withr::with_path(
+      c(
+        toolchain_PATH_env_var(),
+        tbb_path(dir = dir)
+      ),
+      wsl_compatible_run(
+        command = run_cmd,
+        args = c(translation_args, paste0("-j", cores), "build"),
+        wd = dir,
+        echo_cmd = is_verbose_mode(),
+        echo = !quiet || is_verbose_mode(),
+        spinner = quiet,
+        error_on_status = FALSE,
+        stderr_callback = function(x, p) { if (quiet) message(x) },
+        timeout = timeout
+      )
     )
   )
 }
 
 clean_cmdstan <- function(dir = cmdstan_path(),
                           cores = getOption("mc.cores", 2),
                           quiet = FALSE) {
-  withr::with_path(
-    c(
-      toolchain_PATH_env_var(),
-      tbb_path(dir = dir)
-    ),
-    wsl_compatible_run(
-      command = make_cmd(),
-      args = "clean-all",
-      wd = dir,
-      echo_cmd = is_verbose_mode(),
-      echo = !quiet || is_verbose_mode(),
-      spinner = quiet,
-      error_on_status = FALSE,
-      stderr_callback = function(x, p) { if (quiet) message(x) }
+  withr::with_envvar(
+    c("HOME" = short_path(Sys.getenv("HOME"))),
+    withr::with_path(
+      c(
+        toolchain_PATH_env_var(),
+        tbb_path(dir = dir)
+      ),
+      wsl_compatible_run(
+        command = make_cmd(),
+        args = "clean-all",
+        wd = dir,
+        echo_cmd = is_verbose_mode(),
+        echo = !quiet || is_verbose_mode(),
+        spinner = quiet,
+        error_on_status = FALSE,
+        stderr_callback = function(x, p) { if (quiet) message(x) }
+      )
     )
   )
 }
 
 build_example <- function(dir, cores, quiet, timeout) {
-  withr::with_path(
-    c(
-      toolchain_PATH_env_var(),
-      tbb_path(dir = dir)
-    ),
-    wsl_compatible_run(
-      command = make_cmd(),
-      args = c(paste0("-j", cores),
-                cmdstan_ext(file.path("examples", "bernoulli", "bernoulli"))),
-      wd = dir,
-      echo_cmd = is_verbose_mode(),
-      echo = !quiet || is_verbose_mode(),
-      spinner = quiet,
-      error_on_status = FALSE,
-      stderr_callback = function(x, p) { if (quiet) message(x) },
-      timeout = timeout
+  withr::with_envvar(
+    c("HOME" = short_path(Sys.getenv("HOME"))),
+    withr::with_path(
+      c(
+        toolchain_PATH_env_var(),
+        tbb_path(dir = dir)
+      ),
+      wsl_compatible_run(
+        command = make_cmd(),
+        args = c(paste0("-j", cores),
+                  cmdstan_ext(file.path("examples", "bernoulli", "bernoulli"))),
+        wd = dir,
+        echo_cmd = is_verbose_mode(),
+        echo = !quiet || is_verbose_mode(),
+        spinner = quiet,
+        error_on_status = FALSE,
+        stderr_callback = function(x, p) { if (quiet) message(x) },
+        timeout = timeout
+      )
     )
   )
 }
@@ -849,7 +858,11 @@ toolchain_PATH_env_var <- function() {
 rtools4x_toolchain_path <- function() {
   toolchain <- ifelse(is_ucrt_toolchain(), "ucrt64", "mingw64")
   if (Sys.getenv("CMDSTANR_USE_RTOOLS") != "") {
-    toolchain <- "x86_64-w64-mingw32.static.posix"
+    if (arch_is_aarch64()) {
+      toolchain <- "aarch64-w64-mingw32.static.posix"
+    } else {
+      toolchain <- "x86_64-w64-mingw32.static.posix"
+    }
   }
   repair_path(file.path(rtools4x_home_path(), toolchain, "bin"))
 }
@@ -871,10 +884,16 @@ rtools4x_version <- function() {
 
 rtools4x_home_path <- function() {
   rtools_ver <- rtools4x_version()
+  if (arch_is_aarch64()) {
+    rtools_ver <- paste0(rtools_ver, "_AARCH64")
+  }
   path <- Sys.getenv(paste0("RTOOLS", rtools_ver, "_HOME"))
 
   if (!nzchar(path)) {
     default_path <- repair_path(file.path(paste0("C:/rtools", rtools_ver)))
+    if (arch_is_aarch64()) {
+      default_path <- paste0(default_path, "-aarch64")
+    }
     if (dir.exists(default_path)) {
       path <- default_path
     }