fix(fit): accept a PM_result or data frame as prior

R/PM_model.R

@@ -1301,7 +1301,15 @@ PM_model <- R6::R6Class(
       }
 
       # set prior
-      if (length(prior) == 1 && prior != "sobol") {
+      if (inherits(prior, "PM_result")) {
+        prior <- prior$final$popPoints
+        if (!is.data.frame(prior)) {
+          msg <- c(msg, "{.arg prior} is a {.cls PM_result} without final population support points.")
+          run_error <- run_error + 1
+          prior <- "sobol"
+        }
+      }
+      if (is.data.frame(prior) || (length(prior) == 1 && prior != "sobol")) {
         if (is.numeric(prior)) {
           # prior specified as a run number
           if (!file.exists(glue::glue("{path}/{prior}/outputs/theta.csv"))) {
@@ -1321,7 +1329,7 @@ PM_model <- R6::R6Class(
               msg <- c(msg, prior_res$note)
             }
           }
-        } else if (length(prior) == 1 && is.character(prior)) {
+        } else if (is.character(prior)) {
           # prior specified as a filename
           if (!file.exists(prior)) {
             msg <- c(msg, "{.arg prior} file does not exist.")
@@ -1360,11 +1368,12 @@ PM_model <- R6::R6Class(
             }
           }
         } else {
-          msg <- c(msg, "{.arg prior} must be a numeric run number or character filename.")
+          msg <- c(msg, "{.arg prior} must be a numeric run number, character filename, data frame or {.cls PM_result}.")
           run_error <- run_error + 1
         }
-      } else {
-        prior <- "sobol"
+      } else if (!identical(prior, "sobol")) {
+        msg <- c(msg, "{.arg prior} must be a numeric run number, character filename, data frame or {.cls PM_result}.")
+        run_error <- run_error + 1
       }
 
       #### Abort if errors before creating new folder ####

tests/testthat/test-pm-fit-prior-parameters.R

@@ -158,3 +158,62 @@ test_that("PM_model$fit supports numeric prior run and normalizes theta.csv colu
   expect_false(file.exists(file.path(getwd(), "prior.csv")))
   expect_equal(names(utils::read.csv(file.path(captured_wd, "prior.csv"), check.names = FALSE)), c(params, "prob"))
 })
+
+run_fit_with_prior_object <- function(prior) {
+  model <- PM_model$new(x = NPex$model, compile = FALSE)
+  run_root <- withr::local_tempdir(pattern = "prior-object-", .local_envir = parent.frame())
+  captured <- list(called = FALSE)
+
+  testthat::with_mocked_bindings(
+    fit = function(model_source, data, params, output_path, solver = NULL) {
+      captured$called <<- TRUE
+      captured$prior <<- params$prior
+      if (identical(params$prior, "prior.csv")) {
+        captured$prior_df <<- utils::read.csv("prior.csv", check.names = FALSE)
+      }
+      dir.create(output_path, recursive = TRUE)
+      invisible(NULL)
+    },
+    PM_parse = function(path) invisible(NULL),
+    PM_load = function(path, file, ...) structure(list(path = path), class = c("PM_result", "R6")),
+    {
+      model$fit(
+        data = NPex$data,
+        path = run_root,
+        run = 1,
+        cycles = 0,
+        prior = prior,
+        overwrite = TRUE,
+        report = "none",
+        quiet = TRUE
+      )
+    }
+  )
+  captured
+}
+
+test_that("PM_model$fit uses final support points of a PM_result prior", {
+  params <- tolower(names(NPex$model$model_list$pri))
+  prior_df <- make_prior_df(params)
+  prior_result <- structure(list(final = list(popPoints = prior_df)), class = "PM_result")
+
+  out <- run_fit_with_prior_object(prior_result)
+
+  expect_equal(out$prior, "prior.csv")
+  expect_equal(out$prior_df, prior_df, ignore_attr = TRUE)
+})
+
+test_that("PM_model$fit uses a data frame prior", {
+  params <- tolower(names(NPex$model$model_list$pri))
+  prior_df <- make_prior_df(params)
+
+  out <- run_fit_with_prior_object(prior_df)
+
+  expect_equal(out$prior, "prior.csv")
+  expect_equal(out$prior_df, prior_df, ignore_attr = TRUE)
+})
+
+test_that("PM_model$fit rejects an unsupported prior instead of using sobol", {
+  out <- run_fit_with_prior_object(c(1, 2))
+  expect_false(out$called)
+})