Issue #33: Write add_event_vars preprocessing functionality (#375)

* Add template for new add_event_vars function

* First draft complete of add_event_vars functionality

* Reduce complexity of add_event_vars using a helper function

* Template for add_obs_vars

* Revert commit to wrong branch!

Former-commit-id: 05053e1
Former-commit-id: 0fb7ec80e140a7887bb091dac128d53ce950c5ec
Former-commit-id: 30c9d47dc3d7266df6c74eb77fa4a870232d5c36 [formerly 0f90b0e]
Former-commit-id: c4777e5410e516ba0ae27961dc3e9bfb94decb54

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/preprocess.R

@@ -0,0 +1,69 @@
+#' 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
+) {
+  linelist <- .rename_column(linelist, "ptime_lwr", ptime_lwr)
+  linelist <- .rename_column(linelist, "ptime_upr", ptime_upr)
+  linelist <- .rename_column(linelist, "stime_lwr", stime_lwr)
+  linelist <- .rename_column(linelist, "stime_upr", stime_upr)
+  linelist <- .rename_column(linelist, "pwindow", pwindow)
+  linelist <- .rename_column(linelist, "swindow", swindow)
+
+  if (is.numeric(pwindow)) {
+    cli::cli_warn("Overwriting using numeric value(s) of pwindow provided!")
+    linelist$pwindow <- pwindow
+  }
+
+  if (is.numeric(swindow)) {
+    cli::cli_warn("Overwriting using numeric value(s) of swindow provided!")
+    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)
+}

R/utils.R

@@ -122,3 +122,11 @@
   }
   return(formula)
 }
+
+.rename_column <- function(df, new, old) {
+  are_char <- is.character(new) & is.character(old)
+  if (are_char) {
+    df <- dplyr::rename(df, !!new := !!old)
+  }
+  return(df)
+}

_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)
+})