Figure 2 rough draft components (#100)

_targets_eval_postprocessing.R

@@ -301,6 +301,10 @@ head_to_head_targets <- list(
   # Get the full set of quantiles, filtered down to only states and
   # forecast dates with sufficient wastewater for both ww model and hosp only
   # model. Then join the convergence df
+  tar_target(
+    name = last_hosp_data_date_map,
+    command = get_last_hosp_data_date_map(all_hosp_model_quantiles)
+  ),
   tar_target(
     name = hosp_quantiles_filtered,
     command = dplyr::bind_rows(
@@ -320,13 +324,18 @@ head_to_head_targets <- list(
           "forecast_date"
         )
       ) |>
+      dplyr::left_join(
+        last_hosp_data_date_map,
+        by = c("location", "forecast_date")
+      ) |>
       dplyr::left_join(
         epidemic_phases,
         by = c(
           "location" = "state_abbr",
           "date" = "reference_date"
         )
-      )
+      ) |>
+      add_horizons()
   ),
   # Do the same thing for the sampled scores, combining ww and hosp under
   # the status quo scenario, filtering to the locations and forecast dates
@@ -349,13 +358,18 @@ head_to_head_targets <- list(
           "forecast_date"
         )
       ) |>
+      dplyr::left_join(
+        last_hosp_data_date_map,
+        by = c("location", "forecast_date")
+      ) |>
       dplyr::left_join(
         epidemic_phases,
         by = c(
           "location" = "state_abbr",
           "date" = "reference_date"
         )
-      )
+      ) |>
+      add_horizons()
   ),
   # Repeat for the quantile-based scores
   tar_target(
@@ -368,23 +382,129 @@ head_to_head_targets <- list(
       dplyr::left_join(table_of_loc_dates_w_ww,
         by = c("location", "forecast_date")
       ) |>
-      dplyr::filter(
-        isTRUE(ww_sufficient)
-      ) |>
+      dplyr::filter(ww_sufficient) |>
       dplyr::left_join(
         convergence_df,
         by = c(
           "location",
           "forecast_date"
         )
       ) |>
+      dplyr::left_join(
+        last_hosp_data_date_map,
+        by = c("location", "forecast_date")
+      ) |>
       dplyr::left_join(
         epidemic_phases,
         by = c(
           "location" = "state_abbr",
           "date" = "reference_date"
         )
-      )
+      ) |>
+      add_horizons()
+  )
+)
+
+# Manuscript figures------------------------------------------------
+# Note that these are just the components of the figures, not the full
+# ggarranged, properly formatted figures, and currently require
+# specification for the figure components that are examples.
+manuscript_figures <- list(
+  tar_target(
+    name = fig2_hosp_t_1,
+    command = make_fig2_hosp_t(
+      hosp_quantiles_filtered,
+      loc_to_plot = c("MA"),
+      date_to_plot = "2024-01-15"
+    )
+  ),
+  tar_target(
+    name = fig2_hosp_t_2,
+    command = make_fig2_hosp_t(
+      hosp_quantiles_filtered,
+      loc_to_plot = c("AL"),
+      date_to_plot = "2024-01-15"
+    )
+  ),
+  tar_target(
+    name = fig2_hosp_t_3,
+    command = make_fig2_hosp_t(
+      hosp_quantiles_filtered,
+      loc_to_plot = c("WA"),
+      date_to_plot = "2024-01-15"
+    )
+  ),
+  tar_target(
+    name = fig2_ct_1,
+    command = make_fig2_ct(
+      all_ww_quantiles_sq,
+      loc_to_plot = "MA",
+      date_to_plot = "2024-01-15"
+    )
+  ),
+  tar_target(
+    name = fig2_ct_2,
+    command = make_fig2_ct(
+      all_ww_quantiles_sq,
+      loc_to_plot = "AL",
+      date_to_plot = "2024-01-15"
+    )
+  ),
+  tar_target(
+    name = fig2_ct_3,
+    command = make_fig2_ct(
+      all_ww_quantiles_sq,
+      loc_to_plot = "WA",
+      date_to_plot = "2024-01-15"
+    )
+  ),
+  tar_target(
+    name = fig2_forecast_comparison_nowcast1,
+    command = make_hosp_forecast_comp_fig(
+      hosp_quantiles_filtered,
+      loc_to_plot = "MA",
+      horizon_to_plot = "nowcast"
+    )
+  ),
+  tar_target(
+    name = fig2_forecast_comparison_1wk1,
+    command = make_hosp_forecast_comp_fig(
+      hosp_quantiles_filtered,
+      loc_to_plot = "MA",
+      horizon_to_plot = "1 wk"
+    )
+  ),
+  tar_target(
+    name = fig2_forecast_comparison_4wks1,
+    command = make_hosp_forecast_comp_fig(
+      hosp_quantiles_filtered,
+      loc_to_plot = "MA",
+      horizon_to_plot = "4 wks"
+    )
+  ),
+  tar_target(
+    name = fig2_crps_underlay_nowcast1,
+    command = make_crps_underlay_fig(
+      scores_filtered,
+      loc_to_plot = "MA",
+      horizon_to_plot = "nowcast"
+    )
+  ),
+  tar_target(
+    name = fig2_crps_underlay_1wk1,
+    command = make_crps_underlay_fig(
+      scores_filtered,
+      loc_to_plot = "MA",
+      horizon_to_plot = "1 wk"
+    )
+  ),
+  tar_target(
+    name = fig2_crps_underlay_4wks1,
+    command = make_crps_underlay_fig(
+      scores_filtered,
+      loc_to_plot = "MA",
+      horizon_to_plot = "4 wks"
+    )
   )
 )
 
@@ -783,11 +903,12 @@ hub_comparison_plots <- list(
 
 
 
-# Run the targets pipeline
+# Run the targets pipeline----------------------------------------------------
 list(
   upstream_targets,
   combined_targets,
   head_to_head_targets,
+  manuscript_figures,
   scenario_targets,
   hub_targets,
   hub_comparison_plots

wweval/NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(add_horizons)
 export(add_time_indexing)
 export(clean_ww_data)
 export(combine_outputs)
@@ -26,6 +27,7 @@ export(get_hosp_values)
 export(get_input_hosp_data)
 export(get_input_ww_data)
 export(get_last_hosp_data_date)
+export(get_last_hosp_data_date_map)
 export(get_model_draws_w_data)
 export(get_model_path)
 export(get_n_states_improved_plot)
@@ -49,7 +51,11 @@ export(get_ww_data_indices)
 export(get_ww_data_sizes)
 export(get_ww_values)
 export(make_baseline_score_table)
+export(make_crps_underlay_fig)
 export(make_df)
+export(make_fig2_ct)
+export(make_fig2_hosp_t)
+export(make_hosp_forecast_comp_fig)
 export(sample_model)
 export(save_table)
 export(score_hub_submissions)

wweval/R/add_horizons.R

@@ -0,0 +1,59 @@
+#' Add columns indicating the horizon to the scores
+#'
+#' @description
+#' This function takes in a tibble of scores on the nowcasts/forecasts
+#' containing the columns `date`, `forecast_date`, and `last_hosp_data_date`,
+#' and adds the following columns: `horizon_days` (an integer) and
+#'  `horizon` (a string to be used for categorical grouping of horizons)
+#'
+#'
+#' @param df A tibble containing either forecasts or scores (or both)
+#' and the following required columns: `date`,`forecast_date`,
+#' `last_hosp_data_date`
+#'
+#' @return a tibble containing the same columns as `df` plus
+#' `horizon_days` and `horizon`
+#' @export
+add_horizons <- function(df) {
+  df_w_horizons <- df |>
+    dplyr::mutate(
+      horizon_days = as.numeric(date - forecast_date)
+    ) |>
+    dplyr::mutate(
+      horizon = dplyr::case_when(
+        date <= last_hosp_data_date & horizon_days <= 0 ~ "calibration",
+        date > last_hosp_data_date & horizon_days <= 0 ~ "nowcast",
+        horizon_days > 0 & horizon_days <= 7 ~ "1 wk",
+        horizon_days > 7 & horizon_days <= 14 ~ "2 wks",
+        horizon_days > 14 & horizon_days <= 21 ~ "3 wks",
+        horizon_days > 21 & horizon_days <= 28 ~ "4 wks",
+        TRUE ~ NA_character_
+      )
+    )
+
+  return(df_w_horizons)
+}
+
+#' Get a map of the location, forecast date, and last hospital admissions data
+#' date
+#'
+#' @param df A tibble containing the following columns: `forecast_date`,
+#' `location`,`date`, `calib_data`.
+#' `calib_data` should be `NA` for any dates for which there was 
+#'  not hospital admissions data to fit to. 
+#'
+#' @return A tibble with that maps the unique combinations of `location` and
+#' `forecast` date to the last hospital admissions data date
+#' `last_hosp_data_date`
+#' @export
+get_last_hosp_data_date_map <- function(df) {
+  map <- df |>
+    dplyr::group_by(forecast_date, location) |>
+    dplyr::filter(!is.na(calib_data)) |>
+    dplyr::summarise(
+      last_hosp_data_date = max(date)
+    ) |>
+    dplyr::ungroup()
+
+  return(map)
+}