Issue #400: Rename to naive model and latent model

.github/workflows/check-cmdstan.yaml

@@ -62,15 +62,17 @@ 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_data <- data.frame(
+            pdate_lwr = as.POSIXct("2024-01-01 00:00:00"),
+            pdate_upr = as.POSIXct("2024-01-02 00:00:00"),
+            sdate_lwr = as.POSIXct("2024-01-03 00:00:00"),
+            sdate_upr = as.POSIXct("2024-01-04 00:00:00"),
+            obs_date  = as.POSIXct("2024-01-05 00:00:00")
           )
-          dummy_obs <- epidist::as_latent_individual(dummy_obs)
+          linelist <- epidist::as_epidist_linelist(dummy_data)
+          latent_model <- epidist::as_latent_model(linelist)
           stancode <- epidist::epidist(
-            data = dummy_obs, fn = brms::make_stancode
+            data = latent_model, fn = brms::make_stancode
           )
           mod <- cmdstanr::cmdstan_model(
             stan_file = cmdstanr::write_stan_file(stancode), compile = FALSE

NAMESPACE

@@ -3,29 +3,29 @@
 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_latent_model,epidist_linelist)
+S3method(as_naive_model,data.frame)
 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_stancode,epidist_latent_model)
 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_validate_model,epidist_latent_model)
+S3method(epidist_validate_model,epidist_naive_model)
 export(add_mean_sd)
-export(as_direct_model)
 export(as_epidist_linelist)
-export(as_latent_individual)
+export(as_latent_model)
+export(as_naive_model)
 export(epidist)
 export(epidist_diagnostics)
 export(epidist_family)
@@ -39,9 +39,9 @@ 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_latent_model)
+export(is_naive_model)
 export(observe_process)
 export(predict_delay_parameters)
 export(predict_dpar)

R/globals.R

@@ -1,9 +1,17 @@
 # Generated by roxyglobals: do not edit by hand
 
 utils::globalVariables(c(
+  ".data", # <epidist_diagnostics>
   "samples", # <epidist_diagnostics>
-  "woverlap", # <epidist_stancode.epidist_latent_individual>
+  ".data", # <as_latent_model.epidist_linelist>
+  "woverlap", # <epidist_stancode.epidist_latent_model>
+  ".data", # <as_naive_model.data.frame>
+  ".data", # <observe_process>
+  ".data", # <add_mean_sd.lognormal_samples>
+  ".data", # <add_mean_sd.gamma_samples>
   "rlnorm", # <simulate_secondary>
+  ".data", # <simulate_secondary>
+  ".data", # <.replace_prior>
   "prior_new", # <.replace_prior>
   "source_new", # <.replace_prior>
   NULL

R/latent_individual.R → R/latent_model.R

@@ -1,19 +1,19 @@
-#' Prepare latent individual model
+#' Prepare latent model
 #'
 #' @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_latent_model <- function(data) {
+  UseMethod("as_latent_model")
 }
 
-#' @method as_latent_individual epidist_linelist
-#' @family latent_individual
+#' @method as_latent_model epidist_linelist
+#' @family latent_model
 #' @autoglobal
 #' @export
-as_latent_individual.epidist_linelist <- function(data) {
+as_latent_model.epidist_linelist <- function(data) {
   epidist_validate_data(data)
-  class(data) <- c("epidist_latent_individual", class(data))
+  class(data) <- c("epidist_latent_model", class(data))
   data <- data |>
     mutate(
       relative_obs_time = .data$obs_time - .data$ptime_lwr,
@@ -31,11 +31,11 @@ as_latent_individual.epidist_linelist <- function(data) {
   return(data)
 }
 
-#' @method epidist_validate_model epidist_latent_individual
-#' @family latent_individual
+#' @method epidist_validate_model epidist_latent_model
+#' @family latent_model
 #' @export
-epidist_validate_model.epidist_latent_individual <- function(data, ...) {
-  assert_true(is_latent_individual(data))
+epidist_validate_model.epidist_latent_model <- function(data, ...) {
+  assert_true(is_latent_model(data))
   col_names <- c(
     "ptime_lwr", "ptime_upr", "stime_lwr", "stime_upr", "obs_time",
     "relative_obs_time", "pwindow", "woverlap", "swindow", "delay", ".row_id"
@@ -49,24 +49,25 @@ epidist_validate_model.epidist_latent_individual <- function(data, ...) {
   assert_numeric(data$delay, lower = 0)
 }
 
-#' Check if data has the `epidist_latent_individual` class
+#' Check if data has the `epidist_latent_model` class
 #'
 #' @param data A `data.frame` containing line list data
-#' @family latent_individual
+#' @family latent_model
 #' @export
-is_latent_individual <- function(data) {
-  inherits(data, "epidist_latent_individual")
+is_latent_model <- function(data) {
+  inherits(data, "epidist_latent_model")
 }
 
 #' 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(
-    data, family, ...) {
+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(
     paste0("latent_", family$family),
@@ -87,35 +88,36 @@ 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(
-    data, formula, ...) {
+epidist_formula_model.epidist_latent_model <- function(
+  data, formula, ...
+) {
   # data is only used to dispatch on
   formula <- stats::update(
     formula, delay | vreal(relative_obs_time, pwindow, swindow) ~ .
   )
   return(formula)
 }
 
-#' @method epidist_stancode epidist_latent_individual
-#' @family latent_individual
+#' @method epidist_stancode epidist_latent_model
+#' @family latent_model
 #' @autoglobal
 #' @export
-epidist_stancode.epidist_latent_individual <- function(data,
-                                                       family =
-                                                         epidist_family(data),
-                                                       formula =
-                                                         epidist_formula(data),
-                                                       ...) {
+epidist_stancode.epidist_latent_model <- function(data,
+                                                  family =
+                                                    epidist_family(data),
+                                                  formula =
+                                                    epidist_formula(data),
+                                                  ...) {
   epidist_validate_model(data)
 
   stanvars_version <- .version_stanvar()
 
   stanvars_functions <- brms::stanvar(
     block = "functions",
-    scode = .stan_chunk("latent_individual/functions.stan")
+    scode = .stan_chunk("latent_model/functions.stan")
   )
 
   family_name <- gsub("latent_", "", family$name)
@@ -164,17 +166,17 @@ epidist_stancode.epidist_latent_individual <- function(data,
 
   stanvars_parameters <- brms::stanvar(
     block = "parameters",
-    scode = .stan_chunk("latent_individual/parameters.stan")
+    scode = .stan_chunk("latent_model/parameters.stan")
   )
 
   stanvars_tparameters <- brms::stanvar(
     block = "tparameters",
-    scode = .stan_chunk("latent_individual/tparameters.stan")
+    scode = .stan_chunk("latent_model/tparameters.stan")
   )
 
   stanvars_priors <- brms::stanvar(
     block = "model",
-    scode = .stan_chunk("latent_individual/priors.stan")
+    scode = .stan_chunk("latent_model/priors.stan")
   )
 
   stanvars_all <- stanvars_version + stanvars_functions + stanvars_data +

R/naive_model.R

@@ -0,0 +1,48 @@
+#' Prepare naive model to pass through to `brms`
+#'
+#' @param data A `data.frame` containing line list data
+#' @family naive_model
+#' @export
+as_naive_model <- function(data) {
+  UseMethod("as_naive_model")
+}
+
+assert_naive_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_naive_model data.frame
+#' @family naive_model
+#' @autoglobal
+#' @export
+as_naive_model.data.frame <- function(data) {
+  assert_naive_model_input(data)
+  class(data) <- c("epidist_naive_model", class(data))
+  data <- data |>
+    mutate(delay = .data$stime - .data$ptime)
+  epidist_validate_model(data)
+  return(data)
+}
+
+#' @method epidist_validate_model epidist_naive_model
+#' @family naive_model
+#' @export
+epidist_validate_model.epidist_naive_model <- function(data, ...) {
+  assert_true(is_naive_model(data))
+  assert_naive_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_naive_model` class
+#'
+#' @param data A `data.frame` containing line list data
+#' @family naive_model
+#' @export
+is_naive_model <- function(data) {
+  inherits(data, "epidist_naive_model")
+}

R/preprocess.R

@@ -53,7 +53,7 @@ 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"
+    "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)

R/utils.R

@@ -135,7 +135,12 @@
 #' @keywords internal
 #' @importFrom stats setNames
 .rename_columns <- function(df, new_names, old_names) {
-  are_char <- is.character(new_names) & is.character(old_names)
+  if (is.null(new_names) || is.null(old_names)) {
+    return(df)
+  }
+  new_char <- sapply(new_names, is.character)
+  old_char <- sapply(old_names, is.character)
+  are_char <- new_char & old_char
   valid_new_names <- new_names[are_char]
   valid_old_names <- old_names[are_char]
   if (length(are_char) > 0) {

_pkgdown.yml

@@ -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
+  desc: Specific methods for the naive model
   contents:
-  - has_concept("direct_model")
+  - has_concept("naive_model")
 - title: Postprocess
   desc: Functions for postprocessing model output
   contents: