feat: add sort_by_quantiles

Author: dshemetov

R/forecasters/ensemble_linear_climate.R

@@ -52,10 +52,10 @@ ensemble_linear_climate <- function(forecasts,
       )
     full_weights <- full_weights %>%
       left_join(
-      other_weights,
-      by = join_by(forecaster),
-      relationship = "many-to-many"
-    ) %>%
+        other_weights,
+        by = join_by(forecaster),
+        relationship = "many-to-many"
+      ) %>%
       mutate(weight = weight.x * weight.y) %>%
       select(geo_value, ahead, forecaster, quantile, weight)
     grouping_cols <- c("geo_value", "ahead", "quantile")
@@ -82,13 +82,8 @@ ensemble_linear_climate <- function(forecasts,
     ) %>%
     mutate(value = weight * value) %>%
     group_by(geo_value, forecast_date, target_end_date, quantile) %>%
-    summarize(value = sum(value, na.rm = TRUE), .groups = "drop")
-  # sort the quantiles
-  weighted_forecasts <-
-    weighted_forecasts %>%
-    group_by(geo_value, target_end_date, forecast_date) %>%
-    arrange(geo_value, target_end_date, forecast_date, quantile) %>%
-    mutate(value = sort(value))
+    summarize(value = sum(value, na.rm = TRUE), .groups = "drop") %>%
+    sort_by_quantile()
   return(weighted_forecasts)
 }
 

R/utils.R

@@ -157,13 +157,15 @@ data_substitutions <- function(dataset, disease, forecast_generation_date) {
   disease <- "flu"
   forecast_generation_date <- as.Date("2025-01-08")
   substitutions <- readr::read_csv(
-                          glue::glue("{disease}_data_substitutions.csv"),
-                          comment = "#",
-                          show_col_types = FALSE) %>%
+    glue::glue("{disease}_data_substitutions.csv"),
+    comment = "#",
+    show_col_types = FALSE
+  ) %>%
     filter(forecast_date == forecast_generation_date) %>%
     select(-forecast_date) %>%
     rename(new_value = value)
-  dataset %>% left_join(substitutions) %>%
+  dataset %>%
+    left_join(substitutions) %>%
     mutate(value = ifelse(!is.na(new_value), new_value, value)) %>%
     select(-new_value)
 }
@@ -331,3 +333,13 @@ update_site <- function() {
   # Convert the markdown file to HTML
   system("pandoc reports/report.md -s -o reports/index.html --css=reports/style.css --mathjax='https://cdn.jsdelivr.net/npm/mathjax@3/es5/tex-mml-chtml.js' --metadata pagetitle='Delphi Reports'")
 }
+
+#' Ensure that forecast values are monotically increasing
+#' in quantile order.
+sort_by_quantile <- function(forecasts) {
+  forecasts %>%
+    arrange(geo_value, target_end_date, forecast_date, quantile) %>%
+    group_by(geo_value, forecast_date, target_end_date) %>%
+    mutate(value = sort(value)) %>%
+    ungroup()
+}

scripts/flu_hosp_prod.R

@@ -175,22 +175,16 @@ rlang::list2(
     tar_target(
       name = ensemble_mixture_res,
       command = {
-        ensembled <-
-          forecast_res %>%
+        forecast_res %>%
           # Apply the ahead-by-quantile weighting scheme
           ensemble_linear_climate(aheads, other_weights = geo_forecasters_weights) %>%
           filter(geo_value %nin% geo_exclusions) %>%
           ungroup() %>%
           # Ensemble with windowed_seasonal
           bind_rows(forecast_res %>% filter(forecaster == "windowed_seasonal")) %>%
           group_by(geo_value, forecast_date, target_end_date, quantile) %>%
-          summarize(value = mean(value, na.rm = TRUE), .groups = "drop")
-        # filter(geo_value != "us", geo_value !="usa")
-        sorted <- ensembled %>%
-          group_by(geo_value, forecast_date, target_end_date) %>%
-          mutate(value = sort(value)) %>%
-          ungroup()
-        sorted
+          summarize(value = mean(value, na.rm = TRUE), .groups = "drop") %>%
+          sort_by_quantile()
       },
     ),
     tar_target(