make weekly data from generate simulated data vignette

CDCgov · Dec 16, 2024 · 448719a · 448719a
1 parent 5caa395
commit 448719a
Show file tree

Hide file tree

Showing 16 changed files with 81 additions and 4 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -101,7 +101,8 @@ Imports:
     scales,
     ggplot2,
     posterior,
-    checkmate
+    checkmate,
+    zoo
 Remotes:
     stan-dev/cmdstanr
 VignetteBuilder:

diff --git a/R/generate_simulated_data.R b/R/generate_simulated_data.R
@@ -103,7 +103,7 @@ generate_simulated_data <- function(r_in_weeks = # nolint
                                     nt = 9,
                                     forecast_horizon = 28,
                                     sim_start_date = lubridate::ymd(
-                                      "2023-09-01"
+                                      "2023-09-03"
                                     ),
                                     hosp_wday_effect = c(
                                       0.95, 1.01, 1.02,
@@ -512,6 +512,11 @@ generate_simulated_data <- function(r_in_weeks = # nolint
     date_df = date_df
   )
 
+  weekly_hosp_data <- make_weekly_data(
+    hosp_data = hosp_data,
+    day_of_week_to_sum = "Saturday"
+  )
+
   hosp_data_eval <- format_hosp_data(
     pred_obs_hosp = pred_obs_hosp,
     dur_obs = (ot + ht),
@@ -522,6 +527,12 @@ generate_simulated_data <- function(r_in_weeks = # nolint
       "daily_hosp_admits_for_eval" = "daily_hosp_admits"
     )
 
+  weekly_hosp_data_eval <- make_weekly_data(
+    hosp_data = hosp_data_eval,
+    count_col_name = "daily_hosp_admits_for_eval",
+    day_of_week_to_sum = "Saturday"
+  )
+
   # Make a subpopulation level hospital admissions data
   # For now this will only be used for evaluation, eventually, can add
   # feature to use this in calibration
@@ -571,6 +582,8 @@ generate_simulated_data <- function(r_in_weeks = # nolint
     ww_data_eval = ww_data_eval,
     hosp_data = hosp_data,
     hosp_data_eval = hosp_data_eval,
+    weekly_hosp_data = weekly_hosp_data,
+    weekly_hosp_data_eval = weekly_hosp_data_eval,
     subpop_hosp_data = subpop_hosp_data,
     subpop_hosp_data_eval = subpop_hosp_data_eval,
     true_global_rt = true_rt

diff --git a/R/make_weekly_data.R b/R/make_weekly_data.R
@@ -0,0 +1,38 @@
+#' Make daily data into weekly data
+#' This is an internal function used to generate simulated weekly data
+#'
+#' @param hosp_data A tibble containing daily hospital admissions data,
+#' expects the following columns: "date", and whatever is specified in
+#' `count_col_name`
+#' @param count_col_name A character string indicating the name of the column
+#' with the daily counts, default is `"daily_hosp_admits"`
+#' @param day_of_week_to_sum A character string indicating what day of the
+#' week to assign the past 7 days of hospital admissions to. Must be full
+#' weekday name with first letter in uppercase. Default is Saturday
+#'
+#' @return A dataframe with weekly hospital admissions data, assigned to
+#' the day of the week to sum
+make_weekly_data <- function(hosp_data,
+                             count_col_name = "daily_hosp_admits",
+                             day_of_week_to_sum = "Saturday") {
+  hosp_data_w_wday <- hosp_data |>
+    dplyr::mutate(
+      day_of_week = lubridate::wday(.data$date,
+        week_start = 1,
+        label = TRUE,
+        abbr = FALSE
+      ),
+      day_of_week_numeric = lubridate::wday(.data$date),
+      weekly_hosp_admits = zoo::rollsum(.data[[count_col_name]],
+        k = 7,
+        na.pad = TRUE,
+        align = "right"
+      )
+    ) |>
+    dplyr::filter(day_of_week == {{ day_of_week_to_sum }})
+
+  weekly_hosp_data <- hosp_data_w_wday |>
+    dplyr::select(date, weekly_hosp_admits, state_pop)
+
+  return(weekly_hosp_data)
+}
diff --git a/data-raw/vignette_data.R b/data-raw/vignette_data.R
@@ -6,12 +6,16 @@ ww_data_eval <- simulated_data$ww_data_eval
 hosp_data <- hosp_data_from_sim |>
   dplyr::mutate("location" = "example state")
 hosp_data_eval <- simulated_data$hosp_data_eval
+weekly_hosp_data <- simulated_data$weekly_hosp_data
+weekly_hosp_data_eval <- simulated_data$weekly_hosp_data_eval
 subpop_hosp_data <- simulated_data$subpop_hosp_data
 subpop_hosp_data_eval <- simulated_data$subpop_hosp_data_eval
 true_global_rt <- simulated_data$true_global_rt
 
 usethis::use_data(hosp_data, overwrite = TRUE)
 usethis::use_data(hosp_data_eval, overwrite = TRUE)
+usethis::use_data(weekly_hosp_data, overwrite = TRUE)
+usethis::use_data(weekly_hosp_data_eval, overwrite = TRUE)
 usethis::use_data(ww_data, overwrite = TRUE)
 usethis::use_data(ww_data_eval, overwrite = TRUE)
 usethis::use_data(subpop_hosp_data, overwrite = TRUE)

diff --git a/data/hosp_data.rda b/data/hosp_data.rda
diff --git a/data/hosp_data_eval.rda b/data/hosp_data_eval.rda
diff --git a/data/subpop_hosp_data.rda b/data/subpop_hosp_data.rda
diff --git a/data/subpop_hosp_data_eval.rda b/data/subpop_hosp_data_eval.rda
diff --git a/data/true_global_rt.rda b/data/true_global_rt.rda
diff --git a/data/weekly_hosp_data.rda b/data/weekly_hosp_data.rda
diff --git a/data/weekly_hosp_data_eval.rda b/data/weekly_hosp_data_eval.rda
diff --git a/data/ww_data.rda b/data/ww_data.rda
diff --git a/data/ww_data_eval.rda b/data/ww_data_eval.rda
diff --git a/man/generate_simulated_data.Rd b/man/generate_simulated_data.Rd
diff --git a/man/make_weekly_data.Rd b/man/make_weekly_data.Rd
diff --git a/scratch/sim_data_script.R b/scratch/sim_data_script.R
@@ -17,7 +17,7 @@ lab <- c(1, 2, 3, 3, 3)
 ot <- 90
 nt <- 9
 forecast_horizon <- 28
-sim_start_date <- lubridate::ymd("2023-09-01")
+sim_start_date <- lubridate::ymd("2023-09-03")
 hosp_wday_effect <- c(
   0.95, 1.01, 1.02,
   1.02, 1.01, 1,