Add parsers for cpp opts

R/cpp_opts.R

@@ -0,0 +1,197 @@
+# Internal functions for handling cpp options
+
+# running and parsing exe info --------------------------------
+# run <model> info command
+run_info_cli <- function(exe_file) {
+  withr::with_path(
+    c(
+      toolchain_PATH_env_var(),
+      tbb_path()
+    ),
+    ret <- wsl_compatible_run(
+      command = wsl_safe_path(exe_file),
+      args = "info",
+      echo = is_verbose_mode(),
+      error_on_status = FALSE
+    )
+  )
+  ret
+}
+
+# new (future) parser
+# Parse the string output of <model> `info` into an R object (list)
+parse_exe_info_string <- function(ret_stdout) {
+  info <- list()
+  info_raw <- strsplit(strsplit(ret_stdout, "\n")[[1]], "=")
+  for (key_val in info_raw) {
+    if (length(key_val) > 1) {
+      key_val <- trimws(key_val)
+      val <- key_val[2]
+      if (!is.na(as.logical(val))) {
+        val <- as.logical(val)
+      }
+      info[[tolower(key_val[1])]] <- val
+    }
+  }
+
+  info[["stan_version"]] <- paste0(
+    info[["stan_version_major"]],
+    ".",
+    info[["stan_version_minor"]],
+    ".", info[["stan_version_patch"]]
+  )
+  info[["stan_version_major"]] <- NULL
+  info[["stan_version_minor"]] <- NULL
+  info[["stan_version_patch"]] <- NULL
+
+  info
+}
+
+# old (current) parser
+model_compile_info <- function(exe_file, version) {
+  info <- NULL
+  if (version > "2.26.1") {
+
+    ret <- run_info_cli(exe_file)
+    if (ret$status == 0) {
+      info <- list()
+      info_raw <- strsplit(strsplit(ret$stdout, "\n")[[1]], "=")
+      for (key_val in info_raw) {
+        if (length(key_val) > 1) {
+          key_val <- trimws(key_val)
+          val <- key_val[2]
+          if (!is.na(as.logical(val))) {
+            val <- as.logical(val)
+          }
+          info[[toupper(key_val[1])]] <- val
+        }
+      }
+      info[["STAN_VERSION"]] <- paste0(info[["STAN_VERSION_MAJOR"]], ".", info[["STAN_VERSION_MINOR"]], ".", info[["STAN_VERSION_PATCH"]])
+      info[["STAN_VERSION_MAJOR"]] <- NULL
+      info[["STAN_VERSION_MINOR"]] <- NULL
+      info[["STAN_VERSION_PATCH"]] <- NULL
+    }
+  }
+  info
+}
+
+# convert to compile flags --------------------
+cpp_options_to_compile_flags <- function(cpp_options) {
+  if (length(cpp_options) == 0) {
+    return(NULL)
+  }
+  cpp_built_options <- c()
+  for (i in seq_along(cpp_options)) {
+    option_name <- names(cpp_options)[i]
+    if (is.null(option_name) || !nzchar(option_name)) {
+      cpp_built_options <- c(cpp_built_options, cpp_options[[i]])
+    } else {
+      cpp_built_options <- c(cpp_built_options, paste0(toupper(option_name), "=", cpp_options[[i]]))
+    }
+  }
+  cpp_built_options
+}
+
+
+# check options overall for validity ---------------------------------
+
+validate_cpp_options <- function(cpp_options) {
+  if (is.null(cpp_options) || length(cpp_options) == 0) return(list())
+
+  if (
+    !is.null(cpp_options[["user_header"]]) &&
+      !is.null(cpp_options[["USER_HEADER"]])
+  ) {
+    warning(
+      "User header specified both via cpp_options[[\"USER_HEADER\"]] ",
+      "and cpp_options[[\"user_header\"]].",
+      call. = FALSE
+    )
+  }
+
+  names(cpp_options) <- tolower(names(cpp_options))
+  flags_set_if_defined <- c(
+    # cmdstan
+    "stan_threads", "stan_mpi", "stan_opencl",
+    "stan_no_range_checks", "stan_cpp_optims",
+    # stan math
+    "integrated_opencl", "tbb_lib", "tbb_inc", "tbb_interface_new"
+  )
+  for (flag in flags_set_if_defined)   {
+    if (isFALSE(cpp_options[[flag]])) warning(
+      toupper(flag), " set to ", cpp_options[flag],
+      " Since this is a non-empty value, ",
+      "it will result in the corresponding ccp option being turned ON. To turn this",
+      " option off, use cpp_options = list(", flag, " = NULL)."
+    )
+  }
+  cpp_options
+}
+
+# check specific options for validity ---------------------------------
+
+assert_valid_opencl <- function(opencl_ids, cpp_options) {
+  if (is.null(cpp_options[["stan_opencl"]])
+      && !is.null(opencl_ids)) {
+    stop("'opencl_ids' is set but the model was not compiled with for use with OpenCL.",
+         "\nRecompile the model with 'cpp_options = list(stan_opencl = TRUE)'",
+         call. = FALSE)
+  }
+  invisible(opencl_ids)
+}
+
+assert_valid_threads <- function(threads, cpp_options, multiple_chains = FALSE) {
+  threads_arg <- if (multiple_chains) "threads_per_chain" else "threads"
+  checkmate::assert_integerish(threads, .var.name = threads_arg,
+                               null.ok = TRUE, lower = 1, len = 1)
+  if (is.null(cpp_options[["stan_threads"]]) || !isTRUE(cpp_options[["stan_threads"]])) {
+    if (!is.null(threads)) {
+      warning(
+        "'", threads_arg, "' is set but the model was not compiled with ",
+        "'cpp_options = list(stan_threads = TRUE)' ",
+        "so '", threads_arg, "' will have no effect!",
+        call. = FALSE
+      )
+      threads <- NULL
+    }
+  } else if (isTRUE(cpp_options[["stan_threads"]]) && is.null(threads)) {
+    stop(
+      "The model was compiled with 'cpp_options = list(stan_threads = TRUE)' ",
+      "but '", threads_arg, "' was not set!",
+      call. = FALSE
+    )
+  }
+  invisible(threads)
+}
+
+# compare exe info and cpp options to one another
+exe_info_style_cpp_options <- function(cpp_options) {
+  if(is.null(cpp_options)) cpp_options <- list()
+  names(cpp_options) <- tolower(names(cpp_options))
+  flags_reported_in_exe_info <- c(
+    "stan_threads", "stan_mpi", "stan_opencl",
+    "stan_no_range_checks", "stan_cpp_optims"
+  )
+  for (flag in flags_reported_in_exe_info) {
+    cpp_options[[flag]] <- !(
+      is.null(cpp_options[[flag]]) || cpp_options[[flag]] == ""
+    )
+  }
+  cpp_options
+}
+
+exe_info_reflects_cpp_options <- function(exe_info, cpp_options) {
+  if (length(exe_info) == 0) {
+    warning("Recompiling is recommended due to missing exe_info.")
+    return(TRUE)
+  }
+  if (is.null(cpp_options)) return(TRUE)
+
+  cpp_options <- exe_info_style_cpp_options(cpp_options)[tolower(names(cpp_options))]
+  overlap <- names(cpp_options)[names(cpp_options) %in% names(exe_info)]
+
+  if (length(overlap) == 0) TRUE else all.equal(
+    exe_info[overlap],
+    cpp_options[overlap]
+  )
+}

R/model.R

@@ -2264,41 +2264,6 @@ CmdStanModel$set("public", name = "expose_functions", value = expose_functions)
 
 
 # internal ----------------------------------------------------------------
-
-assert_valid_opencl <- function(opencl_ids, cpp_options) {
-  if (is.null(cpp_options[["stan_opencl"]])
-      && !is.null(opencl_ids)) {
-    stop("'opencl_ids' is set but the model was not compiled with for use with OpenCL.",
-         "\nRecompile the model with 'cpp_options = list(stan_opencl = TRUE)'",
-         call. = FALSE)
-  }
-  invisible(opencl_ids)
-}
-
-assert_valid_threads <- function(threads, cpp_options, multiple_chains = FALSE) {
-  threads_arg <- if (multiple_chains) "threads_per_chain" else "threads"
-  checkmate::assert_integerish(threads, .var.name = threads_arg,
-                               null.ok = TRUE, lower = 1, len = 1)
-  if (is.null(cpp_options[["stan_threads"]]) || !isTRUE(cpp_options[["stan_threads"]])) {
-    if (!is.null(threads)) {
-      warning(
-        "'", threads_arg, "' is set but the model was not compiled with ",
-        "'cpp_options = list(stan_threads = TRUE)' ",
-        "so '", threads_arg, "' will have no effect!",
-        call. = FALSE
-      )
-      threads <- NULL
-    }
-  } else if (isTRUE(cpp_options[["stan_threads"]]) && is.null(threads)) {
-    stop(
-      "The model was compiled with 'cpp_options = list(stan_threads = TRUE)' ",
-      "but '", threads_arg, "' was not set!",
-      call. = FALSE
-    )
-  }
-  invisible(threads)
-}
-
 assert_valid_stanc_options <- function(stanc_options) {
   i <- 1
   names <- names(stanc_options)
@@ -2325,22 +2290,6 @@ assert_stan_file_exists <- function(stan_file) {
   }
 }
 
-cpp_options_to_compile_flags <- function(cpp_options) {
-  if (length(cpp_options) == 0) {
-    return(NULL)
-  }
-  cpp_built_options <- c()
-  for (i in seq_along(cpp_options)) {
-    option_name <- names(cpp_options)[i]
-    if (is.null(option_name) || !nzchar(option_name)) {
-      cpp_built_options <- c(cpp_built_options, cpp_options[[i]])
-    } else {
-      cpp_built_options <- c(cpp_built_options, paste0(toupper(option_name), "=", cpp_options[[i]]))
-    }
-  }
-  cpp_built_options
-}
-
 include_paths_stanc3_args <- function(include_paths = NULL, standalone_call = FALSE) {
   stancflags <- NULL
   if (!is.null(include_paths)) {
@@ -2397,41 +2346,6 @@ model_variables <- function(stan_file, include_paths = NULL, allow_undefined = F
   variables
 }
 
-model_compile_info <- function(exe_file, version) {
-  info <- NULL
-  if (version > "2.26.1") {
-    withr::with_path(
-      c(
-        toolchain_PATH_env_var(),
-        tbb_path()
-      ),
-      ret <- wsl_compatible_run(
-        command = wsl_safe_path(exe_file),
-        args = "info",
-        error_on_status = FALSE
-      )
-    )
-    if (ret$status == 0) {
-      info <- list()
-      info_raw <- strsplit(strsplit(ret$stdout, "\n")[[1]], "=")
-      for (key_val in info_raw) {
-        if (length(key_val) > 1) {
-          key_val <- trimws(key_val)
-          val <- key_val[2]
-          if (!is.na(as.logical(val))) {
-            val <- as.logical(val)
-          }
-          info[[toupper(key_val[1])]] <- val
-        }
-      }
-      info[["STAN_VERSION"]] <- paste0(info[["STAN_VERSION_MAJOR"]], ".", info[["STAN_VERSION_MINOR"]], ".", info[["STAN_VERSION_PATCH"]])
-      info[["STAN_VERSION_MAJOR"]] <- NULL
-      info[["STAN_VERSION_MINOR"]] <- NULL
-      info[["STAN_VERSION_PATCH"]] <- NULL
-    }
-  }
-  info
-}
 
 is_variables_method_supported <- function(mod) {
   cmdstan_version() >= "2.27.0" && mod$has_stan_file() && file.exists(mod$stan_file())

tests/testthat/helper-custom-expectations.R

@@ -100,3 +100,11 @@ expect_noninteractive_silent <- function(object) {
   rlang::with_interactive(value = FALSE,
     expect_silent(object))
 }
+
+expect_equal_ignore_order <- function(object, expected, ...) {
+  object <- expected[sort(names(object))]
+  expected <- expected[sort(names(expected))]
+  expect_equal(object, expected, ...)
+}
+
+expect_not_true <- function(...) expect_false(isTRUE(...))

tests/testthat/test-cpp_opts.R

@@ -0,0 +1,71 @@
+test_that("parse_exe_info_string works", {
+  expect_equal_ignore_order(
+    parse_exe_info_string("
+      stan_version_major = 2
+      stan_version_minor = 38
+      stan_version_patch = 0
+      STAN_THREADS=false
+      STAN_MPI=false
+      STAN_OPENCL=true
+      STAN_NO_RANGE_CHECKS=false
+      STAN_CPP_OPTIMS=false
+    "),
+    list(
+      stan_version = "2.38.0",
+      stan_threads = FALSE,
+      stan_mpi = FALSE,
+      stan_opencl = TRUE,
+      stan_no_range_checks = FALSE,
+      stan_cpp_optims = FALSE
+    )
+  )
+})
+
+test_that("validate_cpp_options works", {
+  expect_equal_ignore_order(
+    validate_cpp_options(list(
+      Stan_Threads = TRUE,
+      STAN_OPENCL = NULL,
+      aBc = FALSE
+    )),
+    list(
+      stan_threads = TRUE,
+      stan_opencl = NULL,
+      abc = FALSE
+    )
+  )
+  expect_warning(validate_cpp_options(list(STAN_OPENCL = FALSE)))
+})
+
+
+test_that("exe_info cpp_options comparison works", {
+  exe_info_all_flags_off <- exe_info_style_cpp_options(list())
+  exe_info_all_flags_off[["stan_version"]] <- "35.0.0"
+
+  expect_true(exe_info_reflects_cpp_options(
+    exe_info_all_flags_off,
+    list()
+  ))
+  expect_true(exe_info_reflects_cpp_options(
+    list(stan_opencl = FALSE),
+    list(stan_opencl = NULL)
+  ))
+  expect_not_true(exe_info_reflects_cpp_options(
+    list(stan_opencl = FALSE),
+    list(stan_opencl = FALSE)
+  ))
+  expect_not_true(exe_info_reflects_cpp_options(
+    list(stan_opencl = FALSE, stan_threads = FALSE),
+    list(stan_opencl = NULL, stan_threads = TRUE)
+  ))
+  expect_not_true(exe_info_reflects_cpp_options(
+    list(stan_opencl = FALSE, stan_threads = FALSE),
+    list(stan_opencl = NULL, stan_threads = TRUE, EXTRA_ARG = TRUE)
+  ))
+
+  # no exe_info -> no recompile based on cpp info
+  expect_warning(
+    expect_true(exe_info_reflects_cpp_options(list(), list())),
+    "Recompiling is recommended"
+  )
+})