wip

Author: dshemetov

R/scoring.R

@@ -12,20 +12,24 @@ evaluate_predictions <- function(forecasts, truth_data) {
     must.include = c("geo_value", "target_end_date", "true_value")
   )
 
-  # joined_forecasts <- left_join(forecasts, truth_data, by = c("geo_value", "target_end_date"))
+  browser()
+  joined_forecasts <- left_join(forecasts, truth_data, by = c("geo_value", "target_end_date"))
 
-  # joined_forecasts %>%
-  #   group_by(model, geo_value, forecast_date, target_end_date) %>%
-  #   summarize(increasing = all(prediction - shift(prediction, 1, 0) > 0)) %>%
-  #   ungroup() %>%
-  #   filter(!increasing)
-
-  pred_final %>%
-    group_by(geo_value, forecast_date, target_end_date) %>%
-    summarize(increasing = all(value - shift(value, 1, 0) > 0)) %>%
+  joined_forecasts %>%
+    group_by(model, geo_value, forecast_date, target_end_date) %>%
+    summarize(increasing = all(prediction - shift(prediction, 1, 0) > 0)) %>%
     ungroup() %>%
     filter(!increasing)
 
+  joined_forecasts %>%
+    filter(geo_value == "ma", forecast_date == "2023-10-21", target_end_date == "2023-10-21")
+
+  # pred_final %>%
+  #   group_by(geo_value, forecast_date, target_end_date) %>%
+  #   summarize(increasing = all(value - shift(value, 1, 0) > 0)) %>%
+  #   ungroup() %>%
+  #   filter(!increasing)
+
   # joined_forecasts %>% filter(geo_value == "ma", forecast_date == "2023-10-07", target_end_date == "2023-10-21") %>% print(n=50)
 
   forecast_obj <- left_join(forecasts, truth_data, by = c("geo_value", "target_end_date")) %>%
@@ -36,7 +40,6 @@ evaluate_predictions <- function(forecasts, truth_data) {
       forecast_unit = c("model", "geo_value", "forecast_date", "target_end_date")
     )
 
-  # browser()
   scores <- forecast_obj %>%
     scoringutils::score(metrics = get_metrics(.)) %>%
     as_tibble() %>%

R/utils.R

@@ -7,25 +7,25 @@
 #' @param pattern string to search in the forecaster name.
 #'
 #' @export
-forecaster_lookup <- function(pattern, forecaster_grid = NULL, printing = TRUE) {
+forecaster_lookup <- function(pattern, forecaster_grid = NULL) {
   if (is.null(forecaster_grid)) {
-    cli::cli_warn("Reading `forecaster_param_combinations` target. If it's not up to date, results will be off. Update with `tar_make(forecaster_parameter_combinations)`.")
-    forecaster_grid <- tar_read_raw("forecaster_parameter_combinations") %>%
-      map(make_forecaster_grid) %>%
-      bind_rows()
+    cli::cli_warn("Reading `forecaster_param_combinations` target. If it's not up to date, results will be off.
+    Update with `tar_make(forecaster_parameter_combinations)`.")
+    forecaster_grid <- tar_read_raw("forecaster_parameter_grid")
   }
-  fc_row <- forecaster_grid %>% filter(grepl(pattern, id))
-  if (printing) {
-    params <- fc_row$params[[1]]
-    if (!is.null(params$trainer)) {
-      params$trainer <- as_string(params$trainer)
+
+  # Remove the "forecaster_" prefix from the pattern if it exists.
+  if (grepl("forecaster_", pattern)) {
+    pattern <- gsub("forecaster_", "", pattern)
+  }
+
+  for (table in forecaster_grid) {
+    filtered_table <- table %>% filter(grepl(pattern, id))
+    if (nrow(filtered_table) > 0) {
+      filtered_table %>% glimpse()
+      break
     }
-    print(glue::glue("name: {fc_row %>% pull(id)}"))
-    print(glue::glue("forecaster: {fc_row$forecaster[[1]]}"))
-    print(glue::glue("params:"))
-    print(params %>% data.table::as.data.table())
   }
-  return(fc_row)
 }
 
 #' Add a unique id based on the column contents
@@ -37,8 +37,6 @@ forecaster_lookup <- function(pattern, forecaster_grid = NULL, printing = TRUE)
 #'
 #' @export
 add_id <- function(tib, exclude = c()) {
-  browser()
-  # TODO
   ids <- tib %>%
     select(-all_of(exclude)) %>%
     purrr::transpose() %>%
@@ -63,7 +61,7 @@ get_single_id <- function(param_list) {
 }
 
 #' Turn a tibble of parameters into a list of named lists.
-make_params_list <- function(df, singleton_cols = c("trainer")) {
+make_params_list <- function(df, unlist_cols = c("lags", "trainer"), get_cols = c("trainer")) {
   params_list <- df %>%
     select(-forecaster, -id) %>%
     split(seq_len(nrow(.))) %>%
@@ -72,9 +70,10 @@ make_params_list <- function(df, singleton_cols = c("trainer")) {
   names(params_list) <- df$id
 
   # Some columns need to be unlisted.
-  if (length(singleton_cols) > 0) {
+  unlist_cols <- unlist_cols[unlist_cols %in% names(params_list[[1]])]
+  if (length(unlist_cols) > 0) {
     params_list %<>% lapply(function(x) {
-      for (col in singleton_cols) {
+      for (col in unlist_cols) {
         if (length(x[[col]]) == 1) {
           x[[col]] <- x[[col]][[1]]
         }
@@ -83,13 +82,16 @@ make_params_list <- function(df, singleton_cols = c("trainer")) {
     })
   }
 
-  # We also should remove one layer of nesting from lags, but only if they're a list of length 1.
-  params_list %<>% map(function(x) {
-    if (!is.null(x$lags) && length(x$lags) == 1) {
-      x$lags <- x$lags[[1]]
-    }
-    x
-  })
+  # Some columns need to be converted to symbols.
+  get_cols <- get_cols[get_cols %in% names(params_list[[1]])]
+  if (length(get_cols) > 0) {
+    params_list %<>% lapply(function(x) {
+      for (col in get_cols) {
+        x[[col]] <- get(x[[col]])
+      }
+      x
+    })
+  }
 
   return(params_list)
 }
@@ -371,7 +373,7 @@ get_recent_targets_errors <- function(recent_minutes = 60) {
   }
 
   other_errors <- targets::tar_meta() %>%
-    filter(time > Sys.time() - days(recent_days), !is.na(error)) %>%
+    filter(time > Sys.time() - minutes(recent_minutes), !is.na(error)) %>%
     arrange(desc(time)) %>%
     distinct(error, .keep_all = TRUE) %>%
     select(time, name, error)
@@ -388,5 +390,3 @@ get_recent_targets_errors <- function(recent_minutes = 60) {
     }
   }
 }
-# Alias
-grte <- get_recent_targets_errors

scripts/covid_hosp_explore.R

@@ -27,8 +27,8 @@ forecast_dates <- forecast_dates[1:10]
 # Human-readable object to be used for inspecting the forecasters in the pipeline.
 forecaster_parameter_combinations <- rlang::list2(
   scaled_pop_main = tidyr::expand_grid(
-    forecaster = list(scaled_pop),
-    trainer = list(linreg, quantreg),
+    forecaster = "scaled_pop",
+    trainer = list("linreg", "quantreg"),
     lags = list(
       c(0, 7),
       c(0, 7, 14),
@@ -39,13 +39,13 @@ forecaster_parameter_combinations <- rlang::list2(
     n_training = Inf
   ),
   flatline_forecaster = tidyr::expand_grid(
-    forecaster = list(flatline_fc),
+    forecaster = "flatline_fc",
   ),
   # using exogenous variables
   scaled_pop_exogenous = bind_rows(
     expand_grid(
-      forecaster = list(scaled_pop),
-      trainer = list(quantreg),
+      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_4_bronchitis", "google_symptoms", "nwss", "nwss_region"),
       lags = list2(
@@ -68,8 +68,8 @@ forecaster_parameter_combinations <- rlang::list2(
       drop_non_seasons = FALSE,
     ),
     expand_grid(
-      forecaster = list(scaled_pop),
-      trainer = list(quantreg),
+      forecaster = "scaled_pop",
+      trainer = "quantreg",
       extra_sources = list2(
         ## c("dr_visits", "google_symptoms"),
         ## c("dr_visits", "nssp"),
@@ -99,8 +99,8 @@ forecaster_parameter_combinations <- rlang::list2(
       drop_non_seasons = FALSE,
     ),
     expand_grid(
-      forecaster = list(scaled_pop),
-      trainer = list(quantreg),
+      forecaster = "scaled_pop",
+      trainer = "quantreg",
       extra_sources = list2(
         c("nssp", "google_symptoms", "nwss", "nwss_region"),
       ),
@@ -131,8 +131,8 @@ forecaster_parameter_combinations <- rlang::list2(
     )
   ),
   scaled_pop_season = tidyr::expand_grid(
-    forecaster = list(scaled_pop_seasonal),
-    trainer = list(quantreg),
+    forecaster = "scaled_pop_seasonal",
+    trainer = "quantreg",
     lags = list(
       c(0, 7, 14, 21),
       c(0, 7)
@@ -144,7 +144,7 @@ forecaster_parameter_combinations <- rlang::list2(
 ) %>%
   map(function(x) {
     if (dummy_mode) {
-      x$forecaster <- list(dummy_forecaster)
+      x$forecaster <- "dummy_forecaster"
     }
     x
   }) %>%
@@ -193,17 +193,21 @@ get_partially_applied_forecaster <- function(id) {
       !!!params_list[[id]],
       .homonyms = "last"
     )
-    rlang::inject(forecaster_functions_list[[id]](epi_data = epi_data, !!!forecaster_args))
+    # This uses string lookup to get the function.
+    forecaster_fn <- get(forecaster_functions_list[[id]])
+    rlang::inject(forecaster_fn(epi_data = epi_data, !!!forecaster_args))
   }
 }
 
 # ================================ TARGETS =================================
 # ================================ PARAMETERS TARGETS ======================
 parameter_targets <- list2(
-  # tar_target(name = forecaster_names, command = forecaster_functions_list %>% names()),
   tar_target(name = aheads, command = c(0, 7, 14, 21)),
+  tar_target(name = ref_time_values, command = forecast_dates),
+  # This is used for parameter lookup.
+  tar_target(name = forecaster_parameter_grid, command = forecaster_parameter_combinations),
+  # This is used for generating notebooks.
   tar_target(name = forecaster_families, command = forecaster_parameter_combinations %>% names()),
-  tar_target(name = ref_time_values, command = forecast_dates)
 )
 # ================================ DATA TARGETS ==============================
 data_targets <- list2(