add pathfinder algorithm

NAMESPACE

@@ -106,6 +106,7 @@ export(simulate_infections)
 export(simulate_secondary)
 export(stan_laplace_opts)
 export(stan_opts)
+export(stan_pathfinder_opts)
 export(stan_sampling_opts)
 export(stan_vb_opts)
 export(summarise_key_measures)

R/opts.R

@@ -798,6 +798,36 @@ stan_laplace_opts <- function(backend = "cmdstanr",
   return(opts)
 }
 
+#' Stan pathfinder algorithm Options
+#'
+#' @description `r lifecycle::badge("stable")` Defines a list specifying the
+#'   arguments passed to [cmdstanr::laplace()].
+#'
+#' @inheritParams stan_opts
+#' @inheritParams stan_vb_opts
+#' @param ... Additional parameters to pass to [cmdstanr::laplace()].
+#' @return A list of arguments to pass to [cmdstanr::laplace()].
+#' @export
+#' @examples
+#' stan_laplace_opts()
+stan_pathfinder_opts <- function(backend = "cmdstanr",
+                                 samples = 2000,
+                                 trials = 10,
+                                 ...) {
+  if (backend != "cmdstanr") {
+    stop(
+      "The pathfinder algorithm is only available with the \"cmdstanr\" ",
+      "backend."
+    )
+  }
+  opts <- list(
+    trials = trials,
+    draws = samples
+  )
+  opts <- c(opts, ...)
+  return(opts)
+}
+
 #' Rstan Options
 #'
 #' @description `r lifecycle::badge("deprecated")`
@@ -858,7 +888,9 @@ rstan_opts <- function(object = NULL,
 #'
 #' @param method A character string, defaulting to sampling. Currently supports
 #' MCMC sampling ("sampling") or approximate posterior sampling via
-#' variational inference ("vb").
+#' variational inference ("vb") and, if the "cmdstanr" backend is used,
+#' approximate posterior sampling with the laplaces algorithm ("laplace") or
+#' pathfinder ("pathfinder").
 #'
 #' @param backend Character string indicating the backend to use for fitting
 #' stan models. Supported arguments are "rstan" (default) or "cmdstanr".
@@ -904,7 +936,9 @@ stan_opts <- function(object = NULL,
                       init_fit = NULL,
                       return_fit = TRUE,
                       ...) {
-  method <- arg_match(method, values = c("sampling", "vb", "laplace"))
+  method <- arg_match(
+    method, values = c("sampling", "vb", "laplace", "pathfinder")
+  )
   backend <- arg_match(backend, values = c("rstan", "cmdstanr"))
   if (backend == "cmdstanr" && !requireNamespace("cmdstanr", quietly = TRUE)) {
     stop(
@@ -934,6 +968,10 @@ stan_opts <- function(object = NULL,
     opts <- c(
       opts, stan_laplace_opts(backend = backend, ...)
     )
+  } else if (method == "pathfinder") {
+    opts <- c(
+      opts, stan_pathfinder_opts(samples = samples, backend = backend, ...)
+    )
   }
 
   if (!is.null(init_fit)) {

R/stan.R

@@ -86,10 +86,10 @@ fit_model <- function(args, id = "stan") {
       future = args$future,
       max_execution_time = args$max_execution_time, id = id
     )
-  } else if (args$method %in% c("vb", "laplace")) {
+  } else if (args$method %in% c("vb", "laplace", "pathfinder")) {
     fit <- fit_model_approximate(args, id = id)
   } else {
-    stop("args$method unknown")
+    stop("method ", args$method, " unknown")
   }
   return(fit)
 }

tests/testthat/test-epinow.R

@@ -85,6 +85,29 @@ test_that("epinow produces expected output when run with the
   )
 })
 
+test_that("epinow produces expected output when run with the
+           pathfinder algorithm", {
+  skip_on_os("windows")
+  output <- capture.output(suppressMessages(suppressWarnings(
+    out <- epinow(
+      reported_cases = reported_cases,
+      generation_time = generation_time_opts(example_generation_time),
+      delays = delay_opts(example_incubation_period + reporting_delay),
+      stan = stan_opts(method = "pathfinder", backend = "cmdstanr"),
+      logs = NULL, verbose = FALSE
+    )
+  )))
+  expect_equal(names(out), expected_out)
+  df_non_zero(out$estimates$samples)
+  df_non_zero(out$estimates$summarised)
+  df_non_zero(out$estimated_reported_cases$samples)
+  df_non_zero(out$estimated_reported_cases$summarised)
+  df_non_zero(out$summary)
+  expect_equal(
+    names(out$plots), c("infections", "reports", "R", "growth_rate", "summary")
+  )
+})
+
 test_that("epinow runs without error when saving to disk", {
   expect_null(suppressWarnings(epinow(
     reported_cases = reported_cases,