enh: forecaster parameters cleanup (#192)

* make flu forecasters parameters more consistent
* don't try linreg
* update template.md
* fix: borked seasonal_method "window", both in data table and in forecaster, just in case
* doc: update README

Author: dshemetov

R/forecasters/forecaster_scaled_pop_seasonal.R

@@ -35,25 +35,27 @@
 #' @importFrom zeallot %<-%
 #' @importFrom recipes all_numeric
 #' @export
-scaled_pop_seasonal <- function(epi_data,
-                                outcome,
-                                extra_sources = "",
-                                ahead = 1,
-                                pop_scaling = TRUE,
-                                drop_non_seasons = FALSE,
-                                scale_method = c("quantile", "std", "none"),
-                                center_method = c("median", "mean", "none"),
-                                nonlin_method = c("quart_root", "none"),
-                                seasonal_method = c("none", "flu", "covid", "indicator", "window", "climatological"),
-                                seasonal_backward_window = 5 * 7,
-                                seasonal_forward_window = 3 * 7,
-                                train_residual = FALSE,
-                                trainer = epipredict::quantile_reg(),
-                                quantile_levels = covidhub_probs(),
-                                filter_source = "",
-                                filter_agg_level = "",
-                                clip_lower = TRUE,
-                                ...) {
+scaled_pop_seasonal <- function(
+  epi_data,
+  outcome,
+  extra_sources = "",
+  ahead = 1,
+  pop_scaling = TRUE,
+  drop_non_seasons = FALSE,
+  scale_method = c("quantile", "std", "none"),
+  center_method = c("median", "mean", "none"),
+  nonlin_method = c("quart_root", "none"),
+  seasonal_method = c("none", "flu", "covid", "indicator", "window", "climatological"),
+  seasonal_backward_window = 5 * 7,
+  seasonal_forward_window = 3 * 7,
+  train_residual = FALSE,
+  trainer = epipredict::quantile_reg(),
+  quantile_levels = covidhub_probs(),
+  filter_source = "",
+  filter_agg_level = "",
+  clip_lower = TRUE,
+  ...
+) {
   scale_method <- arg_match(scale_method)
   center_method <- arg_match(center_method)
   nonlin_method <- arg_match(nonlin_method)
@@ -62,6 +64,9 @@ scaled_pop_seasonal <- function(epi_data,
   extra_sources <- unwrap_argument(extra_sources)
   trainer <- unwrap_argument(trainer)
 
+  if (typeof(seasonal_method) == "list") {
+    seasonal_method <- seasonal_method[[1]]
+  }
   if (all(seasonal_method == c("none", "flu", "covid", "indicator", "window", "climatological"))) {
     seasonal_method <- "none"
   }
@@ -100,7 +105,8 @@ scaled_pop_seasonal <- function(epi_data,
   args_list <- inject(default_args_list(!!!args_input))
   # if you want to hardcode particular predictors in a particular forecaster
   predictors <- c(outcome, extra_sources)
-  c(args_list, predictors, trainer) %<-% sanitize_args_predictors_trainer(epi_data, outcome, predictors, trainer, args_list)
+  c(args_list, predictors, trainer) %<-%
+    sanitize_args_predictors_trainer(epi_data, outcome, predictors, trainer, args_list)
 
   if ("season_week" %nin% names(epi_data)) {
     epi_data %<>% add_season_info()
@@ -116,13 +122,27 @@ scaled_pop_seasonal <- function(epi_data,
     season_data <- epi_data
   }
   # TODO: Jank way to avoid having hhs_region get centered; this isn't very general
-  learned_params <- calculate_whitening_params(season_data, setdiff(predictors, "hhs_region"), scale_method, center_method, nonlin_method)
+  learned_params <- calculate_whitening_params(
+    season_data,
+    setdiff(predictors, "hhs_region"),
+    scale_method,
+    center_method,
+    nonlin_method
+  )
   epi_data %<>% data_whitening(setdiff(predictors, "hhs_region"), learned_params, nonlin_method)
 
   # get the seasonal features
   # first add PCA
   if (("flu" %in% seasonal_method) || ("covid" %in% seasonal_method)) {
-    epi_data <- compute_pca(epi_data, seasonal_method, ahead, scale_method, center_method, nonlin_method, normalize = train_residual)
+    epi_data <- compute_pca(
+      epi_data,
+      seasonal_method,
+      ahead,
+      scale_method,
+      center_method,
+      nonlin_method,
+      normalize = train_residual
+    )
 
     if (train_residual) {
       epi_data <- epi_data %>% mutate(across(all_of(outcome), ~ .x - PC1))
@@ -172,14 +192,15 @@ scaled_pop_seasonal <- function(epi_data,
   # preprocessing supported by epipredict
   preproc <- epi_recipe(epi_data)
   if (pop_scaling) {
-    preproc %<>% step_population_scaling(
-      all_of(predictors),
-      df = epidatasets::state_census,
-      df_pop_col = "pop",
-      create_new = FALSE,
-      rate_rescaling = 1e5,
-      by = c("geo_value" = "abbr")
-    )
+    preproc %<>%
+      step_population_scaling(
+        all_of(predictors),
+        df = epidatasets::state_census,
+        df_pop_col = "pop",
+        create_new = FALSE,
+        rate_rescaling = 1e5,
+        by = c("geo_value" = "abbr")
+      )
   }
   if ("indicator" %in% seasonal_method) {
     preproc %<>%
@@ -201,14 +222,16 @@ scaled_pop_seasonal <- function(epi_data,
   postproc <- frosting()
   postproc %<>% arx_postprocess(trainer, args_list)
   if (pop_scaling) {
-    postproc %<>% layer_population_scaling(
-      .pred, .pred_distn,
-      df = epidatasets::state_census,
-      df_pop_col = "pop",
-      create_new = FALSE,
-      rate_rescaling = 1e5,
-      by = c("geo_value" = "abbr")
-    )
+    postproc %<>%
+      layer_population_scaling(
+        .pred,
+        .pred_distn,
+        df = epidatasets::state_census,
+        df_pop_col = "pop",
+        create_new = FALSE,
+        rate_rescaling = 1e5,
+        by = c("geo_value" = "abbr")
+      )
   }
   # with all the setup done, we execute and format
   pred <- run_workflow_and_format(preproc, postproc, trainer, season_data, epi_data)
@@ -217,7 +240,10 @@ scaled_pop_seasonal <- function(epi_data,
   # finally, any postprocessing not supported by epipredict e.g. calibration
   #
   # undo subtraction if we're training on residuals
-  if (train_residual && (("flu" %in% seasonal_method) || ("covid" %in% seasonal_method) || ("climatological" %in% seasonal_method))) {
+  if (
+    train_residual &&
+      (("flu" %in% seasonal_method) || ("covid" %in% seasonal_method) || ("climatological" %in% seasonal_method))
+  ) {
     pred <- pred %>%
       mutate(epi_week = epiweek(target_end_date)) %>%
       left_join(values_subtracted, by = join_by(geo_value, source, epi_week == epiweek)) %>%
@@ -228,7 +254,12 @@ scaled_pop_seasonal <- function(epi_data,
   # reintroduce color into the value
   pred_final <- pred %>%
     rename({{ outcome }} := value) %>%
-    data_coloring(outcome, learned_params, join_cols = key_colnames(epi_data, exclude = "time_value"), nonlin_method = nonlin_method) %>%
+    data_coloring(
+      outcome,
+      learned_params,
+      join_cols = key_colnames(epi_data, exclude = "time_value"),
+      nonlin_method = nonlin_method
+    ) %>%
     rename(value = {{ outcome }})
   if (clip_lower) {
     pred_final %<>% mutate(value = pmax(0, value))

R/new_epipredict_steps/step_training_window.R

@@ -15,7 +15,7 @@
 #'   Expects n_recent to be finite.
 #' @param seasonal_forward_window An integer value that represents the number of days
 #'   after a season week to include in the training window. The default value
-#'   is 14. Only valid when seasonal is TRUE.
+#'   is 21. Only valid when seasonal is TRUE.
 #' @param seasonal_backward_window An integer value that represents the number of days
 #'   before a season week to include in the training window. The default value
 #'   is 35. Only valid when seasonal is TRUE.
@@ -50,14 +50,16 @@
 #'   prep(tib) %>%
 #'   bake(new_data = NULL)
 step_epi_training_window <-
-  function(recipe,
-           role = NA,
-           n_recent = 50,
-           seasonal = FALSE,
-           seasonal_forward_window = 14,
-           seasonal_backward_window = 35,
-           epi_keys = NULL,
-           id = rand_id("epi_training_window")) {
+  function(
+    recipe,
+    role = NA,
+    n_recent = 50,
+    seasonal = FALSE,
+    seasonal_forward_window = 21,
+    seasonal_backward_window = 35,
+    epi_keys = NULL,
+    id = rand_id("epi_training_window")
+  ) {
     epipredict:::arg_is_scalar(n_recent, id, seasonal, seasonal_forward_window, seasonal_backward_window)
     epipredict:::arg_is_pos(n_recent, seasonal_forward_window, seasonal_backward_window)
     if (is.finite(n_recent)) epipredict:::arg_is_pos_int(n_recent)
@@ -150,7 +152,6 @@ bake.step_epi_training_window <- function(object, new_data, ...) {
     new_data %<>% filter(time_value %in% date_ranges)
   }
 
-
   new_data
 }
 
@@ -162,8 +163,17 @@ print.step_epi_training_window <-
       n_recent <- x$n_recent
       seasonal_forward_window <- x$seasonal_forward_window
       seasonal_backward_window <- x$seasonal_backward_window
-      tr_obj <- recipes::format_selectors(rlang::enquos(n_recent, seasonal_forward_window, seasonal_backward_window), width)
-      recipes::print_step(tr_obj, rlang::enquos(n_recent, seasonal_forward_window, seasonal_backward_window), x$trained, title, width)
+      tr_obj <- recipes::format_selectors(
+        rlang::enquos(n_recent, seasonal_forward_window, seasonal_backward_window),
+        width
+      )
+      recipes::print_step(
+        tr_obj,
+        rlang::enquos(n_recent, seasonal_forward_window, seasonal_backward_window),
+        x$trained,
+        title,
+        width
+      )
     } else {
       title <- "# of recent observations per key limited to:"
       n_recent <- x$n_recent

R/targets/covid_forecaster_config.R

@@ -14,7 +14,7 @@ get_covid_forecaster_params <- function() {
   out <- rlang::list2(
     scaled_pop_main = tidyr::expand_grid(
       forecaster = "scaled_pop",
-      trainer = list("linreg", "quantreg"),
+      trainer = "quantreg",
       lags = list(
         c(0, 7),
         c(0, 7, 14),
@@ -167,9 +167,6 @@ get_covid_forecaster_params <- function() {
       if ("trainer" %in% names(x) && is.list(x$trainer)) {
         x$trainer <- x$trainer[[1]]
       }
-      if ("seasonal_method" %in% names(x) && is.list(x$seasonal_method)) {
-        x$seasonal_method <- x$seasonal_method[[1]]
-      }
       # Add the outcome to each forecaster.
       x$outcome <- "hhs"
       x