Issue 73: as, is, and validate functions for latent_individual (#125)

* Notes on implementing this * as_latent_individual will be a generic * Basic version using as_latent_individual * Add is_latent_individual function * Run document * Use inherits * Start adding checkmate assertions * Bug fix about int, and extend validate function to cover added columns * Rebase * Edits to pass tests and checks * Add test for error on wrong input * Fix rebase issue * Changes to pass document and build site * Add tests of as_latent_individual * Add tests for is and validate * Add partial matching test and is_latent_individual spoofing test (it accepts spoofs) * Fix lint * Add documentation to functions * Lint whitespace * Update R/latent_individual.R Co-authored-by: Katie Gostic (she/her) <[email protected]> * Remove unneeded paste0 call * Create assert_latent_individual_input helper function, and add lower checking * Can't have lower as a vector --------- Co-authored-by: Sam Abbott <[email protected]> Co-authored-by: Katie Gostic (she/her) <[email protected]>
epinowcast · Jul 11, 2024 · 4877714 · 4877714
1 parent 476c36e
commit 4877714
Show file tree

Hide file tree

Showing 25 changed files with 263 additions and 117 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,17 +1,17 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(as_latent_individual,data.frame)
 S3method(epidist,default)
 S3method(epidist_family,default)
 S3method(epidist_family,epidist_latent_individual)
 S3method(epidist_formula,default)
 S3method(epidist_formula,epidist_latent_individual)
-S3method(epidist_prepare,default)
-S3method(epidist_prepare,epidist_latent_individual)
 S3method(epidist_prior,default)
 S3method(epidist_prior,epidist_latent_individual)
 S3method(epidist_stancode,default)
 S3method(epidist_stancode,epidist_latent_individual)
 export(add_natural_scale_mean_sd)
+export(as_latent_individual)
 export(calculate_censor_delay)
 export(calculate_cohort_mean)
 export(calculate_truncated_means)
@@ -23,7 +23,6 @@ export(drop_zero)
 export(epidist)
 export(epidist_family)
 export(epidist_formula)
-export(epidist_prepare)
 export(epidist_prior)
 export(epidist_stan_chunk)
 export(epidist_stancode)
@@ -32,6 +31,7 @@ export(event_to_incidence)
 export(extract_lognormal_draws)
 export(filter_obs_by_obs_time)
 export(filter_obs_by_ptime)
+export(is_latent_individual)
 export(linelist_to_cases)
 export(linelist_to_counts)
 export(make_relative_to_truth)
@@ -53,10 +53,15 @@ export(simulate_secondary)
 export(simulate_uniform_cases)
 export(summarise_draws)
 export(summarise_variable)
+export(validate_latent_individual)
 import(brms)
 import(cmdstanr)
 import(data.table)
 import(ggplot2)
+importFrom(checkmate,assert_data_frame)
+importFrom(checkmate,assert_int)
+importFrom(checkmate,assert_names)
+importFrom(checkmate,assert_numeric)
 importFrom(posterior,as_draws_df)
 importFrom(stats,as.formula)
 importFrom(stats,ecdf)

diff --git a/R/defaults.R b/R/defaults.R
@@ -1,19 +1,3 @@
-#' Default method used when preparing data
-#'
-#' @param model Character string, model type to prepare to use.
-#' Supported options are "latent_individual".
-#' @param ... Additional arguments passed to model specific `epidist_prepare`
-#' functions
-#' @rdname epidist_prepare
-#' @method epidist_prepare default
-#' @family defaults
-#' @export
-epidist_prepare.default <- function(data, model, ...) {
-  model <- match.arg(model, choices = c("latent_individual"))
-  class(data) <- c(class(data), paste0("epidist_", model))
-  epidist_prepare(data, ...)
-}
-
 #' Default method for defining a model specific formula
 #'
 #' @inheritParams epidist_formula

diff --git a/R/generics.R b/R/generics.R
@@ -1,16 +1,6 @@
-#' Prepare data for modelling
-#'
-#' @param data A dataframe to be used for modelling.
-#' @rdname epidist_prepare
-#' @family generics
-#' @export
-epidist_prepare <- function(data, ...) {
-  UseMethod("epidist_prepare")
-}
-
 #' Define a model specific formula
 #'
-#' @inheritParams epidist_prepare
+#' @param data A dataframe to be used for modelling.
 #' @param ... Additional arguments for method.
 #' @family generics
 #' @export
@@ -20,7 +10,7 @@ epidist_formula <- function(data, ...) {
 
 #' Define model specific family
 #'
-#' @inheritParams epidist_prepare
+#' @inheritParams epidist_formula
 #' @param ... Additional arguments for method.
 #' @family generics
 #' @export
@@ -30,7 +20,7 @@ epidist_family <- function(data, ...) {
 
 #' Define model specific priors
 #'
-#' @inheritParams epidist_prepare
+#' @inheritParams epidist_formula
 #' @param ... Additional arguments for method.
 #' @rdname epidist_prior
 #' @family generics
@@ -41,7 +31,7 @@ epidist_prior <- function(data, ...) {
 
 #' Define model specific Stan code
 #'
-#' @inheritParams epidist_prepare
+#' @inheritParams epidist_formula
 #' @param ... Additional arguments for method.
 #' @rdname epidist_stancode
 #' @family generics
@@ -57,7 +47,7 @@ epidist_stancode <- function(data, ...) {
 #' @param prior ...
 #' @param fn Likely `brms::brm`. Also possible to be `brms::make_stancode` or
 #' `brms::make_standata`.
-#' @inheritParams epidist_prepare
+#' @inheritParams epidist_formula
 #' @param ... Additional arguments for method.
 #' @family generics
 #' @export

diff --git a/R/globals.R b/R/globals.R
@@ -17,18 +17,18 @@ utils::globalVariables(c(
   "value", # <make_relative_to_truth>
   "rel_value", # <make_relative_to_truth>
   "value", # <summarise_variable>
-  "id", # <epidist_prepare.epidist_latent_individual>
-  "obs_t", # <epidist_prepare.epidist_latent_individual>
-  "obs_at", # <epidist_prepare.epidist_latent_individual>
-  "ptime_lwr", # <epidist_prepare.epidist_latent_individual>
-  "pwindow_upr", # <epidist_prepare.epidist_latent_individual>
-  "stime_lwr", # <epidist_prepare.epidist_latent_individual>
-  "ptime_upr", # <epidist_prepare.epidist_latent_individual>
-  "stime_upr", # <epidist_prepare.epidist_latent_individual>
-  "woverlap", # <epidist_prepare.epidist_latent_individual>
-  "swindow_upr", # <epidist_prepare.epidist_latent_individual>
-  "delay_central", # <epidist_prepare.epidist_latent_individual>
-  "row_id", # <epidist_prepare.epidist_latent_individual>
+  "id", # <as_latent_individual.data.frame>
+  "obs_t", # <as_latent_individual.data.frame>
+  "obs_at", # <as_latent_individual.data.frame>
+  "ptime_lwr", # <as_latent_individual.data.frame>
+  "pwindow_upr", # <as_latent_individual.data.frame>
+  "stime_lwr", # <as_latent_individual.data.frame>
+  "ptime_upr", # <as_latent_individual.data.frame>
+  "stime_upr", # <as_latent_individual.data.frame>
+  "woverlap", # <as_latent_individual.data.frame>
+  "swindow_upr", # <as_latent_individual.data.frame>
+  "delay_central", # <as_latent_individual.data.frame>
+  "row_id", # <as_latent_individual.data.frame>
   "woverlap", # <epidist_stancode.epidist_latent_individual>
   "row_id", # <epidist_stancode.epidist_latent_individual>
   "ptime_daily", # <observe_process>

diff --git a/R/latent_individual.R b/R/latent_individual.R
@@ -1,8 +1,51 @@
-#' @method epidist_prepare epidist_latent_individual
+#' Prepare latent individual model
+#'
+#' @param data Input data to be used for modelling.
+#' @family latent_individual
+#' @export
+as_latent_individual <- function(data) {
+  UseMethod("as_latent_individual")
+}
+
+assert_latent_individual_input <- function(data) {
+  checkmate::assert_data_frame(data)
+  checkmate::assert_names(
+    names(data),
+    must.include = c("case", "ptime_lwr", "ptime_upr",
+                     "stime_lwr", "stime_upr", "obs_at")
+  )
+  checkmate::assert_integer(data$case, lower = 0)
+  checkmate::assert_numeric(data$ptime_lwr, lower = 0)
+  checkmate::assert_numeric(data$ptime_upr, lower = 0)
+  checkmate::assert_true(all(data$ptime_upr - data$ptime_lwr > 0))
+  checkmate::assert_numeric(data$stime_lwr, lower = 0)
+  checkmate::assert_numeric(data$stime_upr, lower = 0)
+  checkmate::assert_true(all(data$stime_upr - data$stime_lwr > 0))
+  checkmate::assert_numeric(data$obs_at, lower = 0)
+}
+
+#' Prepare latent individual model
+#'
+#' This function prepares data for use with the latent individual model. It does
+#' this by adding columns used in the model to the `data` object provided. To do
+#' this, the `data` must already have columns for the case number (integer),
+#' (positive, numeric) upper and lower bounds for the primary and secondary
+#' event times, as well as a (positive, numeric) time that observation takes
+#' place. The output of this function is a `epidist_latent_individual` class
+#' object, which may be passed to `epidist()` to perform inference for the
+#' model.
+#'
+#' @param data A `data.frame` or `data.table` containing line list data
+#' @rdname as_latent_individual
+#' @method as_latent_individual data.frame
 #' @family latent_individual
+#' @importFrom checkmate assert_data_frame assert_names assert_int
+#' assert_numeric
 #' @autoglobal
 #' @export
-epidist_prepare.epidist_latent_individual <- function(data, ...) {
+as_latent_individual.data.frame <- function(data) {
+  assert_latent_individual_input(data)
+  class(data) <- c(class(data), "epidist_latent_individual")
   data <- data.table::as.data.table(data)
   data[, id := seq_len(.N)]
   data[, obs_t := obs_at - ptime_lwr]
@@ -15,14 +58,55 @@ epidist_prepare.epidist_latent_individual <- function(data, ...) {
   data[, swindow_upr := stime_upr - stime_lwr]
   data[, delay_central := stime_lwr - ptime_lwr]
   data[, row_id := seq_len(.N)]
-
   if (nrow(data) > 1) {
     data <- data[, id := as.factor(id)]
   }
-
+  validate_latent_individual(data)
   return(data)
 }
 
+#' Validate latent individual model data
+#'
+#' This function checks whether the provided `data` object is suitable for
+#' running the latent individual model. As well as making sure that
+#' `is_latent_individual()` is true, it also checks that `data` is a
+#' `data.frame` with the correct columns.
+#'
+#' @param data A `data.frame` or `data.table` containing line list data
+#' @importFrom checkmate assert_data_frame assert_names assert_int
+#' assert_numeric
+#' @family latent_individual
+#' @export
+validate_latent_individual <- function(data) {
+  checkmate::assert_true(is_latent_individual(data))
+  assert_latent_individual_input(data)
+  checkmate::assert_names(
+    names(data),
+    must.include = c("case", "ptime_lwr", "ptime_upr",
+                     "stime_lwr", "stime_upr", "obs_at",
+                     "id", "obs_t", "pwindow_upr", "woverlap",
+                     "swindow_upr", "delay_central", "row_id")
+  )
+  if (nrow(data) > 1) {
+    checkmate::assert_factor(data$id)
+  }
+  checkmate::assert_numeric(data$obs_t, lower = 0)
+  checkmate::assert_numeric(data$pwindow_upr, lower = 0)
+  checkmate::assert_numeric(data$woverlap, lower = 0)
+  checkmate::assert_numeric(data$swindow_upr, lower = 0)
+  checkmate::assert_numeric(data$delay_central, lower = 0)
+  checkmate::assert_integer(data$row_id, lower = 0)
+}
+
+#' Check if data has the `epidist_latent_individual` class
+#'
+#' @param data A `data.frame` or `data.table` containing line list data
+#' @family latent_individual
+#' @export
+is_latent_individual <- function(data) {
+  inherits(data, "epidist_latent_individual")
+}
+
 #' Define a formula for the latent_individual model
 #'
 #' @param data ...
@@ -36,6 +120,7 @@ epidist_prepare.epidist_latent_individual <- function(data, ...) {
 #' @export
 epidist_formula.epidist_latent_individual <- function(data, delay_central = ~ 1,
                                                       sigma = ~ 1, ...) {
+  validate_latent_individual(data)
   if (!inherits(delay_central, "formula")) {
     cli::cli_abort("A valid formula for delay_central must be provided")
   }
@@ -67,6 +152,7 @@ epidist_formula.epidist_latent_individual <- function(data, delay_central = ~ 1,
 #' @export
 epidist_family.epidist_latent_individual <- function(data, family = "lognormal",
                                                      ...) {
+  validate_latent_individual(data)
   checkmate::assert_string(family)
 
   pdf_lookup <- rstan::lookup("pdf")
@@ -121,6 +207,8 @@ epidist_family.epidist_latent_individual <- function(data, family = "lognormal",
 #' @family latent_individual
 #' @export
 epidist_prior.epidist_latent_individual <- function(data, ...) {
+  validate_latent_individual(data)
+
   prior1 <- brms::prior("normal(2, 0.5)", class = "Intercept")
   prior2 <- brms::prior("normal(0, 0.5)", class = "Intercept", dpar = "sigma")
   return(prior1 + prior2)
@@ -135,6 +223,8 @@ epidist_stancode.epidist_latent_individual <- function(data,
                                                          epidist_family(data),
                                                        ...) {
 
+  validate_latent_individual(data)
+
   stanvars_version <- epidist_version_stanvar()
 
   stanvars_functions <- brms::stanvar(

diff --git a/man/as_latent_individual.Rd b/man/as_latent_individual.Rd
diff --git a/man/epidist.Rd b/man/epidist.Rd
diff --git a/man/epidist.default.Rd b/man/epidist.default.Rd
diff --git a/man/epidist_family.Rd b/man/epidist_family.Rd
diff --git a/man/epidist_family.default.Rd b/man/epidist_family.default.Rd
diff --git a/man/epidist_formula.Rd b/man/epidist_formula.Rd
diff --git a/man/epidist_formula.default.Rd b/man/epidist_formula.default.Rd