55 estimate coverage

NAMESPACE

@@ -6,6 +6,7 @@ importFrom(cowplot,background_grid)
 importFrom(cowplot,theme_half_open)
 importFrom(data.table,as.data.table)
 importFrom(data.table,setattr)
+importFrom(dplyr,bind_rows)
 importFrom(dplyr,case_when)
 importFrom(dplyr,filter)
 importFrom(dplyr,group_by)

R/compute_coverage.R

@@ -8,40 +8,52 @@
 #'
 #' @returns Data frame with coverage for 50% and 95% intervals by model,
 #'   location, and nowcast_date
-#' @importFrom dplyr filter group_by summarise mutate
+#' @importFrom dplyr filter group_by summarise mutate bind_rows select
 #' @importFrom scoringutils as_forecast_quantile score get_coverage
 #' @autoglobal
 compute_coverage <- function(df_prepared, locs, nowcast_dates,
                              intervals = c(50, 95)) {
-  # Filter to specific locations and nowcast dates
-  df_to_score <- filter(
-    df_prepared,
-    location %in% locs,
-    nowcast_date %in% nowcast_dates
-  )
+  # Process by location to reduce memory usage
+  coverage_list <- lapply(locs, function(loc) {
+    # Filter to specific location and nowcast dates
+    df_to_score <- filter(
+      df_prepared,
+      location == loc,
+      nowcast_date %in% nowcast_dates
+    )
+
+    # Convert to scoringutils forecast object
+    forecast_obj <- scoringutils::as_forecast_quantile(
+      df_to_score,
+      forecast_unit = c(
+        "model_id", "location", "nowcast_date",
+        "target_date", "clade"
+      ),
+      observed = "observed",
+      predicted = "predicted",
+      quantile_level = "quantile_level"
+    )
 
-  # Convert to scoringutils forecast object
-  forecast_obj <- scoringutils::as_forecast_quantile(
-    df_to_score,
-    forecast_unit = c(
-      "model_id", "location", "nowcast_date",
-      "target_date", "clade"
-    ),
-    observed = "observed",
-    predicted = "predicted",
-    quantile_level = "quantile_level"
-  )
-  all_coverage <- scoringutils::get_coverage(
-    forecast_obj,
-    by = c(
-      "location", "nowcast_date", "target_date",
-      "model_id", "clade"
+    # Get coverage at target_date level (needed for accurate computation)
+    all_coverage <- scoringutils::get_coverage(
+      forecast_obj,
+      by = c(
+        "location", "nowcast_date", "target_date",
+        "model_id", "clade"
+      )
     )
-  )
-  coverage <- filter(
-    all_coverage,
-    interval_range %in% c(intervals)
-  )
+
+    # Immediately filter to desired intervals and select only needed columns
+    coverage_loc <- all_coverage |>
+      filter(interval_range %in% c(intervals)) |>
+      select(location, nowcast_date, model_id, clade, interval_range,
+             interval_coverage, target_date)
+
+    return(coverage_loc)
+  })
+
+  # Combine all locations
+  coverage <- bind_rows(coverage_list)
 
   return(coverage)
 }

R/globals.R

@@ -58,6 +58,10 @@ utils::globalVariables(c(
   "location", # <compute_coverage>
   "nowcast_date", # <compute_coverage>
   "interval_range", # <compute_coverage>
+  "model_id", # <compute_coverage>
+  "clade", # <compute_coverage>
+  "interval_coverage", # <compute_coverage>
+  "target_date", # <compute_coverage>
   "location", # <extract_nowcasts>
   "nowcast_date", # <extract_nowcasts>
   "location", # <get_oracle_output>

targets/clean_data_targets.R

@@ -42,6 +42,17 @@ clean_data_targets <- list(
       type = "evaluation"
     )
   ),
+  tar_target(
+    name = clean_variant_data_for_eval_all_nowcasts,
+    command = get_clean_variant_data(
+      variant_data_eval_all,
+      clade_list,
+      location_data,
+      nowcast_dates,
+      seq_col_name = "oracle_value",
+      type = "evaluation"
+    )
+  ),
   tar_target(
     name = clean_variant_data_eval_all,
     command = get_clean_variant_data(

targets/fig_submission_heatmaps_targets.R

@@ -3,7 +3,7 @@ fig_submission_heatmaps_targets <- list(
   tar_target(
     name = submission_presence_data,
     command = prepare_submission_data(
-      all_model_outputs_for_heatmap,
+      all_model_outputs,
       location_data,
       nowcast_dates
     )

targets/load_data_targets.R

@@ -108,9 +108,9 @@ load_data_targets <- list(
       bucket_name = nowcast_bucket_name
     )
   ),
-  # All model outputs for heatmap (all dates and locations)
+  # All model outputs
   tar_target(
-    name = all_model_outputs_for_heatmap,
+    name = all_model_outputs,
     command = extract_nowcasts(
       nowcast_dates = nowcast_dates,
       states = location_data$abbreviation,

targets/pred_int_targets.R

@@ -12,5 +12,12 @@ pred_int_targets <- list(
       model_pred_prop = model_outputs_mult_nowcasts,
       eval_seq = clean_variant_data_for_eval_mult_nowcasts
     )
+  ),
+  tar_target(
+    name = df_quantiled_nowcasts,
+    command = get_pred_int(
+      model_pred_prop = all_model_outputs,
+      eval_seq = clean_variant_data_for_eval_all_nowcasts
+    )
   )
 )