Issue 34: Refactor and infrastructure for filtering functions

R/observe.R

@@ -24,52 +24,74 @@ observe_process <- function(linelist) {
   return(clinelist)
 }
 
-#' Filter observations based on a observation time of secondary events
+#' Add a column to linelist data specifying the date of observation.
+#' 
+#' @param linelist A `data.table` containing line list data.
+#' @param obs_time The observation time.
 #' 
 #' @family observe
 #' @export
-filter_obs_by_obs_time <- function(linelist, obs_time) {
-  truncated_linelist <- data.table::copy(linelist)
-  truncated_linelist[, obs_at := obs_time]
-  truncated_linelist[, obs_time := obs_time - ptime]
-  truncated_linelist[, censored_obs_time := obs_at - ptime_lwr]
-  truncated_linelist[, censored := "interval"]
-  truncated_linelist <- truncated_linelist[stime_upr <= obs_at]
+include_obs_at <- function(linelist, obs_time) {
+  clinelist <- data.table::copy(linelist)
+  clinelist[, obs_at := obs_time]
 
-  return(truncated_linelist)
+  return(clinelist)
 }
 
-#' Filter observations based on the observation time of primary events
+#' Filter observations based on the observation time of secondary events
 #' 
+#' @param linelist A `data.table` containing line list data.
+#' @param obs_time The observation time of secondary events.
+#' 
+#' @family observe
+#' @export
+filter_obs_by_stime <- function(linelist, obs_time) {
+  clinelist <- data.table::copy(linelist)
+  clinelist[, obs_at := obs_time]
+  clinelist[, obs_time := obs_time - ptime]
+  clinelist[, censored_obs_time := obs_at - ptime_lwr]
+  clinelist[, censored := "interval"]
+  clinelist <- clinelist[stime_upr <= obs_at]
+
+  return(clinelist)
+}
+
+#' Filter observations based on the observation time of primary events
+#'
+#' @param linelist A `data.table` containing line list data.
+#' @param obs_time The observation time of primary events.
+#' @param obs_at Unknown argument.
+#'
 #' @family observe
 #' @export
 filter_obs_by_ptime <- function(linelist, obs_time,
                                 obs_at = c("obs_secondary", "max_secondary")) {
   obs_at <- match.arg(obs_at)
 
   pfilt_t <- obs_time
-  truncated_linelist <- data.table::copy(linelist)
+  clinelist <- data.table::copy(linelist)
 
-  truncated_linelist[, censored := "interval"]
-  truncated_linelist <- truncated_linelist[ptime_upr <= pfilt_t]
+  clinelist[, censored := "interval"]
+  clinelist <- clinelist[ptime_upr <= pfilt_t]
 
   if (obs_at == "obs_secondary") {
     # Update observation time to be the same as the maximum secondary time
-    truncated_linelist[, obs_at := stime_upr]
+    clinelist[, obs_at := stime_upr]
   } else if (obs_at == "max_secondary") {
-    truncated_linelist[, obs_at := stime_upr |> max() |> ceiling()] 
+    clinelist[, obs_at := stime_upr |> max() |> ceiling()] 
   }
 
   # make observation time as specified
-  truncated_linelist[, obs_time := obs_at - ptime]
+  clinelist[, obs_time := obs_at - ptime]
   # Assuming truncation at the beginning of the censoring window
-  truncated_linelist[, censored_obs_time := obs_at - ptime_lwr]
+  clinelist[, censored_obs_time := obs_at - ptime_lwr]
 
   # set observation time to artifial observation time
   if (obs_at == "obs_secondary") {
-    truncated_linelist[, obs_at := pfilt_t]
+    clinelist[, obs_at := pfilt_t]
   }
-  return(truncated_linelist)
+
+  return(clinelist)
 }
 
 #' Pad zero observations as unstable in a lognormal distribution

tests/testthat/setup.R

@@ -5,11 +5,14 @@ sdlog <- 0.5
 obs_time <- 25
 sample_size <- 200
 
-sim_obs <- simulate_gillespie() |>
+obs <- simulate_gillespie() |>
   simulate_secondary(
     meanlog = meanlog,
     sdlog = sdlog
-  ) |>
-  observe_process() |>
-  filter_obs_by_obs_time(obs_time = obs_time) %>%
-  .[sample(seq_len(.N), sample_size, replace = FALSE)]
+  )
+
+obs_cens <- observe_process(obs)
+
+obs_cens_trunc <- filter_obs_by_stime(obs_cens, obs_time = obs_time)
+
+obs_cens_trunc_samp <- obs_cens_trunc[sample(seq_len(.N), sample_size, replace = FALSE)]

tests/testthat/test-filter_obs.R

@@ -0,0 +1,6 @@
+test_that("obs_cens_trunc has the correct number of rows", {
+  expect_equal(
+    sum(obs_cens$stime_upr <= obs_time),
+    nrow(obs_cens_trunc)
+  )
+})