add enw_simulate_missing_reference to package

epinowcast · seabbs · Sep 20, 2022 · Jul 31, 2022 · Jul 31, 2022 · Jul 31, 2022
commit bd0a430730c03925ff451589306d6720d43fa358
diff --git a/R/simulate.R b/R/simulate.R
@@ -0,0 +1,57 @@
+#' Simulate observations with a missing reference date.
+#'
+#' A simple binomial simulator of missing data by reference date using simulated
+#' or observed data as an input. This function may be used to validate missing
+#' data models, as part of examples and case studies, or to explore the
+#' implications of missing data for your use case.
+#'
+#' @param proportion Numeric, the proportion of observations that are missing a
+#' reference date, indexed by reference date. Currently only a fixed proportion
+#' are supported and this defaults to 0.2.
+#'
+#' @return A `data.table` of the same format as the input but with a simulated
+#' proportion of observations now having a missing reference date.
+#'
+#' @inheritParams enw_cumulative_to_incidence
+#' @family simulate
+#' @examples
+#' # Load and filter germany hospitalisations
+#' nat_germany_hosp <- subset(
+#'   germany_covid19_hosp, location == "DE" & age_group %in% "00+"
+#' )
+#' nat_germany_hosp <- enw_filter_report_dates(
+#'   nat_germany_hosp,
+#'   latest_date = "2021-08-01"
+#' )
+#'
+#' # Make sure observations are complete
+#' nat_germany_hosp <- enw_complete_dates(
+#'   nat_germany_hosp,
+#'   by = c("location", "age_group"), missing_reference = FALSE
+#' )
+#'
+#' # Simulate
+#' enw_simulate_missing_reference(
+#'   nat_germany_hosp,
+#'   proportion = 0.35, by = c("location", "age_group")
+#' )
+enw_simulate_missing_reference <- function(obs, proportion = 0.2, by = c()) {
+  obs <- enw_cumulative_to_incidence(obs, by = by)
+
+  obs[, missing := purrr::map2_dbl(
+    new_confirm, proportion, ~ rbinom(1, .x, .y)
+  )]
+  obs[, new_confirm := new_confirm - missing]
+
+  complete_ref <- enw_incidence_to_cumulative(obs, by = by)
+  complete_ref[, c("new_confirm", "delay", "missing") := NULL]
+
+  missing_ref <- obs[, .(confirm = sum(missing)),
+    by = c(by, "report_date")
+  ]
+  missing_ref[, reference_date := as.IDate(NA)]
+
+  obs <- rbind(complete_ref, missing_ref, use.names = TRUE)
+  data.table::setkeyv(obs, c(by, "reference_date", "report_date"))
+  return(obs[])
+}
diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -68,6 +68,10 @@ reference:
     desc: Package datasets used in examples and by users to explore the package functionality.
     contents:
       - has_concept("data")
+  - title: Simulate Datasets
+    desc: Tools for simulating datasets
+    contents:
+      - has_concept("simulate")
   - title: Check inputs
     desc: Functions to check the structure of user inputs.
     contents:

diff --git a/inst/examples/germany_missing.R b/inst/examples/germany_missing.R
@@ -11,7 +11,7 @@ options(mc.cores = 4)
 nat_germany_hosp <- germany_covid19_hosp[location == "DE"][age_group %in% "00+"]
 nat_germany_hosp <- enw_filter_report_dates(
   nat_germany_hosp,
-  latest_date = "2021-10-01"
+  latest_date = "2021-08-01"
 )
 
 # Make sure observations are complete
@@ -24,29 +24,6 @@ nat_germany_hosp <- enw_complete_dates(
 # Set proportion missing at 35%
 prop_miss <- 0.35
 
-# Prototypes for simulating missing data - likely to be implemented in 0.2.0
-enw_simulate_missing_reference <- function(obs, proportion = 0.2, by = c()) {
-  obs <- check_dates(obs)
-  obs <- enw_cumulative_to_incidence(obs, by = by)
-
-  obs[, missing := purrr::map2_dbl(
-    new_confirm, proportion, ~ rbinom(1, .x, .y)
-  )]
-  obs[, new_confirm := new_confirm - missing]
-
-  complete_ref <- enw_incidence_to_cumulative(obs, by = by)
-  complete_ref[, c("new_confirm", "delay", "missing") := NULL]
-
-  missing_ref <- obs[, .(confirm = sum(missing)),
-    by = c(by, "report_date")
-  ]
-  missing_ref[, reference_date := as.IDate(NA)]
-
-  obs <- rbind(complete_ref, missing_ref, use.names = TRUE)
-  obs[order(reference_date, report_date)]
-  return(obs[])
-}
-
 # Simulate using this function
 nat_germany_hosp <- enw_simulate_missing_reference(
   nat_germany_hosp,
@@ -67,7 +44,7 @@ retro_nat_germany <- enw_filter_reference_dates(
 latest_obs <- enw_latest_data(nat_germany_hosp)
 latest_obs <- enw_filter_reference_dates(
   latest_obs,
-  remove_days = 40, include_days = 20
+  remove_days = 40, include_days = 60
 )
 
 # Preprocess observations (note this maximum delay is likely too short)
@@ -81,14 +58,14 @@ model <- enw_model(threads = FALSE)
 # dates and produce a nowcast
 # Note that we have reduced samples for this example to reduce runtimes
 nowcast <- epinowcast(pobs,
-  missing = enw_missing(~week, data = pobs),
+  missing = enw_missing(~ (1 | week), data = pobs),
   report = enw_report(~ (1 | day_of_week), data = pobs),
   fit = enw_fit_opts(
     save_warmup = FALSE, pp = TRUE,
     chains = 4, iter_warmup = 500, iter_sampling = 500,
     likelihood_aggregation = "groups", adapt_delta = 0.9
   ),
-  obs = enw_obs(family = "negbin", data = pobs),
+  obs = enw_obs(family = "poisson", data = pobs),
   model = model
 )
 

diff --git a/man/enw_simulate_missing_reference.Rd b/man/enw_simulate_missing_reference.Rd
diff --git a/man/roxygen/meta.R b/man/roxygen/meta.R
@@ -11,6 +11,7 @@ list( # nolint
     nowcast = "Functions used for nowcasting", # nolint
     generatedata = "Functions to generate simulated data",
     scenarios = "Functions to define and create scenarios",
+    simulate = "Tools for data simulation",
     data = "Package data sets",
     check = "Functions used for checking inputs",
     utils = "Utility functions"