Issue #376: Add epidist_diagnostics to FAQ

NAMESPACE

@@ -18,6 +18,7 @@ S3method(epidist_stancode,default)
 S3method(epidist_stancode,epidist_latent_individual)
 S3method(epidist_validate,default)
 S3method(epidist_validate,epidist_latent_individual)
+export(add_event_vars)
 export(add_mean_sd)
 export(as_latent_individual)
 export(epidist)

R/diagnostics.R

@@ -14,6 +14,7 @@
 #' `max_treedepth`
 #' * `per_at_max_treedepth`: the proportion of samples which attained the
 #' `max_treedepth`
+#' 
 #' When the fitting algorithm is not `"sampling"` (see [brms::brm()] for other
 #' possible algorithms) then diagnostics are yet to be implemented.
 #' @param fit A fitted model of class `epidist_fit`

R/preprocess.R

@@ -0,0 +1,86 @@
+#' Add columns for interval censoring of primary and secondary events
+#'
+#' @param linelist ...
+#' @param ptime_lwr ...
+#' @param ptime_upr ...
+#' @param pwindow ...
+#' @param stime_lwr ...
+#' @param stime_upr ...
+#' @param swindow ...
+#' @family preprocess
+#' @autoglobal
+#' @export
+add_event_vars <- function(
+  linelist, ptime_lwr = NULL, ptime_upr = NULL, pwindow = NULL,
+  stime_lwr = NULL, stime_upr = NULL, swindow = NULL
+) {
+  if (!is.null(ptime_lwr)) {
+    linelist <- dplyr::rename(linelist, ptime_lwr = !!ptime_lwr)
+  }
+
+  if (!is.null(ptime_upr)) {
+    linelist <- dplyr::rename(linelist, ptime_upr = !!ptime_upr)
+  }
+
+  if (!is.null(pwindow) && is.character(pwindow)) {
+    linelist <- dplyr::rename(linelist, pwindow = !!pwindow)
+  }
+
+  if (!is.null(stime_lwr)) {
+    linelist <- dplyr::rename(linelist, stime_lwr = !!stime_lwr)
+  }
+
+  if (!is.null(stime_upr)) {
+    linelist <- dplyr::rename(linelist, stime_upr = !!stime_upr)
+  }
+
+  if (!is.null(swindow) && is.character(swindow)) {
+    linelist <- dplyr::rename(linelist, swindow = !!swindow)
+  }
+
+  if (is.numeric(pwindow)) {
+    # Warn that numeric pwindow overwrites pwindow in data
+    linelist$pwindow <- pwindow
+  }
+
+  if (is.numeric(swindow)) {
+    # Warn that numeric swindow overwrites swindow in data
+    linelist$swindow <- swindow
+  }
+
+  if (is.null(stime_upr)) {
+    linelist <- mutate(linelist, stime_upr = stime_lwr + swindow)
+  }
+
+  if (is.null(ptime_upr)) {
+    linelist <- mutate(linelist, ptime_upr = ptime_lwr + pwindow)
+  }
+
+  if (is.null(swindow)) {
+    linelist <- mutate(linelist, pwindow = stime_upr - stime_lwr)
+  }
+
+  if (is.null(pwindow)) {
+    linelist <- mutate(linelist, swindow = ptime_upr - ptime_lwr)
+  }
+
+  assert_numeric(linelist$ptime_lwr)
+  assert_numeric(linelist$ptime_upr)
+  assert_numeric(linelist$pwindow, lower = 0)
+  assert_true(
+    all(linelist$ptime_lwr + linelist$pwindow - linelist$ptime_upr < 1e-6)
+  )
+
+  assert_numeric(linelist$stime_lwr)
+  assert_numeric(linelist$stime_upr)
+  assert_numeric(linelist$swindow, lower = 0)
+  assert_true(
+    all(linelist$stime_lwr + linelist$swindow - linelist$stime_upr < 1e-6)
+  )
+
+  linelist <- dplyr::relocate(
+    linelist, ptime_lwr, ptime_upr, pwindow, stime_lwr, stime_upr, swindow
+  )
+
+  return(linelist)
+}

_pkgdown.yml

@@ -37,6 +37,10 @@ reference:
   desc: Functions for observing data
   contents:
   - has_concept("observe")
+- title: Preprocess
+  desc: Functions for preprocessing data
+  contents:
+  - has_concept("preprocess")
 - title: S3 generics
   desc: S3 generics for delay modelling
   contents:

tests/testthat/test-preprocess.R

@@ -0,0 +1,36 @@
+test_that("add_event_vars produces equivalent linelists in different ways", { # nolint: line_length_linter.
+  linelist <- tibble::tibble(
+    "a" = runif(100),
+    "b" = 1,
+    "c" = a + b,
+    "d" = runif(100, 2, 3),
+    "e" = 1,
+    "f" = d + e
+  )
+
+  ll <- linelist |>
+    add_event_vars(
+      ptime_lwr = "a", pwindow = "b", ptime_upr = "c",
+      stime_lwr = "d", swindow = "e", stime_upr = "f"
+    )
+
+  ll2 <- select(linelist, a, c, d, f) |>
+    add_event_vars(
+      ptime_lwr = "a", pwindow = 1, ptime_upr = "c",
+      stime_lwr = "d", swindow = 1, stime_upr = "f"
+    )
+
+  ll3 <- select(linelist, a, b, d, e) |>
+    add_event_vars(
+      ptime_lwr = "a", pwindow = "b", stime_lwr = "d", swindow = "e",
+    )
+
+  ll4 <- select(linelist, a, c, d, f) |>
+    add_event_vars(
+      ptime_lwr = "a", ptime_upr = "c", stime_lwr = "d", stime_upr = "f",
+    )
+
+  expect_equal(ll, ll2)
+  expect_equal(ll, ll3)
+  expect_equal(ll, ll4)
+})

vignettes/faq.Rmd

@@ -77,6 +77,12 @@ library(bayesplot)
 mcmc_trace(fit, pars = c("Intercept", "Intercept_sigma"))
 ```
 
+We also provide a helper function `epidist_diagnostics()` which can be used to obtain common diagnostics used to assess the quality of a fitted model.
+
+```{r message = FALSE}
+epidist_diagnostics(fit)
+```
+
 ## I'd like to run a simulation study
 
 We recommend use of the `purrr` package for running many `epidist` models, for example as a part of a simulation study.