Make layer_predict forward stored dots_list to predict()

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: epipredict
 Title: Basic epidemiology forecasting methods
-Version: 0.0.16
+Version: 0.0.17
 Authors@R: c(
     person("Daniel", "McDonald", , "daniel@stat.ubc.ca", role = c("aut", "cre")),
     person("Ryan", "Tibshirani", , "ryantibs@cmu.edu", role = "aut"),

NEWS.md

@@ -47,3 +47,5 @@ Pre-1.0.0 numbering scheme: 0.x will indicate releases, while 0.0.x will indicat
 - Revise `compat-purrr` to use the r-lang `standalone-*` version (via
   `{usethis}`)
 - `epi_recipe()` will now warn when given non-`epi_df` data
+- `layer_predict()` will now appropriately forward `...` args intended for
+  `predict.workflow()`

R/epi_workflow.R

@@ -123,7 +123,7 @@ fit.epi_workflow <- function(object, data, ..., control = workflows::control_wor
 #'   possible. Specifically, the output will have `time_value` and
 #'   `geo_value` columns as well as the prediction.
 #'
-#' @inheritParams parsnip::predict.model_fit
+#' @inheritParams workflows::predict.workflow
 #'
 #' @param object An epi_workflow that has been fit by
 #'   [workflows::fit.workflow()]

R/layer_predict.R

@@ -45,12 +45,18 @@ layer_predict <-
            id = rand_id("predict_default")) {
     arg_is_chr_scalar(id)
     arg_is_chr_scalar(type, allow_null = TRUE)
+    dots_list <- rlang::dots_list(..., .homonyms = "error", .check_assign = TRUE)
+    if (any(rlang::names2(dots_list) == "")) {
+      cli_abort("All `...` arguments must be named.",
+        class = "epipredict__layer_predict__unnamed_dot"
+      )
+    }
     add_layer(
       frosting,
       layer_predict_new(
         type = type,
         opts = opts,
-        dots_list = rlang::list2(...), # can't figure how to use this
+        dots_list = dots_list,
         id = id
       )
     )
@@ -63,13 +69,16 @@ layer_predict_new <- function(type, opts, dots_list, id) {
 
 #' @export
 slather.layer_predict <- function(object, components, workflow, new_data, ...) {
+  rlang::check_dots_empty()
+
   the_fit <- workflows::extract_fit_parsnip(workflow)
 
-  components$predictions <- predict(
+  components$predictions <- rlang::inject(predict(
     the_fit,
     components$forged$predictors,
-    type = object$type, opts = object$opts
-  )
+    type = object$type, opts = object$opts,
+    !!!object$dots_list
+  ))
   components$predictions <- dplyr::bind_cols(
     components$keys, components$predictions
   )

tests/testthat/test-layer_predict.R

@@ -31,3 +31,47 @@ test_that("prediction with interval works", {
   expect_equal(nrow(p), 108L)
   expect_named(p, c("geo_value", "time_value", ".pred_lower", ".pred_upper"))
 })
+
+test_that("layer_predict dots validation", {
+  # We balk at unnamed arguments, though perhaps not with the most helpful error messages:
+  expect_error(
+    frosting() %>% layer_predict("pred_int", list(), tibble::tibble(x = 5)),
+    class = "epipredict__layer_predict__unnamed_dot"
+  )
+  expect_error(
+    frosting() %>% layer_predict("pred_int", list(), "maybe_meant_to_be_id"),
+    class = "epipredict__layer_predict__unnamed_dot"
+  )
+  # We allow arguments that might actually work at prediction time:
+  expect_no_error(frosting() %>% layer_predict(type = "quantile", interval = "confidence"))
+
+  # We don't detect completely-bogus arg names until predict time:
+  expect_no_error(f_bad_arg <- frosting() %>% layer_predict(bogus_argument = "something"))
+  wf_bad_arg <- wf %>% add_frosting(f_bad_arg)
+  expect_error(predict(wf_bad_arg, latest))
+  # Some argument names only apply for some prediction `type`s; we don't check for ignored arguments, and neither does workflows:
+  expect_no_error(frosting() %>% layer_predict(eval_time = "preferably this would error"))
+
+  # ^ (currently with a truly awful error message, due to an extra comma in parsnip::check_pred_type_dots)
+  #
+  # Unfortunately, we outright ignore attempts to pass args via `predict.epi_workflow`:
+  f_predict <- frosting() %>% layer_predict()
+  wf_predict <- wf %>% add_frosting(f_predict)
+  expect_no_error(predict(wf_predict, latest, type = "pred_int"))
+})
+
+test_that("layer_predict dots are forwarded", {
+  f_lm_int_level <- frosting() %>%
+    layer_predict(type = "pred_int", level = 0.8)
+  wf_lm_int_level <- wf %>% add_frosting(f_lm_int_level)
+  p <- predict(wf, latest)
+  p_lm_int_level <- predict(wf_lm_int_level, latest)
+  expect_contains(names(p_lm_int_level), c(".pred_lower", ".pred_upper"))
+  expect_equal(nrow(na.omit(p)), nrow(na.omit(p_lm_int_level)))
+  expect_true(cbind(p, p_lm_int_level[c(".pred_lower", ".pred_upper")]) %>%
+    na.omit() %>%
+    mutate(sandwiched = .pred_lower <= .pred & .pred <= .pred_upper) %>%
+    `[[`("sandwiched") %>%
+    all())
+  # There are many possible other valid configurations that aren't tested here.
+})