Added update.layer and update_frosting

NAMESPACE

@@ -2,6 +2,11 @@
 
 S3method(Math,dist_quantiles)
 S3method(Ops,dist_quantiles)
+S3method(add_model,epi_workflow)
+S3method(adjust_epi_recipe,epi_recipe)
+S3method(adjust_epi_recipe,epi_workflow)
+S3method(adjust_frosting,epi_workflow)
+S3method(adjust_frosting,frosting)
 S3method(apply_frosting,default)
 S3method(apply_frosting,epi_workflow)
 S3method(augment,epi_workflow)
@@ -75,6 +80,7 @@ S3method(print,step_population_scaling)
 S3method(print,step_training_window)
 S3method(quantile,dist_quantiles)
 S3method(refresh_blueprint,default_epi_recipe_blueprint)
+S3method(remove_model,epi_workflow)
 S3method(residuals,flatline)
 S3method(run_mold,default_epi_recipe_blueprint)
 S3method(slather,layer_add_forecast_date)
@@ -92,12 +98,17 @@ S3method(snap,default)
 S3method(snap,dist_default)
 S3method(snap,dist_quantiles)
 S3method(snap,distribution)
+S3method(update,layer)
+S3method(update_model,epi_workflow)
 S3method(vec_ptype_abbr,dist_quantiles)
 S3method(vec_ptype_full,dist_quantiles)
 export("%>%")
 export(add_epi_recipe)
 export(add_frosting)
 export(add_layer)
+export(add_model)
+export(adjust_epi_recipe)
+export(adjust_frosting)
 export(apply_frosting)
 export(arx_args_list)
 export(arx_class_args_list)
@@ -146,7 +157,9 @@ export(new_epi_recipe_blueprint)
 export(pivot_quantiles)
 export(prep)
 export(quantile_reg)
+export(remove_epi_recipe)
 export(remove_frosting)
+export(remove_model)
 export(slather)
 export(smooth_quantile_reg)
 export(step_epi_ahead)
@@ -156,6 +169,9 @@ export(step_growth_rate)
 export(step_lag_difference)
 export(step_population_scaling)
 export(step_training_window)
+export(update_epi_recipe)
+export(update_frosting)
+export(update_model)
 export(validate_layer)
 import(distributional)
 import(epiprocess)

R/epi_recipe.R

@@ -227,23 +227,27 @@ is_epi_recipe <- function(x) {
 
 
 
-#' Add an epi_recipe to a workflow
+#' Add an `epi_recipe` to a workflow
 #'
 #' @seealso [workflows::add_recipe()]
 #' - `add_recipe()` specifies the terms of the model and any preprocessing that
 #'   is required through the usage of a recipe.
 #'
 #' - `remove_recipe()` removes the recipe as well as any downstream objects
 #'
+#' - `update_recipe()` first removes the recipe, then replaces the previous
+#' recipe with the new one.
+#'
 #' @details
-#' Has the same behaviour as [workflows::add_recipe()] but sets a different
+#' `add_epi_recipe` has the same behaviour as
+#' [workflows::add_recipe()] but sets a different
 #' default blueprint to automatically handle [epiprocess::epi_df] data.
 #'
-#' @param x A workflow or epi_workflow
+#' @param x A `workflow` `or `epi_workflow`
 #'
-#' @param recipe A recipe created using [recipes::recipe()]
+#' @param recipe A recipe created using [recipes::recipe()].
 #'
-#' @param ... Not used.
+#' @param ... Not used
 #'
 #' @param blueprint A hardhat blueprint used for fine tuning the preprocessing.
 #'
@@ -276,13 +280,117 @@ is_epi_recipe <- function(x) {
 #'   add_epi_recipe(r)
 #'
 #' workflow
+#'
+#' r2 <- epi_recipe(jhu) %>%
+#'   step_epi_lag(death_rate, lag = c(0, 7, 14)) %>%
+#'   step_epi_ahead(death_rate, ahead = 7)
+
+#' workflow <- update_epi_recipe(workflow, r2)
+#'
+#' workflow <- remove_epi_recipe(workflow)
+#'
+#' workflow
+#'
 add_epi_recipe <- function(
     x, recipe, ..., blueprint = default_epi_recipe_blueprint()) {
   workflows::add_recipe(x, recipe, ..., blueprint = blueprint)
 }
 
+#' @rdname add_epi_recipe
+#' @export
+remove_epi_recipe <- function(x) {
+  workflows:::validate_is_workflow(x)
+
+  if (!workflows:::has_preprocessor_recipe(x)) {
+    rlang::warn("The workflow has no recipe preprocessor to remove.")
+  }
 
+  actions <- x$pre$actions
+  actions[["recipe"]] <- NULL
 
+  new_epi_workflow(
+    pre = workflows:::new_stage_pre(actions = actions),
+    fit = x$fit,
+    post = x$post,
+    trained = FALSE
+  )
+}
+
+#' @rdname add_epi_recipe
+#' @export
+update_epi_recipe <- function(x, recipe, ..., blueprint = NULL) {
+  x <- remove_epi_recipe(x)
+  add_epi_recipe(x, recipe, blueprint = blueprint)
+}
+
+#' Adjust a step in an `epi_workflow` or `epi_recipe`
+#'
+#' Make a parameter adjustment to a step in either an
+#' `epi_workflow` or `epi_recipe` object.
+#'
+#'
+#' @details This function can either adjust a step in a `epi_recipe` object
+#' or a step from a `epi_recipe` object in an `epi_workflow`. In any case, the
+#' argument name and update value must be inputted as `...`.
+#' See the examples below for brief illustrations of both types of updates.
+#'
+#' @param x A `epi_workflow` or `epi_recipe` object
+#'
+#' @param step_num the number of the step to adjust
+#'
+#' @param ... Used to input a parameter adjustment
+#'
+#' @param blueprint A hardhat blueprint used for fine tuning the preprocessing.
+#'
+#' @return
+#' `x`, updated with the adjustment to the specified `epi_recipe` step.
+#'
+#' @export
+#' @examples
+#' jhu <- case_death_rate_subset %>%
+#'   filter(time_value > "2021-11-01", geo_value %in% c("ak", "ca", "ny"))
+#' r <- epi_recipe(jhu) %>%
+#'   step_epi_lag(death_rate, lag = c(0, 7, 14)) %>%
+#'   step_epi_ahead(death_rate, ahead = 7) %>%
+#'   step_epi_naomit()
+#'
+#' wf <- epi_workflow(r, parsnip::linear_reg()) %>% fit(jhu)
+#' latest <- jhu %>%
+#'   dplyr::filter(time_value >= max(time_value) - 14)
+#'
+#' # Adjust `step_epi_ahead` to have an ahead value of 14
+#' # in the `epi_workflow`
+#' wf2 = wf %>% adjust_epi_recipe(step_num = 2, ahead = 14)
+#' workflows::extract_preprocessor(wf2)
+#'
+#' # Adjust `step_epi_ahead` to have an ahead value of 14
+#' # in the `epi_recipe`
+#' r2 = r %>% adjust_epi_recipe(step_num = 2, ahead = 14)
+#' r2
+#'
+adjust_epi_recipe <- function(x, step_num, ..., blueprint = default_epi_recipe_blueprint()) {
+  UseMethod("adjust_epi_recipe")
+}
+
+#' @rdname adjust_epi_recipe
+#' @export
+adjust_epi_recipe.epi_workflow <- function(
+    x, step_num, ..., blueprint = default_epi_recipe_blueprint()) {
+
+  recipe <- workflows::extract_preprocessor(x)
+  recipe$steps[[step_num]] <- update(recipe$steps[[step_num]], ...)
+
+  update_epi_recipe(x, recipe, blueprint = blueprint)
+}
+
+#' @rdname adjust_epi_recipe
+#' @export
+adjust_epi_recipe.epi_recipe <- function(
+    x, step_num, ..., blueprint = default_epi_recipe_blueprint()) {
+
+  x$steps[[step_num]] <- update(x$steps[[step_num]], ...)
+  x
+}
 
 # unfortunately, almost everything the same as in prep.recipe except string/fctr handling
 #' @export

R/epi_workflow.R

@@ -58,6 +58,103 @@ is_epi_workflow <- function(x) {
   inherits(x, "epi_workflow")
 }
 
+
+#' Add a model to an `epi_workflow`
+#'
+#' @seealso [workflows::add_model()]
+#' - `add_model()` adds a parsnip model to the `epi_workflow`.
+#'
+#' - `remove_model()` removes the model specification as well as any fitted
+#'   model object. Any extra formulas are also removed.
+#'
+#' - `update_model()` first removes the model then adds the new
+#' specification to the workflow.
+#'
+#' @details
+#' Has the same behaviour as [workflows::add_model()] but also ensures
+#' that the returned object is an `epi_workflow`.
+#'
+#' @inheritParams workflows::add_model
+#'
+#' @param x An `epi_workflow`.
+#'
+#' @param spec A parsnip model specification.
+#'
+#' @param ... Not used.
+#'
+#' @return
+#' `x`, updated with a new, updated, or removed model.
+#'
+#' @export
+#' @examples
+#' jhu <- case_death_rate_subset %>%
+#' dplyr::filter(time_value > "2021-11-01",
+#' geo_value %in% c("ak", "ca", "ny"))
+#'
+#' r <- epi_recipe(jhu) %>%
+#'   step_epi_lag(death_rate, lag = c(0, 7, 14)) %>%
+#'   step_epi_ahead(death_rate, ahead = 7)
+#'
+#' rf_model <- rand_forest(mode = "regression")
+#'
+#' wf <- epi_workflow(r)
+#'
+#' wf <- wf %>% add_model(rf_model)
+#' wf
+#'
+#' lm_model <- parsnip::linear_reg()
+#'
+#' wf <- update_model(wf, lm_model)
+#' wf
+#'
+#' wf <- remove_model(wf)
+#' wf
+#' @export
+add_model <- function(x, spec, ..., formula = NULL)
+  UseMethod('add_model')
+
+#' @rdname add_model
+#' @export
+remove_model <- function(x)
+  UseMethod('remove_model')
+
+#' @rdname add_model
+#' @export
+update_model <- function(x, spec, ..., formula = NULL)
+  UseMethod('update_model')
+
+#' @rdname add_model
+#' @export
+add_model.epi_workflow <- function(x, spec, ..., formula = NULL) {
+  workflows::add_model(x, spec, formula = formula)
+}
+
+#' @rdname add_model
+#' @export
+remove_model.epi_workflow <- function(x) {
+  workflows:::validate_is_workflow(x)
+
+  if (!workflows:::has_spec(x)) {
+    rlang::warn("The workflow has no model to remove.")
+  }
+
+  new_epi_workflow(
+    pre = x$pre,
+    fit = workflows:::new_stage_fit(),
+    post = x$post,
+    trained = FALSE
+  )
+}
+
+#' @rdname add_model
+#' @export
+update_model.epi_workflow <- function(x, spec, ..., formula = NULL) {
+  rlang::check_dots_empty()
+  x <- remove_model(x)
+  workflows::add_model(x, spec, formula = formula)
+}
+
+
 #' Fit an `epi_workflow` object
 #'
 #' @description
@@ -212,6 +309,7 @@ new_epi_workflow <- function(
     pre = pre, fit = fit, post = post, trained = trained
   )
   class(out) <- c("epi_workflow", class(out))
+  out
 }