merge frosting

Merge branch 'frosting' into add-distn

# Conflicts:
#	NAMESPACE

Author: dajmcdon

NAMESPACE

@@ -5,7 +5,8 @@ S3method(Ops,dist_quantiles)
 S3method(apply_frosting,default)
 S3method(apply_frosting,epi_workflow)
 S3method(augment,epi_workflow)
-S3method(bake,step_epi_shift)
+S3method(bake,step_epi_ahead)
+S3method(bake,step_epi_lag)
 S3method(detect_layer,frosting)
 S3method(detect_layer,workflow)
 S3method(epi_keys,default)
@@ -14,6 +15,11 @@ S3method(epi_keys,recipe)
 S3method(epi_recipe,default)
 S3method(epi_recipe,epi_df)
 S3method(epi_recipe,formula)
+S3method(extract_argument,epi_workflow)
+S3method(extract_argument,frosting)
+S3method(extract_argument,layer)
+S3method(extract_argument,recipe)
+S3method(extract_argument,step)
 S3method(extract_layers,frosting)
 S3method(extract_layers,workflow)
 S3method(extrapolate_quantiles,dist_default)
@@ -23,12 +29,12 @@ S3method(format,dist_quantiles)
 S3method(median,dist_quantiles)
 S3method(predict,epi_workflow)
 S3method(prep,epi_recipe)
-S3method(prep,step_epi_shift)
+S3method(prep,step_epi_ahead)
+S3method(prep,step_epi_lag)
 S3method(print,epi_workflow)
 S3method(print,frosting)
 S3method(print,step_epi_ahead)
 S3method(print,step_epi_lag)
-S3method(print,step_epi_shift)
 S3method(quantile,dist_quantiles)
 S3method(refresh_blueprint,default_epi_recipe_blueprint)
 S3method(run_mold,default_epi_recipe_blueprint)
@@ -60,6 +66,7 @@ export(epi_keys)
 export(epi_recipe)
 export(epi_recipe_blueprint)
 export(epi_workflow)
+export(extract_argument)
 export(extract_layers)
 export(extrapolate_quantiles)
 export(frosting)
@@ -89,7 +96,6 @@ export(smooth_arx_forecaster)
 export(step_epi_ahead)
 export(step_epi_lag)
 export(step_epi_naomit)
-export(step_epi_shift)
 export(validate_layer)
 import(distributional)
 import(recipes)

R/compat-purrr.R

@@ -29,6 +29,17 @@ map_chr <- function(.x, .f, ...) {
   out
 }
 
+.rlang_purrr_args_recycle <- function(args) {
+  lengths <- map_int(args, length)
+  n <- max(lengths)
+
+  stopifnot(all(lengths == 1L | lengths == n))
+  to_recycle <- lengths == 1L
+  args[to_recycle] <- map(args[to_recycle], function(x) rep.int(x, n))
+
+  args
+}
+
 map2 <- function(.x, .y, .f, ...) {
   .f <- rlang::as_function(.f, env = rlang::global_env())
   out <- mapply(.f, .x, .y, MoreArgs = list(...), SIMPLIFY = FALSE)
@@ -63,3 +74,8 @@ pmap <- function(.l, .f, ...) {
     SIMPLIFY = FALSE, USE.NAMES = FALSE
   ))
 }
+
+reduce <- function(.x, .f, ..., .init) {
+  f <- function(x, y) .f(x, y, ...)
+  Reduce(f, .x, init = .init)
+}

R/epi_recipe.R

@@ -46,7 +46,7 @@ epi_recipe.default <- function(x, ...) {
 #' library(recipes)
 #'
 #' jhu <- case_death_rate_subset %>%
-#'   filter(time_value > "2021-08-01") %>%
+#'   dplyr::filter(time_value > "2021-08-01") %>%
 #'   dplyr::arrange(geo_value, time_value)
 #'
 #' r <- epi_recipe(jhu) %>%

R/extract.R

@@ -0,0 +1,109 @@
+#' Extract an argument made to a frosting layer or recipe step
+#'
+#' @param x an epi_workflow, epi_recipe, frosting, step, or layer object
+#' @param name the name of the layer
+#' @param arg the name of the argument
+#' @param ... not used
+#'
+#' @return An object originally passed as an argument to a layer or step
+#' @export
+#'
+#' @examples
+#' f <- frosting() %>%
+#'   layer_predict() %>%
+#'   layer_residual_quantile(probs = c(0.0275, 0.975), symmetrize = FALSE) %>%
+#'   layer_naomit(.pred)
+#'
+#' extract_argument(f, "layer_residual_quantile", "symmetrize")
+extract_argument <- function(x, name, arg, ...) {
+  UseMethod("extract_argument")
+}
+
+#' @export
+extract_argument.layer <- function(x, name, arg, ...) {
+  rlang::check_dots_empty()
+  arg_is_chr_scalar(name, arg)
+  in_layer_name = class(x)[1]
+  if (name != in_layer_name)
+    cli_stop("Requested {name} not found. This is a(n) {in_layer_name}.")
+  if (! arg %in% names(x))
+    cli_stop("Requested argument {arg} not found in {name}.")
+  x[[arg]]
+}
+
+#' @export
+extract_argument.step <- function(x, name, arg, ...) {
+  rlang::check_dots_empty()
+  arg_is_chr_scalar(name, arg)
+  in_step_name = class(x)[1]
+  if (name != in_step_name)
+    cli_stop("Requested {name} not found. This is a {in_step_name}.")
+  if (! arg %in% names(x))
+    cli_stop("Requested argument {arg} not found in {name}.")
+  x[[arg]]
+}
+
+#' @export
+extract_argument.recipe <- function(x, name, arg, ...){
+  rlang::check_dots_empty()
+  step_names <- map_chr(x$steps, ~class(.x)[1])
+  has_step <- name %in% step_names
+  if (!has_step)
+    cli_stop("recipe object does not contain a {name}.")
+  step_locations <- which(name == step_names)
+  out <- map(x$steps[step_locations], extract_argument, name = name, arg = arg)
+  if (length(out) == 1) out <- out[[1]]
+  out
+}
+
+#' @export
+extract_argument.frosting <- function(x, name, arg, ...) {
+  rlang::check_dots_empty()
+  layer_names <- map_chr(x$layers, ~ class(.x)[1])
+  has_layer <- name %in% layer_names
+  if (! has_layer)
+    cli_stop("frosting object does not contain a {name} layer.")
+  layer_locations <- which(name == layer_names)
+  out <- map(x$layers[layer_locations], extract_argument, name = name, arg = arg)
+  if (length(out) == 1) out <- out[[1]]
+  out
+}
+
+#' @export
+extract_argument.epi_workflow <- function(x, name, arg, ...) {
+  rlang::check_dots_empty()
+  type <- sub("_.*", "", name)
+  if (type %in% c("check", "step")) {
+    if (!workflows:::has_preprocessor_recipe(x))
+      cli_stop("The workflow must have a recipe preprocessor.")
+    out <- extract_argument(x$pre$actions$recipe$recipe, name, arg)
+  }
+  if (type %in% "layer")
+    out <- extract_argument(extract_frosting(x), name, arg)
+  if (! type %in% c("check", "step", "layer"))
+    cli_stop("{name} must begin with one of step, check, or layer")
+  return(out)
+}
+
+
+#' @export
+#' @rdname layer-processors
+extract_layers <- function(x, ...) {
+  UseMethod("extract_layers")
+}
+
+
+#' @export
+#' @rdname layer-processors
+extract_layers.frosting <- function(x, ...) {
+  rlang::check_dots_empty()
+  x$layers
+}
+
+#' @export
+#' @rdname layer-processors
+extract_layers.workflow <- function(x, ...) {
+  rlang::check_dots_empty()
+  validate_has_postprocessor(x)
+  extract_layers(x$post$actions$frosting$frosting)
+}

R/get_test_data.R

@@ -28,7 +28,7 @@ get_test_data <- function(recipe, x){
   }
   ## CHECK if it is epi_df?
 
-  max_lags <- max(map_dbl(recipe$steps, ~ max(.x$shift %||% 0)))
+  max_lags <- max(map_dbl(recipe$steps, ~ max(.x$lag %||% 0)))
 
   # CHECK: Return NA if insufficient training data
   if (dplyr::n_distinct(x$time_value) < max_lags) {

R/layers.R

@@ -104,27 +104,7 @@ detect_layer.workflow <- function(x, name, ...) {
   detect_layer(x$post$actions$frosting$frosting, name)
 }
 
-#' @export
-#' @rdname layer-processors
-extract_layers <- function(x, ...) {
-  UseMethod("extract_layers")
-}
-
-
-#' @export
-#' @rdname layer-processors
-extract_layers.frosting <- function(x, ...) {
-  rlang::check_dots_empty()
-  x$layers
-}
 
-#' @export
-#' @rdname layer-processors
-extract_layers.workflow <- function(x, ...) {
-  rlang::check_dots_empty()
-  validate_has_postprocessor(x)
-  extract_layers(x$post$actions$frosting$frosting)
-}
 
 #' Spread a layer of frosting on a fitted workflow
 #'