fix: a very complicated way to fix a bug

Author: dshemetov

R/forecasters/data_validation.R

@@ -106,17 +106,3 @@ filter_minus_one_ahead <- function(epi_data, ahead) {
   }
   epi_data
 }
-
-#' Unwrap an argument if it's a list of length 1
-#'
-#' Many of our arguments to the forecasters come as lists not because we expect
-#' them that way, but as a byproduct of tibble and expand_grid.
-unwrap_argument <- function(arg, default_trigger = "", default = character(0L)) {
-  if (is.list(arg) && length(arg) == 1) {
-    arg <- arg[[1]]
-  }
-  if (identical(arg, default_trigger)) {
-    return(default)
-  }
-  return(arg)
-}

R/forecasters/ensemble_average.R

@@ -25,7 +25,7 @@
 ensemble_average <- function(epi_data,
                              forecasts,
                              outcome,
-                             extra_sources = "",
+                             extra_sources = character(),
                              ensemble_args = list(),
                              ensemble_args_names = NULL) {
   # unique parameters must be buried in ensemble_args so that the generic function signature is stable

R/forecasters/forecaster_climatological.R

@@ -2,7 +2,7 @@
 #'
 climate_linear_ensembled <- function(epi_data,
                                      outcome,
-                                     extra_sources = "",
+                                     extra_sources = character(),
                                      ahead = 7,
                                      trainer = parsnip::linear_reg(),
                                      quantile_levels = covidhub_probs(),
@@ -22,8 +22,7 @@ climate_linear_ensembled <- function(epi_data,
   nonlin_method <- arg_match(nonlin_method)
 
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
   args_list <- list(...)
   ahead <- as.integer(ahead / 7)

R/forecasters/forecaster_flatline.R

@@ -10,16 +10,15 @@
 #' @export
 flatline_fc <- function(epi_data,
                         outcome,
-                        extra_sources = "",
+                        extra_sources = character(),
                         ahead = 1,
                         trainer = parsnip::linear_reg(),
                         quantile_levels = covidhub_probs(),
                         filter_source = "",
                         filter_agg_level = "",
                         ...) {
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
   # perform any preprocessing not supported by epipredict
   epi_data %<>% filter_extraneous(filter_source, filter_agg_level)

R/forecasters/forecaster_flusion.R

@@ -1,6 +1,6 @@
 flusion <- function(epi_data,
                     outcome,
-                    extra_sources = "",
+                    extra_sources = character(),
                     ahead = 7,
                     pop_scaling = FALSE,
                     trainer = rand_forest(
@@ -24,8 +24,7 @@ flusion <- function(epi_data,
   derivative_estimator <- arg_match(derivative_estimator)
 
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
   # perform any preprocessing not supported by epipredict
   args_input <- list(...)

R/forecasters/forecaster_no_recent_outcome.R

@@ -2,7 +2,7 @@
 #' it may whiten any old data as the outcome
 no_recent_outcome <- function(epi_data,
                               outcome,
-                              extra_sources = "",
+                              extra_sources = character(),
                               ahead = 7,
                               pop_scaling = FALSE,
                               trainer = epipredict::quantile_reg(),
@@ -24,8 +24,7 @@ no_recent_outcome <- function(epi_data,
   week_method <- arg_match(week_method)
 
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
   # this is for the case where there are multiple sources in the same column
   epi_data %<>% filter_extraneous(filter_source, filter_agg_level)

R/forecasters/forecaster_scaled_pop.R

@@ -47,7 +47,7 @@
 #' @export
 scaled_pop <- function(epi_data,
                        outcome,
-                       extra_sources = "",
+                       extra_sources = character(),
                        ahead = 1,
                        pop_scaling = TRUE,
                        drop_non_seasons = FALSE,
@@ -64,8 +64,7 @@ scaled_pop <- function(epi_data,
   nonlin_method <- arg_match(nonlin_method)
 
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
   # perform any preprocessing not supported by epipredict
   #

R/forecasters/forecaster_scaled_pop_seasonal.R

@@ -38,7 +38,7 @@
 scaled_pop_seasonal <- function(
   epi_data,
   outcome,
-  extra_sources = "",
+  extra_sources = character(),
   ahead = 1,
   pop_scaling = TRUE,
   drop_non_seasons = FALSE,
@@ -61,12 +61,8 @@ scaled_pop_seasonal <- function(
   nonlin_method <- arg_match(nonlin_method)
 
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
-  if (typeof(seasonal_method) == "list") {
-    seasonal_method <- seasonal_method[[1]]
-  }
   if (all(seasonal_method == c("none", "flu", "covid", "indicator", "window", "climatological"))) {
     seasonal_method <- "none"
   }

R/forecasters/forecaster_smoothed_scaled.R

@@ -51,7 +51,7 @@
 #' @export
 smoothed_scaled <- function(epi_data,
                             outcome,
-                            extra_sources = "",
+                            extra_sources = character(),
                             ahead = 1,
                             pop_scaling = TRUE,
                             trainer = parsnip::linear_reg(),
@@ -73,8 +73,7 @@ smoothed_scaled <- function(epi_data,
   nonlin_method <- arg_match(nonlin_method)
 
   epi_data <- validate_epi_data(epi_data)
-  extra_sources <- unwrap_argument(extra_sources)
-  trainer <- unwrap_argument(trainer)
+  extra_sources <- unlist(extra_sources)
 
   # perform any preprocessing not supported by epipredict
   #

R/targets/covid_forecaster_config.R

@@ -7,6 +7,10 @@
 #'
 #' Variables with 'g_' prefix are globals defined in the calling script.
 #'
+#' Note that expand_grid has some quirks:
+#' - if an entry is a vector c() or a list(), each top-level element is expanded out to a row.
+#' - this means that list(list()) reuses the same inner list for each row.
+#'
 #' @param dummy_mode Boolean indicating whether to use dummy forecasters
 #' @return A list of forecaster parameter combinations
 #' @export
@@ -32,7 +36,6 @@ get_covid_forecaster_params <- function() {
       expand_grid(
         forecaster = "scaled_pop",
         trainer = "quantreg",
-        # since it's a list, this gets expanded out to a single one in each row
         extra_sources = list2("nssp", "google_symptoms", "nwss", "nwss_region", "va_covid_per_100k"),
         lags = list2(
           list2(
@@ -105,18 +108,18 @@ get_covid_forecaster_params <- function() {
     scaled_pop_season = tidyr::expand_grid(
       forecaster = "scaled_pop_seasonal",
       trainer = "quantreg",
-      lags = list(
+      lags = list2(
         c(0, 7, 14, 21),
         c(0, 7)
       ),
       pop_scaling = FALSE,
       n_training = Inf,
-      seasonal_method = list(
-        c("covid"),
-        c("window"),
-        c("covid", "window"),
-        c("climatological"),
-        c("climatological", "window")
+      seasonal_method = list2(
+        list2("covid"),
+        list2("window"),
+        list2("covid", "window"),
+        list2("climatological"),
+        list2("climatological", "window")
       )
     ),
     climate_linear = bind_rows(
@@ -165,9 +168,6 @@ get_covid_forecaster_params <- function() {
         x$forecaster <- "dummy_forecaster"
       }
       x <- add_id(x)
-      if ("trainer" %in% names(x) && is.list(x$trainer)) {
-        x$trainer <- x$trainer[[1]]
-      }
       # Add the outcome to each forecaster.
       x$outcome <- "hhs"
       x

R/targets/flu_forecaster_config.R

@@ -209,31 +209,16 @@ get_flu_forecaster_params <- function() {
       tidyr::expand_grid(
         forecaster = "scaled_pop_seasonal",
         trainer = "quantreg",
-        lags = list2(
-          c(0, 7)
+        lags = list2(c(0, 7)),
+        seasonal_method = list2(
+          list2("window"),
+          list2("window", "flu"),
+          list2("window", "climatological")
         ),
-        seasonal_method = list("flu", "indicator", "climatological"),
-        pop_scaling = FALSE,
-        train_residual = c(TRUE, FALSE),
-        filter_source = c("", "nhsn"),
-        filter_agg_level = "state",
-        drop_non_seasons = c(TRUE, FALSE),
-        n_training = Inf,
-        keys_to_ignore = g_very_latent_locations
-      ),
-      # Window-based seasonal method shouldn't drop non-seasons
-      tidyr::expand_grid(
-        forecaster = "scaled_pop_seasonal",
-        trainer = "quantreg",
-        lags = list(
-          c(0, 7)
-        ),
-        seasonal_method = list("window", c("window", "flu"), c("window", "climatological")),
         pop_scaling = FALSE,
         train_residual = c(FALSE, TRUE),
         filter_source = c("", "nhsn"),
         filter_agg_level = "state",
-        drop_non_seasons = FALSE,
         n_training = Inf,
         keys_to_ignore = g_very_latent_locations
       )
@@ -250,7 +235,7 @@ get_flu_forecaster_params <- function() {
             c(0, 7) # exogenous feature
           )
         ),
-        seasonal_method = "window",
+        seasonal_method = list2("window"),
         pop_scaling = FALSE,
         filter_source = c("", "nhsn"),
         filter_agg_level = "state",
@@ -262,10 +247,8 @@ get_flu_forecaster_params <- function() {
     season_window_sizes = tidyr::expand_grid(
       forecaster = "scaled_pop_seasonal",
       trainer = "quantreg",
-      lags = list(
-        c(0, 7)
-      ),
-      seasonal_method = "window",
+      lags = list2(c(0, 7)),
+      seasonal_method = list2("window"),
       pop_scaling = FALSE,
       train_residual = FALSE,
       filter_source = c("", "nhsn"),
@@ -325,9 +308,6 @@ get_flu_forecaster_params <- function() {
         x$forecaster <- "dummy_forecaster"
       }
       x <- add_id(x)
-      if ("trainer" %in% names(x) && is.list(x$trainer)) {
-        x$trainer <- x$trainer[[1]]
-      }
       # Add the outcome to each forecaster.
       x$outcome <- "hhs"
       x

R/utils.R

@@ -30,7 +30,7 @@ forecaster_lookup <- function(pattern, forecaster_params_grid = NULL) {
 
   out <- forecaster_params_grid %>% filter(grepl(pattern, .data$id))
   if (nrow(out) > 0) {
-    out %>% glimpse()
+    out %>% unlist()
     return(out)
   }
 }

scripts/covid_hosp_explore.R

@@ -29,9 +29,9 @@ g_reports_dir <- "reports"
 g_fetch_args <- epidatr::fetch_args_list(return_empty = FALSE, timeout_seconds = 400)
 # Geos with insufficient data for forecasting.
 g_insufficient_data_geos <- c("as", "pr", "vi", "gu", "mp")
-# Human-readable object to be used for inspecting the forecasters in the pipeline.
+# Parameters object used for grouping forecasters by family.
 g_forecaster_parameter_combinations <- get_covid_forecaster_params()
-# Targets-readable object to be used for running the pipeline.
+# Targets-readable object used for running the pipeline.
 g_forecaster_params_grid <- g_forecaster_parameter_combinations %>%
   imap(\(x, i) make_forecaster_grid(x, i)) %>%
   bind_rows()

scripts/flu_hosp_explore.R

@@ -34,9 +34,9 @@ g_very_latent_locations <- list(list(
   c("source"),
   c("flusurv", "ILI+")
 ))
-# Human-readable object to be used for inspecting the forecasters in the pipeline.
+# Parameters object used for grouping forecasters by family.
 g_forecaster_parameter_combinations <- get_flu_forecaster_params()
-# Targets-readable object to be used for running the pipeline.
+# Targets-readable object used for running the pipeline.
 g_forecaster_params_grid <- g_forecaster_parameter_combinations %>%
   imap(\(x, i) make_forecaster_grid(x, i)) %>%
   bind_rows()

scripts/one_offs/forecaster_profiling.R

@@ -11,7 +11,7 @@ p <- profvis::profvis({
     epi_archive = d,
     outcome = "hhs",
     ahead = 2,
-    extra_sources = "",
+    extra_sources = character(),
     forecaster = scaled_pop,
     n_training_pad = 30L,
     forecaster_args = list(