From c835f5f5706b9ad148cf8e598077442c90e35030 Mon Sep 17 00:00:00 2001 From: Sam Abbott Date: Fri, 15 Nov 2024 16:04:22 +0000 Subject: [PATCH] Updates s3 construction to be closer to best practice (#441) * merge changes * overhaul class system and object assertion * get setup script running and prune down class requirements to what is actually needed * remove temporary function * remove test that doesn't do anything * check vignettes * minor tweaks to package family org * rename without epidist prefix * fix file.paths * rename and update functionality for linelist handling * catch changed family name * add lubridate * check date tiem suing lubrdiate * update namespace * flip test to working * fix CRAN notes * fix doc missing * fix R chunk start * rename models * rename models * export stanvar * update cmdstan model check * update package familes * check new tests --- .github/workflows/check-cmdstan.yaml | 11 +- DESCRIPTION | 8 +- NAMESPACE | 48 ++-- R/assert_epidist.R | 21 ++ R/direct_model.R | 48 ---- R/epidist.R | 2 +- R/family.R | 2 +- R/formula.R | 2 +- R/globals.R | 2 +- R/{latent_individual.R => latent_model.R} | 109 ++++----- R/linelist_data.R | 206 ++++++++++++++++++ R/naive_model.R | 55 +++++ R/preprocess.R | 76 ------- R/prior.R | 2 +- R/utils.R | 23 +- R/validate.R | 45 ---- _pkgdown.yml | 20 +- .../functions.stan | 0 .../parameters.stan | 0 .../priors.stan | 0 .../tparameters.stan | 0 man/as_direct_model.Rd | 15 -- man/as_epidist_latent_model.Rd | 22 ++ man/as_epidist_linelist.Rd | 34 --- man/as_epidist_linelist_data.Rd | 25 +++ man/as_epidist_linelist_data.data.frame.Rd | 55 +++++ man/as_epidist_linelist_data.default.Rd | 39 ++++ man/as_epidist_naive_model.Rd | 21 ++ ...idist_naive_model.epidist_linelist_data.Rd | 21 ++ man/as_latent_individual.Rd | 22 -- man/assert_epidist.Rd | 20 ++ man/assert_epidist.epidist_linelist_data.Rd | 25 +++ ...dist_family_model.epidist_latent_model.Rd} | 20 +- ...formula_model.epidist_latent_individual.Rd | 26 --- ...dist_formula_model.epidist_latent_model.Rd | 26 +++ man/epidist_validate_data.Rd | 23 -- man/epidist_validate_data.default.Rd | 23 -- man/epidist_validate_data.epidist_linelist.Rd | 22 -- man/epidist_validate_model.Rd | 23 -- man/epidist_validate_model.default.Rd | 23 -- man/is_direct_model.Rd | 22 -- man/is_epidist_latent_model.Rd | 22 ++ man/is_epidist_linelist.Rd | 22 -- man/is_epidist_linelist_data.Rd | 25 +++ man/is_epidist_naive_model.Rd | 21 ++ man/is_latent_individual.Rd | 22 -- man/new_epidist_latent_model.Rd | 25 +++ man/new_epidist_linelist_data.Rd | 26 +++ man/new_epidist_naive_model.Rd | 24 ++ tests/testthat/setup.R | 41 ++-- tests/testthat/test-diagnostics.R | 2 +- tests/testthat/test-direct_model.R | 50 ----- tests/testthat/test-formula.R | 2 +- tests/testthat/test-int-direct_model.R | 7 +- ...t_individual.R => test-int-latent_model.R} | 22 +- tests/testthat/test-latent_individual.R | 59 ----- tests/testthat/test-latent_model.R | 58 +++++ tests/testthat/test-linelist_data.R | 115 ++++++++++ tests/testthat/test-naive_model.R | 45 ++++ tests/testthat/test-preprocess.R | 46 ---- tests/testthat/test-prior.R | 2 +- tests/testthat/test-utils.R | 4 +- vignettes/approx-inference.Rmd | 18 +- vignettes/ebola.Rmd | 44 ++-- vignettes/epidist.Rmd | 26 +-- vignettes/faq.Rmd | 19 +- 66 files changed, 1135 insertions(+), 799 deletions(-) create mode 100644 R/assert_epidist.R delete mode 100644 R/direct_model.R rename R/{latent_individual.R => latent_model.R} (63%) create mode 100644 R/linelist_data.R create mode 100644 R/naive_model.R delete mode 100644 R/preprocess.R delete mode 100644 R/validate.R rename inst/stan/{latent_individual => latent_model}/functions.stan (100%) rename inst/stan/{latent_individual => latent_model}/parameters.stan (100%) rename inst/stan/{latent_individual => latent_model}/priors.stan (100%) rename inst/stan/{latent_individual => latent_model}/tparameters.stan (100%) delete mode 100644 man/as_direct_model.Rd create mode 100644 man/as_epidist_latent_model.Rd delete mode 100644 man/as_epidist_linelist.Rd create mode 100644 man/as_epidist_linelist_data.Rd create mode 100644 man/as_epidist_linelist_data.data.frame.Rd create mode 100644 man/as_epidist_linelist_data.default.Rd create mode 100644 man/as_epidist_naive_model.Rd create mode 100644 man/as_epidist_naive_model.epidist_linelist_data.Rd delete mode 100644 man/as_latent_individual.Rd create mode 100644 man/assert_epidist.Rd create mode 100644 man/assert_epidist.epidist_linelist_data.Rd rename man/{epidist_family_model.epidist_latent_individual.Rd => epidist_family_model.epidist_latent_model.Rd} (51%) delete mode 100644 man/epidist_formula_model.epidist_latent_individual.Rd create mode 100644 man/epidist_formula_model.epidist_latent_model.Rd delete mode 100644 man/epidist_validate_data.Rd delete mode 100644 man/epidist_validate_data.default.Rd delete mode 100644 man/epidist_validate_data.epidist_linelist.Rd delete mode 100644 man/epidist_validate_model.Rd delete mode 100644 man/epidist_validate_model.default.Rd delete mode 100644 man/is_direct_model.Rd create mode 100644 man/is_epidist_latent_model.Rd delete mode 100644 man/is_epidist_linelist.Rd create mode 100644 man/is_epidist_linelist_data.Rd create mode 100644 man/is_epidist_naive_model.Rd delete mode 100644 man/is_latent_individual.Rd create mode 100644 man/new_epidist_latent_model.Rd create mode 100644 man/new_epidist_linelist_data.Rd create mode 100644 man/new_epidist_naive_model.Rd delete mode 100644 tests/testthat/test-direct_model.R rename tests/testthat/{test-int-latent_individual.R => test-int-latent_model.R} (76%) delete mode 100644 tests/testthat/test-latent_individual.R create mode 100644 tests/testthat/test-latent_model.R create mode 100644 tests/testthat/test-linelist_data.R create mode 100644 tests/testthat/test-naive_model.R delete mode 100644 tests/testthat/test-preprocess.R diff --git a/.github/workflows/check-cmdstan.yaml b/.github/workflows/check-cmdstan.yaml index c02adc54e..12fb5652c 100644 --- a/.github/workflows/check-cmdstan.yaml +++ b/.github/workflows/check-cmdstan.yaml @@ -62,13 +62,12 @@ jobs: - name: Compile model and check syntax run: | - dummy_obs <- dplyr::tibble(case = 1L, ptime = 1, stime = 2, - delay_daily = 1, delay_lwr = 1, delay_upr = 2, ptime_lwr = 1, - ptime_upr = 2, stime_lwr = 1, stime_upr = 2, obs_time = 100, - censored = "interval", censored_obs_time = 10, ptime_daily = 1, - stime_daily = 1 + dummy_obs <- dplyr::tibble( + pdate_lwr = as.Date("2020-01-01"), + sdate_lwr = as.Date("2020-02-01") ) - dummy_obs <- epidist::as_latent_individual(dummy_obs) + dummy_obs <- epidist::as_epidist_linelist_data(dummy_obs) + dummy_obs <- epidist::as_epidist_latent_model(dummy_obs) stancode <- epidist::epidist( data = dummy_obs, fn = brms::make_stancode ) diff --git a/DESCRIPTION b/DESCRIPTION index 21ceb1f3a..f3b6e0bb8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,7 +32,9 @@ Imports: cli, checkmate, rstan (>= 2.26.0), - dplyr + dplyr, + tibble, + lubridate Suggests: bookdown, testthat (>= 3.0.0), @@ -41,7 +43,6 @@ Suggests: gt, knitr, roxyglobals, - tibble, bayesplot, tidyr, posterior, @@ -51,8 +52,7 @@ Suggests: modelr, patchwork, cmdstanr, - priorsense -LinkingTo: + priorsense, BH (>= 1.66.0), Rcpp (>= 0.12.0), RcppEigen (>= 0.3.3.3.0) diff --git a/NAMESPACE b/NAMESPACE index 0bc85d4be..83cc4fcb4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,29 +3,31 @@ S3method(add_mean_sd,default) S3method(add_mean_sd,gamma_samples) S3method(add_mean_sd,lognormal_samples) -S3method(as_direct_model,data.frame) -S3method(as_latent_individual,epidist_linelist) +S3method(as_epidist_latent_model,epidist_linelist_data) +S3method(as_epidist_linelist_data,data.frame) +S3method(as_epidist_linelist_data,default) +S3method(as_epidist_naive_model,epidist_linelist_data) +S3method(assert_epidist,default) +S3method(assert_epidist,epidist_latent_model) +S3method(assert_epidist,epidist_linelist_data) +S3method(assert_epidist,epidist_naive_model) S3method(epidist,default) S3method(epidist_family_model,default) -S3method(epidist_family_model,epidist_latent_individual) +S3method(epidist_family_model,epidist_latent_model) S3method(epidist_family_prior,default) S3method(epidist_family_prior,lognormal) S3method(epidist_family_reparam,default) S3method(epidist_family_reparam,gamma) S3method(epidist_formula_model,default) -S3method(epidist_formula_model,epidist_latent_individual) +S3method(epidist_formula_model,epidist_latent_model) S3method(epidist_model_prior,default) S3method(epidist_stancode,default) -S3method(epidist_stancode,epidist_latent_individual) -S3method(epidist_validate_data,default) -S3method(epidist_validate_data,epidist_linelist) -S3method(epidist_validate_model,default) -S3method(epidist_validate_model,epidist_direct_model) -S3method(epidist_validate_model,epidist_latent_individual) +S3method(epidist_stancode,epidist_latent_model) export(add_mean_sd) -export(as_direct_model) -export(as_epidist_linelist) -export(as_latent_individual) +export(as_epidist_latent_model) +export(as_epidist_linelist_data) +export(as_epidist_naive_model) +export(assert_epidist) export(epidist) export(epidist_diagnostics) export(epidist_family) @@ -37,11 +39,12 @@ export(epidist_formula_model) export(epidist_model_prior) export(epidist_prior) export(epidist_stancode) -export(epidist_validate_data) -export(epidist_validate_model) -export(is_direct_model) -export(is_epidist_linelist) -export(is_latent_individual) +export(is_epidist_latent_model) +export(is_epidist_linelist_data) +export(is_epidist_naive_model) +export(new_epidist_latent_model) +export(new_epidist_linelist_data) +export(new_epidist_naive_model) export(observe_process) export(predict_delay_parameters) export(predict_dpar) @@ -52,18 +55,27 @@ export(simulate_uniform_cases) import(ggplot2) importFrom(brms,bf) importFrom(brms,prior) +importFrom(brms,stanvar) importFrom(checkmate,assert_class) importFrom(checkmate,assert_data_frame) +importFrom(checkmate,assert_date) importFrom(checkmate,assert_factor) importFrom(checkmate,assert_integer) importFrom(checkmate,assert_names) importFrom(checkmate,assert_numeric) importFrom(checkmate,assert_true) importFrom(cli,cli_abort) +importFrom(cli,cli_alert_info) importFrom(cli,cli_inform) importFrom(cli,cli_warn) +importFrom(dplyr,bind_cols) importFrom(dplyr,filter) +importFrom(dplyr,full_join) importFrom(dplyr,mutate) importFrom(dplyr,select) +importFrom(lubridate,days) +importFrom(lubridate,is.timepoint) importFrom(stats,as.formula) importFrom(stats,setNames) +importFrom(tibble,tibble) +importFrom(utils,hasName) diff --git a/R/assert_epidist.R b/R/assert_epidist.R new file mode 100644 index 000000000..b0a2502d8 --- /dev/null +++ b/R/assert_epidist.R @@ -0,0 +1,21 @@ +#' Validation for epidist objects +#' +#' @param data Object to validate +#' @param ... Additional arguments +#' @return NULL invisibly +#' @export +#' @family assert +assert_epidist <- function(data, ...) { + UseMethod("assert_epidist") +} + +#' @export +#' @family assert +assert_epidist.default <- function(data, ...) { + cli_abort( + c( + "!" = "The input needs to be a valid epidist object.", + "i" = "Please convert to epidist object first using as_epidist_()" + ) + ) +} diff --git a/R/direct_model.R b/R/direct_model.R deleted file mode 100644 index 603c0ada8..000000000 --- a/R/direct_model.R +++ /dev/null @@ -1,48 +0,0 @@ -#' Prepare direct model to pass through to `brms` -#' -#' @param data A `data.frame` containing line list data -#' @family direct_model -#' @export -as_direct_model <- function(data) { - UseMethod("as_direct_model") -} - -assert_direct_model_input <- function(data) { - assert_data_frame(data) - assert_names(names(data), must.include = c("case", "ptime", "stime")) - assert_integer(data$case, lower = 0) - assert_numeric(data$ptime, lower = 0) - assert_numeric(data$stime, lower = 0) -} - -#' @method as_direct_model data.frame -#' @family direct_model -#' @autoglobal -#' @export -as_direct_model.data.frame <- function(data) { - assert_direct_model_input(data) - class(data) <- c("epidist_direct_model", class(data)) - data <- data |> - mutate(delay = .data$stime - .data$ptime) - epidist_validate_model(data) - return(data) -} - -#' @method epidist_validate_model epidist_direct_model -#' @family direct_model -#' @export -epidist_validate_model.epidist_direct_model <- function(data, ...) { - assert_true(is_direct_model(data)) - assert_direct_model_input(data) - assert_names(names(data), must.include = c("case", "ptime", "stime", "delay")) - assert_numeric(data$delay, lower = 0) -} - -#' Check if data has the `epidist_direct_model` class -#' -#' @param data A `data.frame` containing line list data -#' @family latent_individual -#' @export -is_direct_model <- function(data) { - inherits(data, "epidist_direct_model") -} diff --git a/R/epidist.R b/R/epidist.R index 2496d4feb..74c1632e1 100644 --- a/R/epidist.R +++ b/R/epidist.R @@ -36,7 +36,7 @@ epidist <- function(data, formula, family, prior, fn, ...) { epidist.default <- function(data, formula = mu ~ 1, family = "lognormal", prior = NULL, fn = brms::brm, ...) { - epidist_validate_model(data) + assert_epidist(data) epidist_family <- epidist_family(data, family) epidist_formula <- epidist_formula( data = data, family = epidist_family, formula = formula diff --git a/R/family.R b/R/family.R index ba76b8cbd..d32e0e54b 100644 --- a/R/family.R +++ b/R/family.R @@ -9,7 +9,7 @@ #' @family family #' @export epidist_family <- function(data, family = "lognormal", ...) { - epidist_validate_model(data) + assert_epidist(data) family <- brms:::validate_family(family) class(family) <- c(family$family, class(family)) family <- .add_dpar_info(family) diff --git a/R/formula.R b/R/formula.R index 71e5c094c..21fca0b55 100644 --- a/R/formula.R +++ b/R/formula.R @@ -11,7 +11,7 @@ #' @family formula #' @export epidist_formula <- function(data, family, formula, ...) { - epidist_validate_model(data) + assert_epidist(data) formula <- brms:::validate_formula(formula, data = data, family = family) formula <- .make_intercepts_explicit(formula) formula <- epidist_formula_model(data, formula) diff --git a/R/globals.R b/R/globals.R index 64d98ea51..bfa8d919d 100644 --- a/R/globals.R +++ b/R/globals.R @@ -2,7 +2,7 @@ utils::globalVariables(c( "samples", # - "woverlap", # + "woverlap", # "rlnorm", # "prior_new", # <.replace_prior> "source_new", # <.replace_prior> diff --git a/R/latent_individual.R b/R/latent_model.R similarity index 63% rename from R/latent_individual.R rename to R/latent_model.R index 8f0bb8140..0e4182686 100644 --- a/R/latent_individual.R +++ b/R/latent_model.R @@ -1,19 +1,18 @@ -#' Prepare latent individual model +#' Convert an object to an `epidist_latent_model` object #' #' @param data A `data.frame` containing line list data -#' @family latent_individual +#' @family latent_model #' @export -as_latent_individual <- function(data) { - UseMethod("as_latent_individual") +as_epidist_latent_model <- function(data) { + UseMethod("as_epidist_latent_model") } -#' @method as_latent_individual epidist_linelist -#' @family latent_individual +#' @method as_epidist_latent_model epidist_linelist_data +#' @family latent_model #' @autoglobal #' @export -as_latent_individual.epidist_linelist <- function(data) { - epidist_validate_data(data) - class(data) <- c("epidist_latent_individual", class(data)) +as_epidist_latent_model.epidist_linelist_data <- function(data) { + assert_epidist(data) data <- data |> mutate( relative_obs_time = .data$obs_time - .data$ptime_lwr, @@ -27,45 +26,55 @@ as_latent_individual.epidist_linelist <- function(data) { delay = .data$stime_lwr - .data$ptime_lwr, .row_id = dplyr::row_number() ) - epidist_validate_model(data) + data <- new_epidist_latent_model(data) + assert_epidist(data) return(data) } -#' @method epidist_validate_model epidist_latent_individual -#' @family latent_individual +#' Class constructor for `epidist_latent_model` objects +#' +#' @param data A data.frame to convert +#' @returns An object of class `epidist_latent_model` +#' @family latent_model +#' @export +new_epidist_latent_model <- function(data) { + class(data) <- c("epidist_latent_model", class(data)) + return(data) +} + +#' Check if data has the `epidist_latent_model` class +#' +#' @param data A `data.frame` containing line list data +#' @family latent_model #' @export -epidist_validate_model.epidist_latent_individual <- function(data, ...) { - assert_true(is_latent_individual(data)) +is_epidist_latent_model <- function(data) { + inherits(data, "epidist_latent_model") +} + +#' @method assert_epidist epidist_latent_model +#' @family latent_model +#' @export +assert_epidist.epidist_latent_model <- function(data, ...) { col_names <- c( "ptime_lwr", "ptime_upr", "stime_lwr", "stime_upr", "obs_time", "relative_obs_time", "pwindow", "woverlap", "swindow", "delay", ".row_id" ) assert_names(names(data), must.include = col_names) assert_numeric(data$relative_obs_time, lower = 0) - # pwindow as f(p) and swindow as f(s) checks here? assert_numeric(data$pwindow, lower = 0) assert_numeric(data$woverlap, lower = 0) assert_numeric(data$swindow, lower = 0) assert_numeric(data$delay, lower = 0) } -#' Check if data has the `epidist_latent_individual` class -#' -#' @param data A `data.frame` containing line list data -#' @family latent_individual -#' @export -is_latent_individual <- function(data) { - inherits(data, "epidist_latent_individual") -} - #' Create the model-specific component of an `epidist` custom family #' #' @inheritParams epidist_family_model #' @param ... Additional arguments passed to method. -#' @method epidist_family_model epidist_latent_individual -#' @family latent_individual +#' @method epidist_family_model epidist_latent_model +#' @family latent_model #' @export -epidist_family_model.epidist_latent_individual <- function( +epidist_family_model.epidist_latent_model <- function( data, family, ...) { # Really the name and vars are the "model-specific" parts here custom_family <- brms::custom_family( @@ -87,10 +96,10 @@ epidist_family_model.epidist_latent_individual <- function( #' @param data A `data.frame` containing line list data #' @param formula As produced by [brms::brmsformula()] #' @param ... ... -#' @method epidist_formula_model epidist_latent_individual -#' @family latent_individual +#' @method epidist_formula_model epidist_latent_model +#' @family latent_model #' @export -epidist_formula_model.epidist_latent_individual <- function( +epidist_formula_model.epidist_latent_model <- function( data, formula, ...) { # data is only used to dispatch on formula <- stats::update( @@ -99,23 +108,23 @@ epidist_formula_model.epidist_latent_individual <- function( return(formula) } -#' @method epidist_stancode epidist_latent_individual -#' @family latent_individual +#' @method epidist_stancode epidist_latent_model +#' @importFrom brms stanvar +#' @family latent_model #' @autoglobal #' @export -epidist_stancode.epidist_latent_individual <- function(data, - family = - epidist_family(data), - formula = - epidist_formula(data), - ...) { - epidist_validate_model(data) +epidist_stancode.epidist_latent_model <- function( + data, + family = epidist_family(data), + formula = epidist_formula(data), ... +) { + assert_epidist(data) stanvars_version <- .version_stanvar() - stanvars_functions <- brms::stanvar( + stanvars_functions <- stanvar( block = "functions", - scode = .stan_chunk("latent_individual/functions.stan") + scode = .stan_chunk(file.path("latent_model", "functions.stan")) ) family_name <- gsub("latent_", "", family$name) @@ -143,38 +152,38 @@ epidist_stancode.epidist_latent_individual <- function(data, stanvars_functions[[1]]$scode ) - stanvars_data <- brms::stanvar( + stanvars_data <- stanvar( block = "data", scode = "int wN;", x = nrow(filter(data, woverlap > 0)), name = "wN" ) + - brms::stanvar( + stanvar( block = "data", scode = "array[N - wN] int noverlap;", x = filter(data, woverlap == 0)$.row_id, name = "noverlap" ) + - brms::stanvar( + stanvar( block = "data", scode = "array[wN] int woverlap;", x = filter(data, woverlap > 0)$.row_id, name = "woverlap" ) - stanvars_parameters <- brms::stanvar( + stanvars_parameters <- stanvar( block = "parameters", - scode = .stan_chunk("latent_individual/parameters.stan") + scode = .stan_chunk(file.path("latent_model", "parameters.stan")) ) - stanvars_tparameters <- brms::stanvar( + stanvars_tparameters <- stanvar( block = "tparameters", - scode = .stan_chunk("latent_individual/tparameters.stan") + scode = .stan_chunk(file.path("latent_model", "tparameters.stan")) ) - stanvars_priors <- brms::stanvar( + stanvars_priors <- stanvar( block = "model", - scode = .stan_chunk("latent_individual/priors.stan") + scode = .stan_chunk(file.path("latent_model", "priors.stan")) ) stanvars_all <- stanvars_version + stanvars_functions + stanvars_data + diff --git a/R/linelist_data.R b/R/linelist_data.R new file mode 100644 index 000000000..a423c1593 --- /dev/null +++ b/R/linelist_data.R @@ -0,0 +1,206 @@ +#' Create an epidist_linelist_data object +#' +#' @param data The data to convert +#' @param ... Additional arguments passed to methods +#' @family linelist_data +#' @export +as_epidist_linelist_data <- function(data, ...) { + UseMethod("as_epidist_linelist_data") +} + +#' Create an epidist_linelist_data object from vectors of event times +#' +#' @param data Numeric vector giving lower bounds for primary times +#' @param ptime_upr Numeric vector giving upper bounds for primary times +#' @param stime_lwr,stime_upr Numeric vectors giving lower and upper bounds for +#' secondary times +#' @param obs_time Numeric vector giving observation times +#' @param ... Additional columns to add to the epidist_linelist_data object +#' @importFrom tibble tibble +#' @importFrom dplyr bind_cols +#' @family linelist_data +#' @export +as_epidist_linelist_data.default <- function( + data, ptime_upr = NULL, stime_lwr = NULL, stime_upr = NULL, + obs_time = NULL, ... +) { + # Create base data frame with required columns + df <- tibble( + ptime_lwr = data, + ptime_upr = ptime_upr, + stime_lwr = stime_lwr, + stime_upr = stime_upr, + obs_time = obs_time + ) + + # Add any additional columns passed via ... + extra_cols <- list(...) + if (length(extra_cols) > 0) { + df <- bind_cols(df, extra_cols) + } + + df <- new_epidist_linelist_data(df) + assert_epidist(df) + + return(df) +} + +#' Create an epidist_linelist_data object from a data frame with event dates +#' +#' @param data A data.frame containing line list data +#' +#' @param pdate_lwr A string giving the column of `data` containing the primary +#' event lower bound as a datetime. Defaults to `NULL` which assumes that the +#' variable `pdate_lwr` is present. +#' +#' @param pdate_upr A string giving the column of `data` containing the primary +#' event upper bound as a datetime. If this column exists in the data it will be +#' used, otherwise if not supplied then the value of `pdate_lwr` + 1 day is +#' used. +#' +#' @param sdate_lwr A string giving the column of `data` containing the +#' secondary event lower bound as a datetime. Defaults to `NULL` which assumes +#' that the variable `sdate_lwr` is present. +#' +#' @param sdate_upr A string giving the column of `data` containing the +#' secondary event upper bound as a datetime. If this column exists in the data +#' it will be used, otherwise if not supplied then the value of `sdate_lwr` + 1 +#' day is used. +#' +#' @param obs_date A string giving the column of `data` containing the +#' observation time as a datetime. Optional, if not supplied then the maximum of +#' `sdate_upr` is used. +#' +#' @param ... Additional arguments passed to methods +#' @family linelist_data +#' @importFrom dplyr bind_cols +#' @importFrom lubridate days is.timepoint +#' @importFrom cli cli_abort cli_alert_info +#' @importFrom checkmate assert_true assert_names assert_numeric assert_date +#' @importFrom utils hasName +#' @export +as_epidist_linelist_data.data.frame <- function( + data, pdate_lwr = NULL, sdate_lwr = NULL, pdate_upr = NULL, sdate_upr = NULL, + obs_date = NULL, ... +) { + if (is.null(pdate_lwr) && !hasName(data, "pdate_lwr")) { + cli::cli_abort("{.var pdate_lwr} is NULL but must be provided.") + } + + if (is.null(sdate_lwr) && !hasName(data, "sdate_lwr")) { + cli::cli_abort("{.var sdate_lwr} is NULL but must be provided.") + } + + # Only include non-null inputs in renaming + valid_inputs <- !sapply( + list(pdate_lwr, pdate_upr, sdate_lwr, sdate_upr, obs_date), + is.null + ) + new_names <- c( + "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" + ) + old_names <- c(pdate_lwr, pdate_upr, sdate_lwr, sdate_upr, obs_date) + df <- .rename_columns(data, + new_names = new_names[valid_inputs], + old_names = old_names + ) + + if (!hasName(df, "pdate_upr")) { + cli::cli_alert_info(paste0( + "No primary event upper bound provided, using the primary event lower ", + "bound + 1 day as the assumed upper bound." + )) + df <- mutate(df, pdate_upr = pdate_lwr + lubridate::days(1)) + } + + if (!hasName(df, "sdate_upr")) { + cli::cli_alert_info(paste0( + "No secondary event upper bound provided, using the secondary event", + " lower bound + 1 day as the assumed upper bound." + )) + df <- mutate(df, sdate_upr = sdate_lwr + lubridate::days(1)) + } + + if (!hasName(df, "obs_date")) { + cli::cli_alert_info(paste0( + "No observation time column provided, using ", max(df$sdate_upr), + " as the observation date (the maximum of the secondary event upper ", + "bound)." + )) + df <- mutate(df, obs_date = max(sdate_upr)) + } + + col_names <- c( + "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" + ) + assert_names(names(df), must.include = col_names) + + # Check for being a datetime + assert_true(is.timepoint(df$pdate_lwr)) + assert_true(is.timepoint(df$pdate_upr)) + assert_true(is.timepoint(df$sdate_lwr)) + assert_true(is.timepoint(df$sdate_upr)) + assert_true(is.timepoint(df$obs_date)) + + # Convert datetime to time + min_date <- min(df$pdate_lwr) + + # Convert to numeric times and use default method + + result <- as_epidist_linelist_data.default( + data = as.numeric(df$pdate_lwr - min_date), + ptime_upr = as.numeric(df$pdate_upr - min_date), + stime_lwr = as.numeric(df$sdate_lwr - min_date), + stime_upr = as.numeric(df$sdate_upr - min_date), + obs_time = as.numeric(df$obs_date - min_date) + ) + + result <- bind_cols(result, df) + + return(result) +} + +#' Class constructor for `epidist_linelist_data` objects +#' +#' @param data A data.frame to convert +#' @returns An object of class `epidist_linelist_data` +#' @family linelist_data +#' @export +new_epidist_linelist_data <- function(data) { + class(data) <- c("epidist_linelist_data", class(data)) + return(data) +} + +#' Check if data has the `epidist_linelist_data` class +#' +#' @inheritParams as_epidist_linelist_data +#' @param ... Additional arguments +#' @family linelist_data +#' @export +is_epidist_linelist_data <- function(data, ...) { + inherits(data, "epidist_linelist_data") +} + +#' Assert validity of `epidist_linelist_data` objects +#' +#' @param data An object to check +#' @param ... Additional arguments +#' @method assert_epidist epidist_linelist_data +#' @family linelist_data +#' @export +assert_epidist.epidist_linelist_data <- function(data, ...) { + assert_data_frame(data) + col_names <- c( + "ptime_lwr", "ptime_upr", "stime_lwr", "stime_upr", "obs_time" + ) + assert_names(names(data), must.include = col_names) + assert_numeric(data$ptime_lwr, lower = 0) + assert_numeric(data$ptime_upr, lower = 0) + assert_true(all(data$ptime_upr - data$ptime_lwr > 0)) + assert_numeric(data$stime_lwr, lower = 0) + assert_numeric(data$stime_upr, lower = 0) + assert_true(all(data$stime_upr - data$stime_lwr > 0)) + assert_numeric(data$obs_time, lower = 0) + + return(invisible(NULL)) +} diff --git a/R/naive_model.R b/R/naive_model.R new file mode 100644 index 000000000..6b95ff14a --- /dev/null +++ b/R/naive_model.R @@ -0,0 +1,55 @@ +#' Prepare direct model to pass through to `brms` +#' +#' @param data A `data.frame` containing line list data +#' @family naive_model +#' @export +as_epidist_naive_model <- function(data) { + UseMethod("as_epidist_naive_model") +} + +#' The direct model method for `epidist_linelist_data` objects +#' +#' @param data An `epidist_linelist_data` object +#' @method as_epidist_naive_model epidist_linelist_data +#' @family naive_model +#' @autoglobal +#' @export +as_epidist_naive_model.epidist_linelist_data <- function(data) { + assert_epidist(data) + + data <- data |> + mutate(delay = .data$stime_lwr - .data$ptime_lwr) + + data <- new_epidist_naive_model(data) + assert_epidist(data) + return(data) +} + +#' Class constructor for `epidist_naive_model` objects +#' +#' @param data A data.frame to convert +#' @returns An object of class `epidist_naive_model` +#' @family naive_model +#' @export +new_epidist_naive_model <- function(data) { + class(data) <- c("epidist_naive_model", class(data)) + return(data) +} + +#' @method assert_epidist epidist_naive_model +#' @family naive_model +#' @export +assert_epidist.epidist_naive_model <- function(data, ...) { + assert_data_frame(data) + assert_names(names(data), must.include = c("delay")) + assert_numeric(data$delay, lower = 0) +} + +#' Check if data has the `epidist_naive_model` class +#' +#' @param data A `data.frame` containing line list data +#' @family naive_model +#' @export +is_epidist_naive_model <- function(data) { + inherits(data, "epidist_naive_model") +} diff --git a/R/preprocess.R b/R/preprocess.R deleted file mode 100644 index e39c84f56..000000000 --- a/R/preprocess.R +++ /dev/null @@ -1,76 +0,0 @@ -#' Prepare date data in the `epidist_linelist` format -#' -#' @param data A `data.frame` containing line list data -#' @param pdate_lwr,pdate_upr,sdate_lwr,sdate_upr Strings giving the column of -#' `data` containing the primary and secondary event upper and lower bounds. -#' These columns of `data` must be as datetime. -#' @param obs_date A string giving the column of `data` containing the -#' observation time as a datetime. -#' @family preprocess -#' @export -as_epidist_linelist <- function( - data, pdate_lwr = NULL, pdate_upr = NULL, sdate_lwr = NULL, - sdate_upr = NULL, obs_date = NULL) { - class(data) <- c("epidist_linelist", class(data)) - - data <- .rename_columns(data, - new_names = c( - "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" - ), - old_names = c(pdate_lwr, pdate_upr, sdate_lwr, sdate_upr, obs_date) - ) - - # Check for being a datetime - assert_true(any(inherits(data$pdate_lwr, c("POSIXct", "POSIXlt")))) - assert_true(any(inherits(data$pdate_upr, c("POSIXct", "POSIXlt")))) - assert_true(any(inherits(data$sdate_lwr, c("POSIXct", "POSIXlt")))) - assert_true(any(inherits(data$sdate_upr, c("POSIXct", "POSIXlt")))) - assert_true(any(inherits(data$obs_date, c("POSIXct", "POSIXlt")))) - - # Convert datetime to time - min_date <- min(data$pdate_lwr) - - data <- mutate(data, - ptime_lwr = as.numeric(.data$pdate_lwr - min_date), - ptime_upr = as.numeric(.data$pdate_upr - min_date), - stime_lwr = as.numeric(.data$sdate_lwr - min_date), - stime_upr = as.numeric(.data$sdate_upr - min_date), - obs_time = as.numeric(.data$obs_date - min_date) - ) - - epidist_validate_data(data) - - return(data) -} - -#' Validation for the `epidist_linelist` class -#' -#' @inheritParams as_epidist_linelist -#' @param ... Additional arguments -#' @family preprocess -#' @export -epidist_validate_data.epidist_linelist <- function(data, ...) { - assert_true(is_epidist_linelist(data)) - assert_data_frame(data) - col_names <- c( - "case", "ptime_lwr", "ptime_upr", "stime_lwr", "stime_upr", "obs_time" - ) - assert_names(names(data), must.include = col_names) - assert_numeric(data$ptime_lwr, lower = 0) - assert_numeric(data$ptime_upr, lower = 0) - assert_true(all(data$ptime_upr - data$ptime_lwr > 0)) - assert_numeric(data$stime_lwr, lower = 0) - assert_numeric(data$stime_upr, lower = 0) - assert_true(all(data$stime_upr - data$stime_lwr > 0)) - assert_numeric(data$obs_time, lower = 0) -} - -#' Check if data has the `epidist_linelist` class -#' -#' @inheritParams as_epidist_linelist -#' @param ... Additional arguments -#' @family preprocess -#' @export -is_epidist_linelist <- function(data, ...) { - inherits(data, "epidist_linelist") -} diff --git a/R/prior.R b/R/prior.R index 3ff6c4a47..015b16903 100644 --- a/R/prior.R +++ b/R/prior.R @@ -21,7 +21,7 @@ #' @family prior #' @export epidist_prior <- function(data, family, formula, prior) { - epidist_validate_model(data) + assert_epidist(data) default <- brms::default_prior(formula, data = data) model <- epidist_model_prior(data, formula) family <- epidist_family_prior(family, formula) diff --git a/R/utils.R b/R/utils.R index a2cef2f8c..1069f073a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,7 +8,7 @@ #' @return A character string containing the Stan code chunk of interest. #' @keywords internal .stan_chunk <- function(path) { - local_path <- system.file(paste0("stan/", path), package = "epidist") + local_path <- system.file(file.path("stan", path), package = "epidist") paste(readLines(local_path), collapse = "\n") } @@ -54,6 +54,7 @@ #' @param warn If `TRUE` then a warning will be displayed if a `new_prior` is #' provided for which there is no matching `old_prior`. Defaults to `FALSE` #' @autoglobal +#' @importFrom dplyr full_join filter select #' @keywords internal .replace_prior <- function(old_prior, prior, warn = FALSE) { if (is.null(prior)) { @@ -135,12 +136,24 @@ #' @keywords internal #' @importFrom stats setNames .rename_columns <- function(df, new_names, old_names) { - are_char <- is.character(new_names) & is.character(old_names) - valid_new_names <- new_names[are_char] - valid_old_names <- old_names[are_char] - if (length(are_char) > 0) { + are_valid <- is.character(new_names) & is.character(old_names) + + valid_new_names <- new_names[are_valid] + valid_old_names <- old_names[are_valid] + + # Check if old names exist in dataframe + missing_cols <- setdiff(valid_old_names, names(df)) + if (length(missing_cols) > 0) { + cli::cli_abort(paste0( + "The following columns are not present in the data: ", + paste(missing_cols, collapse = ", ") + )) + } + + if (length(valid_new_names) > 0) { rename_map <- setNames(valid_old_names, valid_new_names) df <- dplyr::rename(df, !!!rename_map) } + return(df) } diff --git a/R/validate.R b/R/validate.R deleted file mode 100644 index e3a464c89..000000000 --- a/R/validate.R +++ /dev/null @@ -1,45 +0,0 @@ -#' Validate data class -#' -#' @inheritParams epidist -#' @param ... Additional arguments -#' @family validate -#' @export -epidist_validate_data <- function(data, ...) { - UseMethod("epidist_validate_data") -} - -#' Default method for validate data class -#' -#' @inheritParams epidist -#' @param ... Additional arguments -#' @family validate -#' @export -epidist_validate_data.default <- function(data, ...) { - cli_abort( - "No epidist_validate_data method implemented for the class ", class(data), - "\n", "See methods(epidist_validate_data) for available methods" - ) -} - -#' Validate model class -#' -#' @inheritParams epidist -#' @param ... Additional arguments -#' @family validate -#' @export -epidist_validate_model <- function(data, ...) { - UseMethod("epidist_validate_model") -} - -#' Default method for validate model class -#' -#' @inheritParams epidist -#' @param ... Additional arguments -#' @family validate -#' @export -epidist_validate_model.default <- function(data, ...) { - cli_abort( - "No epidist_validate_model method implemented for the class ", class(data), - "\n", "See methods(epidist_validate_model) for available methods" - ) -} diff --git a/_pkgdown.yml b/_pkgdown.yml index 06b1422ac..1102ecd6d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -37,14 +37,14 @@ reference: desc: Functions for observing data contents: - has_concept("observe") -- title: Preprocess - desc: Functions for preprocessing data +- title: Linelist data + desc: Functions for preparing linelist data contents: - - has_concept("preprocess") -- title: Validation - desc: Functions used to check validity of package objects + - has_concept("linelist_data") +- title: Assert validity of objects + desc: Functions used to assert the validity of package objects contents: - - has_concept("validate") + - has_concept("assert") - title: Family desc: Functions related to specifying custom `brms` families contents: @@ -65,14 +65,14 @@ reference: desc: Functions for fitting delay distribution models using `brms` contents: - has_concept("fit") -- title: Latent individual model - desc: Specific methods for the latent individual model +- title: Latent model + desc: Specific methods for the latent model contents: - - has_concept("latent_individual") + - has_concept("latent_model") - title: Direct model desc: Specific methods for the direct model contents: - - has_concept("direct_model") + - has_concept("naive_model") - title: Postprocess desc: Functions for postprocessing model output contents: diff --git a/inst/stan/latent_individual/functions.stan b/inst/stan/latent_model/functions.stan similarity index 100% rename from inst/stan/latent_individual/functions.stan rename to inst/stan/latent_model/functions.stan diff --git a/inst/stan/latent_individual/parameters.stan b/inst/stan/latent_model/parameters.stan similarity index 100% rename from inst/stan/latent_individual/parameters.stan rename to inst/stan/latent_model/parameters.stan diff --git a/inst/stan/latent_individual/priors.stan b/inst/stan/latent_model/priors.stan similarity index 100% rename from inst/stan/latent_individual/priors.stan rename to inst/stan/latent_model/priors.stan diff --git a/inst/stan/latent_individual/tparameters.stan b/inst/stan/latent_model/tparameters.stan similarity index 100% rename from inst/stan/latent_individual/tparameters.stan rename to inst/stan/latent_model/tparameters.stan diff --git a/man/as_direct_model.Rd b/man/as_direct_model.Rd deleted file mode 100644 index cbce0425c..000000000 --- a/man/as_direct_model.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/direct_model.R -\name{as_direct_model} -\alias{as_direct_model} -\title{Prepare direct model to pass through to \code{brms}} -\usage{ -as_direct_model(data) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} -} -\description{ -Prepare direct model to pass through to \code{brms} -} -\concept{direct_model} diff --git a/man/as_epidist_latent_model.Rd b/man/as_epidist_latent_model.Rd new file mode 100644 index 000000000..8427e15fc --- /dev/null +++ b/man/as_epidist_latent_model.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/latent_model.R +\name{as_epidist_latent_model} +\alias{as_epidist_latent_model} +\title{Convert an object to an \code{epidist_latent_model} object} +\usage{ +as_epidist_latent_model(data) +} +\arguments{ +\item{data}{A \code{data.frame} containing line list data} +} +\description{ +Convert an object to an \code{epidist_latent_model} object +} +\seealso{ +Other latent_model: +\code{\link{epidist_family_model.epidist_latent_model}()}, +\code{\link{epidist_formula_model.epidist_latent_model}()}, +\code{\link{is_epidist_latent_model}()}, +\code{\link{new_epidist_latent_model}()} +} +\concept{latent_model} diff --git a/man/as_epidist_linelist.Rd b/man/as_epidist_linelist.Rd deleted file mode 100644 index 682832251..000000000 --- a/man/as_epidist_linelist.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/preprocess.R -\name{as_epidist_linelist} -\alias{as_epidist_linelist} -\title{Prepare date data in the \code{epidist_linelist} format} -\usage{ -as_epidist_linelist( - data, - pdate_lwr = NULL, - pdate_upr = NULL, - sdate_lwr = NULL, - sdate_upr = NULL, - obs_date = NULL -) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} - -\item{pdate_lwr, pdate_upr, sdate_lwr, sdate_upr}{Strings giving the column of -\code{data} containing the primary and secondary event upper and lower bounds. -These columns of \code{data} must be as datetime.} - -\item{obs_date}{A string giving the column of \code{data} containing the -observation time as a datetime.} -} -\description{ -Prepare date data in the \code{epidist_linelist} format -} -\seealso{ -Other preprocess: -\code{\link{epidist_validate_data.epidist_linelist}()}, -\code{\link{is_epidist_linelist}()} -} -\concept{preprocess} diff --git a/man/as_epidist_linelist_data.Rd b/man/as_epidist_linelist_data.Rd new file mode 100644 index 000000000..49822f341 --- /dev/null +++ b/man/as_epidist_linelist_data.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linelist_data.R +\name{as_epidist_linelist_data} +\alias{as_epidist_linelist_data} +\title{Create an epidist_linelist_data object} +\usage{ +as_epidist_linelist_data(data, ...) +} +\arguments{ +\item{data}{The data to convert} + +\item{...}{Additional arguments passed to methods} +} +\description{ +Create an epidist_linelist_data object +} +\seealso{ +Other linelist_data: +\code{\link{as_epidist_linelist_data.data.frame}()}, +\code{\link{as_epidist_linelist_data.default}()}, +\code{\link{assert_epidist.epidist_linelist_data}()}, +\code{\link{is_epidist_linelist_data}()}, +\code{\link{new_epidist_linelist_data}()} +} +\concept{linelist_data} diff --git a/man/as_epidist_linelist_data.data.frame.Rd b/man/as_epidist_linelist_data.data.frame.Rd new file mode 100644 index 000000000..480007340 --- /dev/null +++ b/man/as_epidist_linelist_data.data.frame.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linelist_data.R +\name{as_epidist_linelist_data.data.frame} +\alias{as_epidist_linelist_data.data.frame} +\title{Create an epidist_linelist_data object from a data frame with event dates} +\usage{ +\method{as_epidist_linelist_data}{data.frame}( + data, + pdate_lwr = NULL, + sdate_lwr = NULL, + pdate_upr = NULL, + sdate_upr = NULL, + obs_date = NULL, + ... +) +} +\arguments{ +\item{data}{A data.frame containing line list data} + +\item{pdate_lwr}{A string giving the column of \code{data} containing the primary +event lower bound as a datetime. Defaults to \code{NULL} which assumes that the +variable \code{pdate_lwr} is present.} + +\item{sdate_lwr}{A string giving the column of \code{data} containing the +secondary event lower bound as a datetime. Defaults to \code{NULL} which assumes +that the variable \code{sdate_lwr} is present.} + +\item{pdate_upr}{A string giving the column of \code{data} containing the primary +event upper bound as a datetime. If this column exists in the data it will be +used, otherwise if not supplied then the value of \code{pdate_lwr} + 1 day is +used.} + +\item{sdate_upr}{A string giving the column of \code{data} containing the +secondary event upper bound as a datetime. If this column exists in the data +it will be used, otherwise if not supplied then the value of \code{sdate_lwr} + 1 +day is used.} + +\item{obs_date}{A string giving the column of \code{data} containing the +observation time as a datetime. Optional, if not supplied then the maximum of +\code{sdate_upr} is used.} + +\item{...}{Additional arguments passed to methods} +} +\description{ +Create an epidist_linelist_data object from a data frame with event dates +} +\seealso{ +Other linelist_data: +\code{\link{as_epidist_linelist_data}()}, +\code{\link{as_epidist_linelist_data.default}()}, +\code{\link{assert_epidist.epidist_linelist_data}()}, +\code{\link{is_epidist_linelist_data}()}, +\code{\link{new_epidist_linelist_data}()} +} +\concept{linelist_data} diff --git a/man/as_epidist_linelist_data.default.Rd b/man/as_epidist_linelist_data.default.Rd new file mode 100644 index 000000000..5ae558a03 --- /dev/null +++ b/man/as_epidist_linelist_data.default.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linelist_data.R +\name{as_epidist_linelist_data.default} +\alias{as_epidist_linelist_data.default} +\title{Create an epidist_linelist_data object from vectors of event times} +\usage{ +\method{as_epidist_linelist_data}{default}( + data, + ptime_upr = NULL, + stime_lwr = NULL, + stime_upr = NULL, + obs_time = NULL, + ... +) +} +\arguments{ +\item{data}{Numeric vector giving lower bounds for primary times} + +\item{ptime_upr}{Numeric vector giving upper bounds for primary times} + +\item{stime_lwr, stime_upr}{Numeric vectors giving lower and upper bounds for +secondary times} + +\item{obs_time}{Numeric vector giving observation times} + +\item{...}{Additional columns to add to the epidist_linelist_data object} +} +\description{ +Create an epidist_linelist_data object from vectors of event times +} +\seealso{ +Other linelist_data: +\code{\link{as_epidist_linelist_data}()}, +\code{\link{as_epidist_linelist_data.data.frame}()}, +\code{\link{assert_epidist.epidist_linelist_data}()}, +\code{\link{is_epidist_linelist_data}()}, +\code{\link{new_epidist_linelist_data}()} +} +\concept{linelist_data} diff --git a/man/as_epidist_naive_model.Rd b/man/as_epidist_naive_model.Rd new file mode 100644 index 000000000..d6b5f863f --- /dev/null +++ b/man/as_epidist_naive_model.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/naive_model.R +\name{as_epidist_naive_model} +\alias{as_epidist_naive_model} +\title{Prepare direct model to pass through to \code{brms}} +\usage{ +as_epidist_naive_model(data) +} +\arguments{ +\item{data}{A \code{data.frame} containing line list data} +} +\description{ +Prepare direct model to pass through to \code{brms} +} +\seealso{ +Other naive_model: +\code{\link{as_epidist_naive_model.epidist_linelist_data}()}, +\code{\link{is_epidist_naive_model}()}, +\code{\link{new_epidist_naive_model}()} +} +\concept{naive_model} diff --git a/man/as_epidist_naive_model.epidist_linelist_data.Rd b/man/as_epidist_naive_model.epidist_linelist_data.Rd new file mode 100644 index 000000000..4f0e211e1 --- /dev/null +++ b/man/as_epidist_naive_model.epidist_linelist_data.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/naive_model.R +\name{as_epidist_naive_model.epidist_linelist_data} +\alias{as_epidist_naive_model.epidist_linelist_data} +\title{The direct model method for \code{epidist_linelist_data} objects} +\usage{ +\method{as_epidist_naive_model}{epidist_linelist_data}(data) +} +\arguments{ +\item{data}{An \code{epidist_linelist_data} object} +} +\description{ +The direct model method for \code{epidist_linelist_data} objects +} +\seealso{ +Other naive_model: +\code{\link{as_epidist_naive_model}()}, +\code{\link{is_epidist_naive_model}()}, +\code{\link{new_epidist_naive_model}()} +} +\concept{naive_model} diff --git a/man/as_latent_individual.Rd b/man/as_latent_individual.Rd deleted file mode 100644 index d69065ccd..000000000 --- a/man/as_latent_individual.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/latent_individual.R -\name{as_latent_individual} -\alias{as_latent_individual} -\title{Prepare latent individual model} -\usage{ -as_latent_individual(data) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} -} -\description{ -Prepare latent individual model -} -\seealso{ -Other latent_individual: -\code{\link{epidist_family_model.epidist_latent_individual}()}, -\code{\link{epidist_formula_model.epidist_latent_individual}()}, -\code{\link{is_direct_model}()}, -\code{\link{is_latent_individual}()} -} -\concept{latent_individual} diff --git a/man/assert_epidist.Rd b/man/assert_epidist.Rd new file mode 100644 index 000000000..64a11b4e5 --- /dev/null +++ b/man/assert_epidist.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/assert_epidist.R +\name{assert_epidist} +\alias{assert_epidist} +\title{Validation for epidist objects} +\usage{ +assert_epidist(data, ...) +} +\arguments{ +\item{data}{Object to validate} + +\item{...}{Additional arguments} +} +\value{ +NULL invisibly +} +\description{ +Validation for epidist objects +} +\concept{assert} diff --git a/man/assert_epidist.epidist_linelist_data.Rd b/man/assert_epidist.epidist_linelist_data.Rd new file mode 100644 index 000000000..7a3bc5efc --- /dev/null +++ b/man/assert_epidist.epidist_linelist_data.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linelist_data.R +\name{assert_epidist.epidist_linelist_data} +\alias{assert_epidist.epidist_linelist_data} +\title{Assert validity of \code{epidist_linelist_data} objects} +\usage{ +\method{assert_epidist}{epidist_linelist_data}(data, ...) +} +\arguments{ +\item{data}{An object to check} + +\item{...}{Additional arguments} +} +\description{ +Assert validity of \code{epidist_linelist_data} objects +} +\seealso{ +Other linelist_data: +\code{\link{as_epidist_linelist_data}()}, +\code{\link{as_epidist_linelist_data.data.frame}()}, +\code{\link{as_epidist_linelist_data.default}()}, +\code{\link{is_epidist_linelist_data}()}, +\code{\link{new_epidist_linelist_data}()} +} +\concept{linelist_data} diff --git a/man/epidist_family_model.epidist_latent_individual.Rd b/man/epidist_family_model.epidist_latent_model.Rd similarity index 51% rename from man/epidist_family_model.epidist_latent_individual.Rd rename to man/epidist_family_model.epidist_latent_model.Rd index b73050a74..32e7da2e7 100644 --- a/man/epidist_family_model.epidist_latent_individual.Rd +++ b/man/epidist_family_model.epidist_latent_model.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/latent_individual.R -\name{epidist_family_model.epidist_latent_individual} -\alias{epidist_family_model.epidist_latent_individual} +% Please edit documentation in R/latent_model.R +\name{epidist_family_model.epidist_latent_model} +\alias{epidist_family_model.epidist_latent_model} \title{Create the model-specific component of an \code{epidist} custom family} \usage{ -\method{epidist_family_model}{epidist_latent_individual}(data, family, ...) +\method{epidist_family_model}{epidist_latent_model}(data, family, ...) } \arguments{ \item{data}{A \code{data.frame} containing line list data.} @@ -18,10 +18,10 @@ information as provided by \code{.add_dpar_info()}} Create the model-specific component of an \code{epidist} custom family } \seealso{ -Other latent_individual: -\code{\link{as_latent_individual}()}, -\code{\link{epidist_formula_model.epidist_latent_individual}()}, -\code{\link{is_direct_model}()}, -\code{\link{is_latent_individual}()} +Other latent_model: +\code{\link{as_epidist_latent_model}()}, +\code{\link{epidist_formula_model.epidist_latent_model}()}, +\code{\link{is_epidist_latent_model}()}, +\code{\link{new_epidist_latent_model}()} } -\concept{latent_individual} +\concept{latent_model} diff --git a/man/epidist_formula_model.epidist_latent_individual.Rd b/man/epidist_formula_model.epidist_latent_individual.Rd deleted file mode 100644 index 4830098ee..000000000 --- a/man/epidist_formula_model.epidist_latent_individual.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/latent_individual.R -\name{epidist_formula_model.epidist_latent_individual} -\alias{epidist_formula_model.epidist_latent_individual} -\title{Define the model-specific component of an \code{epidist} custom formula} -\usage{ -\method{epidist_formula_model}{epidist_latent_individual}(data, formula, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} - -\item{formula}{As produced by \code{\link[brms:brmsformula]{brms::brmsformula()}}} - -\item{...}{...} -} -\description{ -Define the model-specific component of an \code{epidist} custom formula -} -\seealso{ -Other latent_individual: -\code{\link{as_latent_individual}()}, -\code{\link{epidist_family_model.epidist_latent_individual}()}, -\code{\link{is_direct_model}()}, -\code{\link{is_latent_individual}()} -} -\concept{latent_individual} diff --git a/man/epidist_formula_model.epidist_latent_model.Rd b/man/epidist_formula_model.epidist_latent_model.Rd new file mode 100644 index 000000000..a1fcced3e --- /dev/null +++ b/man/epidist_formula_model.epidist_latent_model.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/latent_model.R +\name{epidist_formula_model.epidist_latent_model} +\alias{epidist_formula_model.epidist_latent_model} +\title{Define the model-specific component of an \code{epidist} custom formula} +\usage{ +\method{epidist_formula_model}{epidist_latent_model}(data, formula, ...) +} +\arguments{ +\item{data}{A \code{data.frame} containing line list data} + +\item{formula}{As produced by \code{\link[brms:brmsformula]{brms::brmsformula()}}} + +\item{...}{...} +} +\description{ +Define the model-specific component of an \code{epidist} custom formula +} +\seealso{ +Other latent_model: +\code{\link{as_epidist_latent_model}()}, +\code{\link{epidist_family_model.epidist_latent_model}()}, +\code{\link{is_epidist_latent_model}()}, +\code{\link{new_epidist_latent_model}()} +} +\concept{latent_model} diff --git a/man/epidist_validate_data.Rd b/man/epidist_validate_data.Rd deleted file mode 100644 index f819f796c..000000000 --- a/man/epidist_validate_data.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/validate.R -\name{epidist_validate_data} -\alias{epidist_validate_data} -\title{Validate data class} -\usage{ -epidist_validate_data(data, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data.} - -\item{...}{Additional arguments} -} -\description{ -Validate data class -} -\seealso{ -Other validate: -\code{\link{epidist_validate_data.default}()}, -\code{\link{epidist_validate_model}()}, -\code{\link{epidist_validate_model.default}()} -} -\concept{validate} diff --git a/man/epidist_validate_data.default.Rd b/man/epidist_validate_data.default.Rd deleted file mode 100644 index 476d853eb..000000000 --- a/man/epidist_validate_data.default.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/validate.R -\name{epidist_validate_data.default} -\alias{epidist_validate_data.default} -\title{Default method for validate data class} -\usage{ -\method{epidist_validate_data}{default}(data, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data.} - -\item{...}{Additional arguments} -} -\description{ -Default method for validate data class -} -\seealso{ -Other validate: -\code{\link{epidist_validate_data}()}, -\code{\link{epidist_validate_model}()}, -\code{\link{epidist_validate_model.default}()} -} -\concept{validate} diff --git a/man/epidist_validate_data.epidist_linelist.Rd b/man/epidist_validate_data.epidist_linelist.Rd deleted file mode 100644 index e2bbf12dc..000000000 --- a/man/epidist_validate_data.epidist_linelist.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/preprocess.R -\name{epidist_validate_data.epidist_linelist} -\alias{epidist_validate_data.epidist_linelist} -\title{Validation for the \code{epidist_linelist} class} -\usage{ -\method{epidist_validate_data}{epidist_linelist}(data, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} - -\item{...}{Additional arguments} -} -\description{ -Validation for the \code{epidist_linelist} class -} -\seealso{ -Other preprocess: -\code{\link{as_epidist_linelist}()}, -\code{\link{is_epidist_linelist}()} -} -\concept{preprocess} diff --git a/man/epidist_validate_model.Rd b/man/epidist_validate_model.Rd deleted file mode 100644 index e6ee95b30..000000000 --- a/man/epidist_validate_model.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/validate.R -\name{epidist_validate_model} -\alias{epidist_validate_model} -\title{Validate model class} -\usage{ -epidist_validate_model(data, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data.} - -\item{...}{Additional arguments} -} -\description{ -Validate model class -} -\seealso{ -Other validate: -\code{\link{epidist_validate_data}()}, -\code{\link{epidist_validate_data.default}()}, -\code{\link{epidist_validate_model.default}()} -} -\concept{validate} diff --git a/man/epidist_validate_model.default.Rd b/man/epidist_validate_model.default.Rd deleted file mode 100644 index b34743e5f..000000000 --- a/man/epidist_validate_model.default.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/validate.R -\name{epidist_validate_model.default} -\alias{epidist_validate_model.default} -\title{Default method for validate model class} -\usage{ -\method{epidist_validate_model}{default}(data, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data.} - -\item{...}{Additional arguments} -} -\description{ -Default method for validate model class -} -\seealso{ -Other validate: -\code{\link{epidist_validate_data}()}, -\code{\link{epidist_validate_data.default}()}, -\code{\link{epidist_validate_model}()} -} -\concept{validate} diff --git a/man/is_direct_model.Rd b/man/is_direct_model.Rd deleted file mode 100644 index fbeea635c..000000000 --- a/man/is_direct_model.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/direct_model.R -\name{is_direct_model} -\alias{is_direct_model} -\title{Check if data has the \code{epidist_direct_model} class} -\usage{ -is_direct_model(data) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} -} -\description{ -Check if data has the \code{epidist_direct_model} class -} -\seealso{ -Other latent_individual: -\code{\link{as_latent_individual}()}, -\code{\link{epidist_family_model.epidist_latent_individual}()}, -\code{\link{epidist_formula_model.epidist_latent_individual}()}, -\code{\link{is_latent_individual}()} -} -\concept{latent_individual} diff --git a/man/is_epidist_latent_model.Rd b/man/is_epidist_latent_model.Rd new file mode 100644 index 000000000..bc02f76f2 --- /dev/null +++ b/man/is_epidist_latent_model.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/latent_model.R +\name{is_epidist_latent_model} +\alias{is_epidist_latent_model} +\title{Check if data has the \code{epidist_latent_model} class} +\usage{ +is_epidist_latent_model(data) +} +\arguments{ +\item{data}{A \code{data.frame} containing line list data} +} +\description{ +Check if data has the \code{epidist_latent_model} class +} +\seealso{ +Other latent_model: +\code{\link{as_epidist_latent_model}()}, +\code{\link{epidist_family_model.epidist_latent_model}()}, +\code{\link{epidist_formula_model.epidist_latent_model}()}, +\code{\link{new_epidist_latent_model}()} +} +\concept{latent_model} diff --git a/man/is_epidist_linelist.Rd b/man/is_epidist_linelist.Rd deleted file mode 100644 index f1590ad4c..000000000 --- a/man/is_epidist_linelist.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/preprocess.R -\name{is_epidist_linelist} -\alias{is_epidist_linelist} -\title{Check if data has the \code{epidist_linelist} class} -\usage{ -is_epidist_linelist(data, ...) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} - -\item{...}{Additional arguments} -} -\description{ -Check if data has the \code{epidist_linelist} class -} -\seealso{ -Other preprocess: -\code{\link{as_epidist_linelist}()}, -\code{\link{epidist_validate_data.epidist_linelist}()} -} -\concept{preprocess} diff --git a/man/is_epidist_linelist_data.Rd b/man/is_epidist_linelist_data.Rd new file mode 100644 index 000000000..2a193a81d --- /dev/null +++ b/man/is_epidist_linelist_data.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linelist_data.R +\name{is_epidist_linelist_data} +\alias{is_epidist_linelist_data} +\title{Check if data has the \code{epidist_linelist_data} class} +\usage{ +is_epidist_linelist_data(data, ...) +} +\arguments{ +\item{data}{The data to convert} + +\item{...}{Additional arguments} +} +\description{ +Check if data has the \code{epidist_linelist_data} class +} +\seealso{ +Other linelist_data: +\code{\link{as_epidist_linelist_data}()}, +\code{\link{as_epidist_linelist_data.data.frame}()}, +\code{\link{as_epidist_linelist_data.default}()}, +\code{\link{assert_epidist.epidist_linelist_data}()}, +\code{\link{new_epidist_linelist_data}()} +} +\concept{linelist_data} diff --git a/man/is_epidist_naive_model.Rd b/man/is_epidist_naive_model.Rd new file mode 100644 index 000000000..391f17823 --- /dev/null +++ b/man/is_epidist_naive_model.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/naive_model.R +\name{is_epidist_naive_model} +\alias{is_epidist_naive_model} +\title{Check if data has the \code{epidist_naive_model} class} +\usage{ +is_epidist_naive_model(data) +} +\arguments{ +\item{data}{A \code{data.frame} containing line list data} +} +\description{ +Check if data has the \code{epidist_naive_model} class +} +\seealso{ +Other naive_model: +\code{\link{as_epidist_naive_model}()}, +\code{\link{as_epidist_naive_model.epidist_linelist_data}()}, +\code{\link{new_epidist_naive_model}()} +} +\concept{naive_model} diff --git a/man/is_latent_individual.Rd b/man/is_latent_individual.Rd deleted file mode 100644 index 94fb1428b..000000000 --- a/man/is_latent_individual.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/latent_individual.R -\name{is_latent_individual} -\alias{is_latent_individual} -\title{Check if data has the \code{epidist_latent_individual} class} -\usage{ -is_latent_individual(data) -} -\arguments{ -\item{data}{A \code{data.frame} containing line list data} -} -\description{ -Check if data has the \code{epidist_latent_individual} class -} -\seealso{ -Other latent_individual: -\code{\link{as_latent_individual}()}, -\code{\link{epidist_family_model.epidist_latent_individual}()}, -\code{\link{epidist_formula_model.epidist_latent_individual}()}, -\code{\link{is_direct_model}()} -} -\concept{latent_individual} diff --git a/man/new_epidist_latent_model.Rd b/man/new_epidist_latent_model.Rd new file mode 100644 index 000000000..df7f754f4 --- /dev/null +++ b/man/new_epidist_latent_model.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/latent_model.R +\name{new_epidist_latent_model} +\alias{new_epidist_latent_model} +\title{Class constructor for \code{epidist_latent_model} objects} +\usage{ +new_epidist_latent_model(data) +} +\arguments{ +\item{data}{A data.frame to convert} +} +\value{ +An object of class \code{epidist_latent_model} +} +\description{ +Class constructor for \code{epidist_latent_model} objects +} +\seealso{ +Other latent_model: +\code{\link{as_epidist_latent_model}()}, +\code{\link{epidist_family_model.epidist_latent_model}()}, +\code{\link{epidist_formula_model.epidist_latent_model}()}, +\code{\link{is_epidist_latent_model}()} +} +\concept{latent_model} diff --git a/man/new_epidist_linelist_data.Rd b/man/new_epidist_linelist_data.Rd new file mode 100644 index 000000000..166fb9590 --- /dev/null +++ b/man/new_epidist_linelist_data.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/linelist_data.R +\name{new_epidist_linelist_data} +\alias{new_epidist_linelist_data} +\title{Class constructor for \code{epidist_linelist_data} objects} +\usage{ +new_epidist_linelist_data(data) +} +\arguments{ +\item{data}{A data.frame to convert} +} +\value{ +An object of class \code{epidist_linelist_data} +} +\description{ +Class constructor for \code{epidist_linelist_data} objects +} +\seealso{ +Other linelist_data: +\code{\link{as_epidist_linelist_data}()}, +\code{\link{as_epidist_linelist_data.data.frame}()}, +\code{\link{as_epidist_linelist_data.default}()}, +\code{\link{assert_epidist.epidist_linelist_data}()}, +\code{\link{is_epidist_linelist_data}()} +} +\concept{linelist_data} diff --git a/man/new_epidist_naive_model.Rd b/man/new_epidist_naive_model.Rd new file mode 100644 index 000000000..95bdce719 --- /dev/null +++ b/man/new_epidist_naive_model.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/naive_model.R +\name{new_epidist_naive_model} +\alias{new_epidist_naive_model} +\title{Class constructor for \code{epidist_naive_model} objects} +\usage{ +new_epidist_naive_model(data) +} +\arguments{ +\item{data}{A data.frame to convert} +} +\value{ +An object of class \code{epidist_naive_model} +} +\description{ +Class constructor for \code{epidist_naive_model} objects +} +\seealso{ +Other naive_model: +\code{\link{as_epidist_naive_model}()}, +\code{\link{as_epidist_naive_model.epidist_linelist_data}()}, +\code{\link{is_epidist_naive_model}()} +} +\concept{naive_model} diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index eeca9f54b..d285b1464 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,11 +1,5 @@ set.seed(101) -as_epidist_linelist_time <- function(data) { - class(data) <- c("epidist_linelist", class(data)) - epidist_validate_data(data) - return(data) -} - obs_time <- 25 sample_size <- 500 @@ -25,7 +19,13 @@ sim_obs <- simulate_gillespie() |> dplyr::slice_sample(n = sample_size, replace = FALSE) # Temporary solution for classing time data -sim_obs <- as_epidist_linelist_time(sim_obs) +sim_obs <- as_epidist_linelist_data( + sim_obs$ptime_lwr, + sim_obs$ptime_upr, + sim_obs$stime_lwr, + sim_obs$stime_upr, + sim_obs$obs_time +) set.seed(101) @@ -46,7 +46,13 @@ sim_obs_gamma <- simulate_gillespie() |> dplyr::slice_sample(n = sample_size, replace = FALSE) # Temporary solution for classing time data -sim_obs_gamma <- as_epidist_linelist_time(sim_obs_gamma) +sim_obs_gamma <- as_epidist_linelist_data( + sim_obs_gamma$ptime_lwr, + sim_obs_gamma$ptime_upr, + sim_obs_gamma$stime_lwr, + sim_obs_gamma$stime_upr, + sim_obs_gamma$obs_time +) # Data with a sex difference @@ -81,12 +87,19 @@ sim_obs_sex <- dplyr::bind_rows(sim_obs_sex_m, sim_obs_sex_f) |> dplyr::slice_sample(n = sample_size, replace = FALSE) # Temporary solution for classing time data -sim_obs_sex <- as_epidist_linelist_time(sim_obs_sex) - -prep_obs <- as_latent_individual(sim_obs) -prep_direct_obs <- as_direct_model(sim_obs) -prep_obs_gamma <- as_latent_individual(sim_obs_gamma) -prep_obs_sex <- as_latent_individual(sim_obs_sex) +sim_obs_sex <- as_epidist_linelist_data( + sim_obs_sex$ptime_lwr, + sim_obs_sex$ptime_upr, + sim_obs_sex$stime_lwr, + sim_obs_sex$stime_upr, + sim_obs_sex$obs_time, + sex = sim_obs_sex$sex +) + +prep_obs <- as_epidist_latent_model(sim_obs) +prep_direct_obs <- as_epidist_naive_model(sim_obs) +prep_obs_gamma <- as_epidist_latent_model(sim_obs_gamma) +prep_obs_sex <- as_epidist_latent_model(sim_obs_sex) if (not_on_cran()) { set.seed(1) diff --git a/tests/testthat/test-diagnostics.R b/tests/testthat/test-diagnostics.R index c1c127f07..dd730df60 100644 --- a/tests/testthat/test-diagnostics.R +++ b/tests/testthat/test-diagnostics.R @@ -41,7 +41,7 @@ test_that("epidist_diagnostics gives the same results for cmdstanr and rstan", { test_that("epidist_diagnostics gives an error when passed model fit using the Laplace algorithm", { # nolint: line_length_linter. skip_on_cran() set.seed(1) - prep_obs <- as_latent_individual(sim_obs) + prep_obs <- as_epidist_latent_model(sim_obs) fit_laplace <- epidist( data = prep_obs, seed = 1, algorithm = "laplace", backend = "cmdstanr", refresh = 0, silent = 2, show_messages = FALSE diff --git a/tests/testthat/test-direct_model.R b/tests/testthat/test-direct_model.R deleted file mode 100644 index 17c8c2efa..000000000 --- a/tests/testthat/test-direct_model.R +++ /dev/null @@ -1,50 +0,0 @@ -test_that("as_direct_model.data.frame with default settings an object with the correct classes", { # nolint: line_length_linter. - prep_obs <- as_direct_model(sim_obs) - expect_s3_class(prep_obs, "data.frame") - expect_s3_class(prep_obs, "epidist_direct_model") -}) - -test_that("as_direct_model.data.frame errors when passed incorrect inputs", { # nolint: line_length_linter. - expect_error(as_direct_model(list())) - expect_error(as_direct_model(sim_obs[, 1])) - expect_error({ - sim_obs$case <- paste("case_", seq_len(nrow(sim_obs))) - as_direct_model(sim_obs) - }) -}) - -# Make this data available for other tests -prep_obs <- as_direct_model(sim_obs) -family_lognormal <- epidist_family(prep_obs, family = brms::lognormal()) - -test_that("is_direct_model returns TRUE for correct input", { # nolint: line_length_linter. - expect_true(is_direct_model(prep_obs)) - expect_true({ - x <- list() - class(x) <- "epidist_direct_model" - is_direct_model(x) - }) -}) - -test_that("is_direct_model returns FALSE for incorrect input", { # nolint: line_length_linter. - expect_false(is_direct_model(list())) - expect_false({ - x <- list() - class(x) <- "epidist_direct_model_extension" - is_direct_model(x) - }) -}) - -test_that("epidist_validate_model.epidist_direct_model doesn't produce an error for correct input", { # nolint: line_length_linter. - expect_no_error(epidist_validate_model(prep_obs)) -}) - -test_that("epidist_validate_model.epidist_direct_model returns FALSE for incorrect input", { # nolint: line_length_linter. - expect_error(epidist_validate_model(list())) - expect_error(epidist_validate_model(prep_obs[, 1])) - expect_error({ - x <- list() - class(x) <- "epidist_direct_model" - epidist_validate_model(x) - }) -}) diff --git a/tests/testthat/test-formula.R b/tests/testthat/test-formula.R index ddb1eb668..9bda32d4c 100644 --- a/tests/testthat/test-formula.R +++ b/tests/testthat/test-formula.R @@ -1,4 +1,4 @@ -prep_obs_gamma <- as_latent_individual(sim_obs_gamma) +prep_obs_gamma <- as_epidist_latent_model(sim_obs_gamma) family_lognormal <- epidist_family(prep_obs, family = brms::lognormal()) diff --git a/tests/testthat/test-int-direct_model.R b/tests/testthat/test-int-direct_model.R index f1f49aefd..a2651e525 100644 --- a/tests/testthat/test-int-direct_model.R +++ b/tests/testthat/test-int-direct_model.R @@ -4,7 +4,7 @@ # varying the input seed. Test failure at an unusually high rate does suggest # a potential code issue. -test_that("epidist.epidist_direct_model Stan code has no syntax errors in the default case", { # nolint: line_length_linter. +test_that("epidist.epidist_naive_model Stan code has no syntax errors in the default case", { # nolint: line_length_linter. skip_on_cran() stancode <- epidist( data = prep_direct_obs, @@ -16,7 +16,7 @@ test_that("epidist.epidist_direct_model Stan code has no syntax errors in the de expect_true(mod$check_syntax()) }) -test_that("epidist.epidist_direct_model fits and the MCMC converges in the default case", { # nolint: line_length_linter. +test_that("epidist.epidist_naive_model fits and the MCMC converges in the default case", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -25,7 +25,8 @@ test_that("epidist.epidist_direct_model fits and the MCMC converges in the defau seed = 1, silent = 2, refresh = 0, cores = 2, - chains = 2 + chains = 2, + backend = "cmdstanr" ) expect_s3_class(fit, "brmsfit") expect_s3_class(fit, "epidist_fit") diff --git a/tests/testthat/test-int-latent_individual.R b/tests/testthat/test-int-latent_model.R similarity index 76% rename from tests/testthat/test-int-latent_individual.R rename to tests/testthat/test-int-latent_model.R index 04c249583..db269ffe1 100644 --- a/tests/testthat/test-int-latent_individual.R +++ b/tests/testthat/test-int-latent_model.R @@ -4,7 +4,7 @@ # varying the input seed. Test failure at an unusually high rate does suggest # a potential code issue. -test_that("epidist.epidist_latent_individual Stan code has no syntax errors in the default case", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model Stan code has no syntax errors in the default case", { # nolint: line_length_linter. skip_on_cran() stancode <- epidist( data = prep_obs, @@ -16,7 +16,7 @@ test_that("epidist.epidist_latent_individual Stan code has no syntax errors in t expect_true(mod$check_syntax()) }) -test_that("epidist.epidist_latent_individual samples from the prior according to marginal Kolmogorov-Smirnov tests in the default case.", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model samples from the prior according to marginal Kolmogorov-Smirnov tests in the default case.", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -53,7 +53,7 @@ test_that("epidist.epidist_latent_individual samples from the prior according to testthat::expect_gt(ks2$p.value, 0.01) }) -test_that("epidist.epidist_latent_individual fits and the MCMC converges in the default case", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model fits and the MCMC converges in the default case", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() expect_s3_class(fit, "brmsfit") @@ -61,7 +61,7 @@ test_that("epidist.epidist_latent_individual fits and the MCMC converges in the expect_convergence(fit) }) -test_that("epidist.epidist_latent_individual fits, the MCMC converges, and the draws of sigma are indeed a constant, when setting sigma = 1 (a constant)", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model fits, the MCMC converges, and the draws of sigma are indeed a constant, when setting sigma = 1 (a constant)", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -80,7 +80,7 @@ test_that("epidist.epidist_latent_individual fits, the MCMC converges, and the d expect_true(all(sigma == 1)) }) -test_that("epidist.epidist_latent_individual Stan code has no syntax errors", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model Stan code has no syntax errors", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -97,7 +97,7 @@ test_that("epidist.epidist_latent_individual Stan code has no syntax errors", { expect_true(mod_string$check_syntax()) }) -test_that("epidist.epidist_latent_individual recovers the simulation settings for the delay distribution in the default case", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model recovers the simulation settings for the delay distribution in the default case", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -107,7 +107,7 @@ test_that("epidist.epidist_latent_individual recovers the simulation settings fo expect_equal(mean(pred$sigma), sdlog, tolerance = 0.1) }) -test_that("epidist.epidist_latent_individual Stan code has no syntax errors and compiles in the gamma delay case", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model Stan code has no syntax errors and compiles in the gamma delay case", { # nolint: line_length_linter. skip_on_cran() stancode_gamma <- epidist( data = prep_obs_gamma, @@ -123,7 +123,7 @@ test_that("epidist.epidist_latent_individual Stan code has no syntax errors and expect_no_error(mod_gamma$compile()) }) -test_that("epidist.epidist_latent_individual fits and the MCMC converges in the gamma delay case", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model fits and the MCMC converges in the gamma delay case", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -132,7 +132,7 @@ test_that("epidist.epidist_latent_individual fits and the MCMC converges in the expect_convergence(fit_gamma) }) -test_that("epidist.epidist_latent_individual recovers the simulation settings for the delay distribution in the gamma delay case", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model recovers the simulation settings for the delay distribution in the gamma delay case", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) @@ -149,7 +149,7 @@ test_that("epidist.epidist_latent_individual recovers the simulation settings fo expect_lte(quantile_shape, 0.975) }) -test_that("epidist.epidist_latent_individual Stan code has no syntax errors for an alternative formula", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model Stan code has no syntax errors for an alternative formula", { # nolint: line_length_linter. skip_on_cran() stancode_sex <- epidist( data = prep_obs_sex, @@ -163,7 +163,7 @@ test_that("epidist.epidist_latent_individual Stan code has no syntax errors for expect_true(mod_sex$check_syntax()) }) -test_that("epidist.epidist_latent_individual recovers a sex effect", { # nolint: line_length_linter. +test_that("epidist.epidist_latent_model recovers a sex effect", { # nolint: line_length_linter. # Note: this test is stochastic. See note at the top of this script skip_on_cran() set.seed(1) diff --git a/tests/testthat/test-latent_individual.R b/tests/testthat/test-latent_individual.R deleted file mode 100644 index c0fb78186..000000000 --- a/tests/testthat/test-latent_individual.R +++ /dev/null @@ -1,59 +0,0 @@ -test_that("as_latent_individual.epidist_linelist with default settings an object with the correct classes", { # nolint: line_length_linter. - prep_obs <- as_latent_individual(sim_obs) - expect_s3_class(prep_obs, "data.frame") - expect_s3_class(prep_obs, "epidist_latent_individual") -}) - -test_that("as_latent_individual.epidist_linelist errors when passed incorrect inputs", { # nolint: line_length_linter. - expect_error(as_latent_individual(list())) - expect_error(as_latent_individual(sim_obs[, 1])) -}) - -# Make this data available for other tests -prep_obs <- as_latent_individual(sim_obs) -family_lognormal <- epidist_family(prep_obs, family = brms::lognormal()) - -test_that("is_latent_individual returns TRUE for correct input", { # nolint: line_length_linter. - expect_true(is_latent_individual(prep_obs)) - expect_true({ - x <- list() - class(x) <- "epidist_latent_individual" - is_latent_individual(x) - }) -}) - -test_that("is_latent_individual returns FALSE for incorrect input", { # nolint: line_length_linter. - expect_false(is_latent_individual(list())) - expect_false({ - x <- list() - class(x) <- "epidist_latent_individual_extension" - is_latent_individual(x) - }) -}) - -test_that("epidist_validate_model.epidist_latent_individual doesn't produce an error for correct input", { # nolint: line_length_linter. - expect_no_error(epidist_validate_model(prep_obs)) -}) - -test_that("epidist_validate.epidist_latent_individual returns FALSE for incorrect input", { # nolint: line_length_linter. - expect_error(epidist_validate(list())) - expect_error(epidist_validate(prep_obs[, 1])) - expect_error({ - x <- list() - class(x) <- "epidist_latent_individual" - epidist_validate(x) - }) -}) - -test_that("epidist_stancode.epidist_latent_individual produces valid stanvars", { # nolint: line_length_linter. - epidist_family <- epidist_family(prep_obs) - epidist_formula <- epidist_formula( - prep_obs, epidist_family, - formula = brms::bf(mu ~ 1) - ) - stancode <- epidist_stancode( - prep_obs, - family = epidist_family, formula = epidist_formula - ) - expect_s3_class(stancode, "stanvars") -}) diff --git a/tests/testthat/test-latent_model.R b/tests/testthat/test-latent_model.R new file mode 100644 index 000000000..357008fde --- /dev/null +++ b/tests/testthat/test-latent_model.R @@ -0,0 +1,58 @@ +test_that("as_epidist_latent_model.epidist_linelist_data with default settings an object with the correct classes", { # nolint: line_length_linter. + prep_obs <- as_epidist_latent_model(sim_obs) + expect_s3_class(prep_obs, "data.frame") + expect_s3_class(prep_obs, "epidist_latent_model") +}) + +test_that("as_epidist_latent_model.epidist_linelist_data errors when passed incorrect inputs", { # nolint: line_length_linter. + expect_error(as_epidist_latent_model(list())) + expect_error(as_epidist_latent_model(sim_obs[, 1])) +}) + +# Make this data available for other tests +family_lognormal <- epidist_family(prep_obs, family = brms::lognormal()) + +test_that("is_epidist_latent_model returns TRUE for correct input", { # nolint: line_length_linter. + expect_true(is_epidist_latent_model(prep_obs)) + expect_true({ + x <- list() + class(x) <- "epidist_latent_model" + is_epidist_latent_model(x) + }) +}) + +test_that("is_epidist_latent_model returns FALSE for incorrect input", { # nolint: line_length_linter. + expect_false(is_epidist_latent_model(list())) + expect_false({ + x <- list() + class(x) <- "epidist_latent_model_extension" + is_epidist_latent_model(x) + }) +}) + +test_that("assert_epidist.epidist_latent_model doesn't produce an error for correct input", { # nolint: line_length_linter. + expect_no_error(assert_epidist(prep_obs)) +}) + +test_that("assert_epidist.epidist_latent_model returns FALSE for incorrect input", { # nolint: line_length_linter. + expect_error(assert_epidist(list())) + expect_error(assert_epidist(prep_obs[, 1])) + expect_error({ + x <- list() + class(x) <- "epidist_latent_model" + assert_epidist(x) + }) +}) + +test_that("epidist_stancode.epidist_latent_model produces valid stanvars", { # nolint: line_length_linter. + epidist_family <- epidist_family(prep_obs) + epidist_formula <- epidist_formula( + prep_obs, epidist_family, + formula = brms::bf(mu ~ 1) + ) + stancode <- epidist_stancode( + prep_obs, + family = epidist_family, formula = epidist_formula + ) + expect_s3_class(stancode, "stanvars") +}) diff --git a/tests/testthat/test-linelist_data.R b/tests/testthat/test-linelist_data.R new file mode 100644 index 000000000..c2e94e21c --- /dev/null +++ b/tests/testthat/test-linelist_data.R @@ -0,0 +1,115 @@ +test_that( + "as_epidist_linelist_data assigns epidist_linelist_data class to data", { + data <- data.frame( + case = 1, + pdate_lwr = as.POSIXct("2023-01-01 00:00:00"), + pdate_upr = as.POSIXct("2023-01-02 00:00:00"), + sdate_lwr = as.POSIXct("2023-01-03 00:00:00"), + sdate_upr = as.POSIXct("2023-01-04 00:00:00"), + obs_date = as.POSIXct("2023-01-05 00:00:00") + ) + linelist_data <- suppressMessages(as_epidist_linelist_data( + data, "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" + )) + expect_s3_class(linelist_data, "epidist_linelist_data") +}) + +test_that("as_epidist_linelist_data correctly renames columns", { + data <- data.frame( + case = 1, + p_lower = as.POSIXct("2023-01-01"), + p_upper = as.POSIXct("2023-01-02"), + s_lower = as.POSIXct("2023-01-03"), + s_upper = as.POSIXct("2023-01-04"), + observation = as.POSIXct("2023-01-05") + ) + linelist_data <- suppressMessages(as_epidist_linelist_data( + data, "p_lower", "p_upper", "s_lower", "s_upper", "observation" + )) + col_names <- c("pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date") + expect_true(all(col_names %in% names(linelist_data))) +}) + +test_that("as_epidist_linelist_data works with dates", { + data <- data.frame( + case = 1, + pdate_lwr = as.Date("2023-01-01"), + pdate_upr = as.Date("2023-01-02"), + sdate_lwr = as.Date("2023-01-03"), + sdate_upr = as.Date("2023-01-04"), + obs_date = as.Date("2023-01-05") + ) + expect_no_error( + suppressMessages(as_epidist_linelist_data( + data, "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" + )) + ) +}) + +test_that("as_epidist_linelist_data works with default column names", { + data <- data.frame( + case = 1, + pdate_lwr = as.Date("2023-01-01"), + sdate_lwr = as.Date("2023-01-03") + ) + linelist_data <- suppressMessages(as_epidist_linelist_data(data)) + expect_s3_class(linelist_data, "epidist_linelist_data") + expect_true( + all( + c( + "ptime_lwr", "ptime_upr", "stime_lwr", "stime_upr", "obs_time" + ) %in% names(linelist_data) + ) + ) +}) + +test_that("as_epidist_linelist_data adds default upper bounds", { + data <- data.frame( + pdate_lwr = as.Date("2023-01-01"), + sdate_lwr = as.Date("2023-01-03") + ) + linelist_data <- suppressMessages(as_epidist_linelist_data(data)) + expect_identical( + as.Date(linelist_data$pdate_upr), + as.Date("2023-01-02") + ) + expect_identical( + as.Date(linelist_data$sdate_upr), + as.Date("2023-01-04") + ) +}) + +test_that("as_epidist_linelist_data uses max secondary date as obs_date", { + data <- data.frame( + pdate_lwr = as.Date("2023-01-01"), + sdate_lwr = as.Date("2023-01-03") + ) + linelist_data <- suppressMessages(as_epidist_linelist_data(data)) + expect_identical( + as.Date(linelist_data$obs_date), + as.Date("2023-01-04") + ) +}) + +test_that("as_epidist_linelist_data errors without required columns", { + data <- data.frame( + case = 1, + some_date = as.Date("2023-01-01") + ) + expect_error( + suppressMessages(as_epidist_linelist_data(data)), + "`pdate_lwr` is NULL but must be provided" + ) +}) + +test_that("as_epidist_linelist_data preserves additional columns", { + data <- data.frame( + case = 1, + pdate_lwr = as.Date("2023-01-01"), + sdate_lwr = as.Date("2023-01-03"), + extra_col = "test" + ) + linelist_data <- suppressMessages(as_epidist_linelist_data(data)) + expect_true("extra_col" %in% names(linelist_data)) + expect_identical(linelist_data$extra_col, "test") +}) diff --git a/tests/testthat/test-naive_model.R b/tests/testthat/test-naive_model.R new file mode 100644 index 000000000..0c24e011c --- /dev/null +++ b/tests/testthat/test-naive_model.R @@ -0,0 +1,45 @@ +test_that("as_epidist_naive_model.data.frame with default settings an object with the correct classes", { # nolint: line_length_linter. + prep_obs <- as_epidist_naive_model(sim_obs) + expect_s3_class(prep_obs, "data.frame") + expect_s3_class(prep_obs, "epidist_naive_model") +}) + +test_that("as_epidist_naive_model.data.frame errors when passed incorrect inputs", { # nolint: line_length_linter. + expect_error(as_epidist_naive_model(list())) + expect_error(as_epidist_naive_model(sim_obs[, 1])) +}) + +# Make this data available for other tests +family_lognormal <- epidist_family(sim_obs, family = brms::lognormal()) + +test_that("is_epidist_naive_model returns TRUE for correct input", { # nolint: line_length_linter. + expect_true(is_epidist_naive_model(prep_direct_obs)) + expect_true({ + x <- list() + class(x) <- "epidist_naive_model" + is_epidist_naive_model(x) + }) +}) + +test_that("is_epidist_naive_model returns FALSE for incorrect input", { # nolint: line_length_linter. + expect_false(is_epidist_naive_model(list())) + expect_false({ + x <- list() + class(x) <- "epidist_naive_model_extension" + is_epidist_naive_model(x) + }) +}) + +test_that("assert_epidist.epidist_naive_model doesn't produce an error for correct input", { # nolint: line_length_linter. + expect_no_error(assert_epidist(prep_direct_obs)) +}) + +test_that("assert_epidist.epidist_naive_model returns FALSE for incorrect input", { # nolint: line_length_linter. + expect_error(assert_epidist(list())) + expect_error(assert_epidist(prep_direct_obs[, 1])) + expect_error({ + x <- list() + class(x) <- "epidist_naive_model" + assert_epidist(x) + }) +}) diff --git a/tests/testthat/test-preprocess.R b/tests/testthat/test-preprocess.R deleted file mode 100644 index 5d29e08c3..000000000 --- a/tests/testthat/test-preprocess.R +++ /dev/null @@ -1,46 +0,0 @@ -test_that("as_epidist_linelist assigns epidist_linelist class to data", { - data <- data.frame( - case = 1, - pdate_lwr = as.POSIXct("2023-01-01 00:00:00"), - pdate_upr = as.POSIXct("2023-01-02 00:00:00"), - sdate_lwr = as.POSIXct("2023-01-03 00:00:00"), - sdate_upr = as.POSIXct("2023-01-04 00:00:00"), - obs_date = as.POSIXct("2023-01-05 00:00:00") - ) - linelist <- as_epidist_linelist( - data, "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" - ) - expect_s3_class(linelist, "epidist_linelist") -}) - -test_that("as_epidist_linelist correctly renames columns", { - data <- data.frame( - case = 1, - p_lower = as.POSIXct("2023-01-01"), - p_upper = as.POSIXct("2023-01-02"), - s_lower = as.POSIXct("2023-01-03"), - s_upper = as.POSIXct("2023-01-04"), - observation = as.POSIXct("2023-01-05") - ) - linelist <- as_epidist_linelist( - data, "p_lower", "p_upper", "s_lower", "s_upper", "observation" - ) - col_names <- c("pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date") - expect_true(all(col_names %in% names(linelist))) -}) - -test_that("as_epidist_linelist gives error if columns are not datetime", { - data <- data.frame( - case = 1, - pdate_lwr = as.Date("2023-01-01"), - pdate_upr = as.Date("2023-01-02"), - sdate_lwr = as.Date("2023-01-03"), - sdate_upr = as.Date("2023-01-04"), - obs_date = as.Date("2023-01-05") - ) - expect_error( - as_epidist_linelist( - data, "pdate_lwr", "pdate_upr", "sdate_lwr", "sdate_upr", "obs_date" - ) - ) -}) diff --git a/tests/testthat/test-prior.R b/tests/testthat/test-prior.R index 1cb50113d..fa77fba4e 100644 --- a/tests/testthat/test-prior.R +++ b/tests/testthat/test-prior.R @@ -1,5 +1,5 @@ test_that("epidist_prior with default settings produces an object of the right class", { # nolint: line_length_linter. - data <- as_latent_individual(sim_obs) + data <- as_epidist_latent_model(sim_obs) family <- brms::lognormal() formula <- brms::bf(mu ~ 1, sigma ~ 1) epidist_family <- epidist_family(data, family) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index a814d551d..77e21314e 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -39,7 +39,7 @@ test_that(".add_dpar_info works as expected for the lognormal and gamma families }) test_that(".make_intercepts_explicit creates a formula which is the same as if it had been explicitly created", { # nolint: line_length_linter. - prep_obs <- as_latent_individual(sim_obs) + prep_obs <- as_epidist_latent_model(sim_obs) epidist_family <- epidist_family(prep_obs, family = "lognormal") formula <- brms:::validate_formula( formula = brms::bf(mu ~ 1), @@ -58,7 +58,7 @@ test_that(".make_intercepts_explicit creates a formula which is the same as if i }) test_that(".make_intercepts_explicit does not add an intercept if the distributional parameter is set to be fixed", { # nolint: line_length_linter. - prep_obs <- as_latent_individual(sim_obs) + prep_obs <- as_epidist_latent_model(sim_obs) epidist_family <- epidist_family(prep_obs, family = "lognormal") formula <- brms:::validate_formula( formula = brms::bf(mu ~ 1, sigma = 1), diff --git a/vignettes/approx-inference.Rmd b/vignettes/approx-inference.Rmd index eb1eca468..004f10235 100644 --- a/vignettes/approx-inference.Rmd +++ b/vignettes/approx-inference.Rmd @@ -130,15 +130,15 @@ obs_cens_trunc_samp <- simulate_gillespie(seed = 101) |> We now prepare the data for fitting with the latent individual model, and perform inference with HMC: ```{r results='hide'} -# Note: this functionality will be integrated into the package shortly -as_epidist_linelist_time <- function(data) { - class(data) <- c("epidist_linelist", class(data)) - epidist_validate_data(data) - return(data) -} - -linelist <- as_epidist_linelist_time(obs_cens_trunc_samp) -data <- as_latent_individual(linelist) +linelist_data <- as_epidist_linelist_data( + obs_cens_trunc_samp$ptime_lwr, + obs_cens_trunc_samp$ptime_upr, + obs_cens_trunc_samp$stime_lwr, + obs_cens_trunc_samp$stime_upr, + obs_time = obs_cens_trunc_samp$obs_time +) + +data <- as_epidist_latent_model(linelist_data) t <- proc.time() fit_hmc <- epidist(data = data, algorithm = "sampling", backend = "cmdstanr") diff --git a/vignettes/ebola.Rmd b/vignettes/ebola.Rmd index 49977dd16..004f86124 100644 --- a/vignettes/ebola.Rmd +++ b/vignettes/ebola.Rmd @@ -45,6 +45,7 @@ set.seed(123) library(epidist) library(brms) +library(tibble) library(dplyr) library(purrr) library(ggplot2) @@ -163,29 +164,18 @@ That is, $\mu$ and $\sigma$ such that when $x \sim \mathcal{N}(\mu, \sigma)$ the ## Data preparation -To prepare the data, we begin by transforming the date columns to `ptime` and `stime` columns for the times of the primary and secondary events respectively. -Both of these columns are relative to the first date of symptom onset in the data: +To prepare the data, we begin by filtering for the relevant columns and converting the date columns to `Date` objects: ```{r} -sierra_leone_ebola_data <- sierra_leone_ebola_data |> +obs_cens <- sierra_leone_ebola_data |> + tibble() |> mutate( # use lubridate::ymd() to drop any sub-date time info date_of_symptom_onset = ymd(date_of_symptom_onset), date_of_sample_tested = ymd(date_of_sample_tested), - # ptime and stime represent the number of days elapsed since the earliest - # date of symptom onset in the data - ptime = as.numeric(date_of_symptom_onset - min(date_of_symptom_onset)), - stime = as.numeric(date_of_sample_tested - min(date_of_symptom_onset)) ) |> - select(case, ptime, stime, age, sex, district) - -head(sierra_leone_ebola_data) -``` - -Next, we use `observe_process()` to add interval censoring columns giving the lower and upper bounds on the primary and secondary event times: + select(case, date_of_symptom_onset, date_of_sample_tested, age, sex, district) -```{r} -obs_cens <- observe_process(sierra_leone_ebola_data) head(obs_cens) ``` @@ -211,20 +201,24 @@ obs_cens <- obs_cens |> slice_sample(n = round(n_complete * subsample), replace = FALSE) ``` +Finally, we prepare the data for use with the `epidist` package by converting the data to an `epidist_linelist_data` object: + +```{r} +linelist_data <- obs_cens |> + as_epidist_linelist_data( + pdate_lwr = "date_of_symptom_onset", + sdate_lwr = "date_of_sample_tested" + ) +``` + +Note that this has made some assumptions about the data in that it has assumed that as we did not supply upper bounds for the primary and secondary events, that the upper bounds are one day after the lower bounds. It has also assumed that the observation time is the maximum of the secondary event upper bound as we also did not supply an observation time column. + ## Model fitting -To prepare the data for use with the latent individual model, we set `obs_cens` to be an `epidist_linelist` object, then use the function `as_latent_individual()`: +To prepare the data for use with the latent individual model, we define the data as being a `epidist_latent_model` model object: ```{r} -# Note: this functionality will be integrated into the package shortly -as_epidist_linelist_time <- function(data) { - class(data) <- c("epidist_linelist", class(data)) - epidist_validate_data(data) - return(data) -} - -linelist <- as_epidist_linelist_time(obs_cens) -obs_prep <- as_latent_individual(linelist) +obs_prep <- as_epidist_latent_model(linelist_data) head(obs_prep) ``` diff --git a/vignettes/epidist.Rmd b/vignettes/epidist.Rmd index 0e680272e..a61ff05a2 100644 --- a/vignettes/epidist.Rmd +++ b/vignettes/epidist.Rmd @@ -242,24 +242,24 @@ bind_rows( theme(legend.position = "bottom") ``` -The main function you will use for modelling is called `epidist()`^[Technically, `epidist()` is an [S3 generic](http://adv-r.had.co.nz/S3.html) which allows it to work differently for inputs of different classes. This is in part why inputs must be prepared first via `as_latent_individual()` so that they are of the appropriate class!]. -We will fit the model `"latent_individual"` which uses latent variables for the time of primary and secondary event of each individual^[In a future vignette, we will explain in more detail the structure of the model!]. -To do so, we first prepare the `data` using `as_latent_individual()`: +The main function you will use for modelling is called `epidist()`^[Technically, `epidist()` is an [S3 generic](http://adv-r.had.co.nz/S3.html) which allows it to work differently for inputs of different classes. This is in part why inputs must be prepared first via `as_epidist_latent_model()` so that they are of the appropriate class!]. +We will fit the model `"epidist_latent_model"` which uses latent variables for the time of primary and secondary event of each individual^[In a future vignette, we will explain in more detail the structure of the model!]. +To do so, we first prepare the `data` using `as_epidist_latent_model()`: ```{r} -# Note: this functionality will be integrated into the package shortly -as_epidist_linelist_time <- function(data) { - class(data) <- c("epidist_linelist", class(data)) - epidist_validate_data(data) - return(data) -} - -linelist <- as_epidist_linelist_time(obs_cens_trunc_samp) -data <- as_latent_individual(linelist) +linelist_data <- as_epidist_linelist_data( + obs_cens_trunc_samp$ptime_lwr, + obs_cens_trunc_samp$ptime_upr, + obs_cens_trunc_samp$stime_lwr, + obs_cens_trunc_samp$stime_upr, + obs_time = obs_cens_trunc_samp$obs_time +) + +data <- as_epidist_latent_model(linelist_data) class(data) ``` -The `data` object now has the class `epidist_latent_individual`. +The `data` object now has the class `epidist_latent_model`. Using this `data`, we now call `epidist()` to fit the model. The parameters of the model are inferred using Bayesian inference. In particular, we use the the No-U-Turn Sampler (NUTS) Markov chain Monte Carlo (MCMC) algorithm via the [`brms`](https://paul-buerkner.github.io/brms/) R package [@brms]. diff --git a/vignettes/faq.Rmd b/vignettes/faq.Rmd index 21ba86bba..86bfe3c05 100644 --- a/vignettes/faq.Rmd +++ b/vignettes/faq.Rmd @@ -47,15 +47,14 @@ obs_cens_trunc_samp <- simulate_gillespie(seed = 101) |> filter(.data$stime_upr <= obs_time) |> slice_sample(n = sample_size, replace = FALSE) -# Note: this functionality will be integrated into the package shortly -as_epidist_linelist_time <- function(data) { - class(data) <- c("epidist_linelist", class(data)) - epidist_validate_data(data) - return(data) -} - -linelist <- as_epidist_linelist_time(obs_cens_trunc_samp) -data <- as_latent_individual(linelist) +linelist_data <- as_epidist_linelist_data( + obs_cens_trunc_samp$ptime_lwr, + obs_cens_trunc_samp$ptime_upr, + obs_cens_trunc_samp$stime_lwr, + obs_cens_trunc_samp$stime_upr, + obs_time = obs_cens_trunc_samp$obs_time +) +data <- as_epidist_latent_model(linelist_data) fit <- epidist( data, @@ -220,7 +219,7 @@ ggplot(draws_pmf, aes(x = .prediction)) + ``` Importantly, this functionality is only available for `epidist` models using custom `brms` families that have `posterior_predict` and `posterior_epred` methods implemented. -For example, for the `latent_individual` model, currently methods are implemented for the [lognormal](https://github.com/epinowcast/epidist/blob/main/R/latent_lognormal.R) and [gamma](https://github.com/epinowcast/epidist/blob/main/R/latent_gamma.R) families. +For example, for the `epidist_latent_model` model, currently methods are implemented for the [lognormal](https://github.com/epinowcast/epidist/blob/main/R/latent_lognormal.R) and [gamma](https://github.com/epinowcast/epidist/blob/main/R/latent_gamma.R) families. If you are using another family, consider [submitting a pull request](https://github.com/epinowcast/epidist/pulls) to implement these methods! In doing so, you may find it useful to use the [`primarycensored`](https://primarycensored.epinowcast.org/) package.