Issue #432: Remove exported filtering functions

NAMESPACE

@@ -39,8 +39,6 @@ export(epidist_prior)
 export(epidist_stancode)
 export(epidist_validate_data)
 export(epidist_validate_model)
-export(filter_obs_by_obs_time)
-export(filter_obs_by_ptime)
 export(is_direct_model)
 export(is_epidist_linelist)
 export(is_latent_individual)

R/globals.R

@@ -3,7 +3,6 @@
 utils::globalVariables(c(
   "samples", # <epidist_diagnostics>
   "woverlap", # <epidist_stancode.epidist_latent_individual>
-  ":=", # <filter_obs_by_ptime>
   "rlnorm", # <simulate_secondary>
   "prior_new", # <.replace_prior>
   "source_new", # <.replace_prior>

R/latent_gamma.R

@@ -77,7 +77,8 @@ log_lik_latent_gamma <- function(i, prep) {
   obs_time <- relative_obs_time - pwindow
   lpdf <- stats::dgamma(d, shape = shape, scale = mu / shape, log = TRUE)
   lcdf <- stats::pgamma(
-    obs_time, shape = shape, scale = mu / shape, log.p = TRUE
+    obs_time,
+    shape = shape, scale = mu / shape, log.p = TRUE
   )
   return(lpdf - lcdf)
 }

R/latent_individual.R

@@ -66,8 +66,7 @@ is_latent_individual <- function(data) {
 #' @family latent_individual
 #' @export
 epidist_family_model.epidist_latent_individual <- function(
-  data, family, ...
-) {
+    data, family, ...) {
   # Really the name and vars are the "model-specific" parts here
   custom_family <- brms::custom_family(
     paste0("latent_", family$family),
@@ -92,8 +91,7 @@ epidist_family_model.epidist_latent_individual <- function(
 #' @family latent_individual
 #' @export
 epidist_formula_model.epidist_latent_individual <- function(
-  data, formula, ...
-) {
+    data, formula, ...) {
   # data is only used to dispatch on
   formula <- stats::update(
     formula, delay | vreal(relative_obs_time, pwindow, swindow) ~ .
@@ -111,7 +109,6 @@ epidist_stancode.epidist_latent_individual <- function(data,
                                                        formula =
                                                          epidist_formula(data),
                                                        ...) {
-
   epidist_validate_model(data)
 
   stanvars_version <- .version_stanvar()

R/observe.R

@@ -33,55 +33,3 @@ observe_process <- function(linelist) {
       obs_time = ceiling(max(.data$stime))
     )
 }
-
-#' Filter observations based on a observation time of secondary events
-#'
-#' @param linelist ...
-#' @param obs_time ...
-#' @family observe
-#' @autoglobal
-#' @export
-filter_obs_by_obs_time <- function(linelist, obs_time) {
-  linelist |>
-    mutate(
-      obs_time = obs_time,
-      relative_obs_time = .data$obs_time - .data$ptime,
-    ) |>
-    filter(.data$stime_upr <= .data$obs_time)
-}
-
-#' Filter observations based on the observation time of primary events
-#'
-#' @param linelist ...
-#' @param obs_time ...
-#' @param obs_time_type ...
-#' @family observe
-#' @autoglobal
-#' @export
-filter_obs_by_ptime <- function(linelist, obs_time,
-                                obs_time_type =
-                                  c("obs_secondary", "max_secondary")) {
-  obs_time <- match.arg(obs_time)
-  pfilt_t <- obs_time
-  truncated_linelist <- linelist |>
-    mutate(censored = "interval") |>
-    filter(.data$ptime_upr <= pfilt_t)
-  if (obs_time_type == "obs_secondary") {
-    # Update observation time to be the same as the maximum secondary time
-    truncated_linelist <- mutate(truncated_linelist, obs_time = .data$stime_upr)
-  } else if (obs_time_type == "max_secondary") {
-    truncated_linelist <- truncated_linelist |>
-      mutate(obs_time := .data$stime_upr |> max() |> ceiling())
-  }
-  # Make observation time as specified
-  truncated_linelist <- truncated_linelist |>
-    mutate(
-      obs_time = .data$obs_time - .data$ptime,
-      censored_obs_time = .data$obs_time - .data$ptime_lwr
-    )
-  # Set observation time to artificial observation time if needed
-  if (obs_time_type == "obs_secondary") {
-    truncated_linelist <- mutate(truncated_linelist, obs_time = pfilt_t)
-  }
-  return(truncated_linelist)
-}

R/postprocess.R

@@ -73,8 +73,8 @@ add_mean_sd.default <- function(data, ...) {
 #' @export
 add_mean_sd.lognormal_samples <- function(data, ...) {
   mutate(data,
-    mean = exp(.data$mu + .data$sigma ^ 2 / 2),
-    sd = .data$mean * sqrt(exp(.data$sigma ^ 2) - 1)
+    mean = exp(.data$mu + .data$sigma^2 / 2),
+    sd = .data$mean * sqrt(exp(.data$sigma^2) - 1)
   )
 }
 

R/preprocess.R

@@ -9,9 +9,8 @@
 #' @family preprocess
 #' @export
 as_epidist_linelist <- function(
-  data, pdate_lwr = NULL, pdate_upr = NULL, sdate_lwr = NULL, sdate_upr = NULL,
-  obs_date = NULL
-) {
+    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,

R/prior.R

@@ -24,7 +24,7 @@ epidist_prior <- function(data, family, formula, prior) {
   epidist_validate_model(data)
   default <- brms::default_prior(formula, data = data)
   model <- epidist_model_prior(data, formula)
-  family <-  epidist_family_prior(family, formula)
+  family <- epidist_family_prior(family, formula)
   if (!is.null(family)) {
     family$source <- "family"
     family[is.na(family)] <- "" # brms likes empty over NA

R/simulate.R

@@ -101,7 +101,6 @@ simulate_gillespie <- function(r = 0.2,
       } else {
         state <- c(state[1], state[2] - 1, state[3] + 1)
       }
-
     } else {
       go <- FALSE
     }

R/utils.R

@@ -61,7 +61,8 @@
   }
   cols <- c("class", "coef", "group", "resp", "dpar", "nlpar", "lb", "ub")
   prior <- dplyr::full_join(
-    old_prior, prior, by = cols, suffix = c("_old", "_new")
+    old_prior, prior,
+    by = cols, suffix = c("_old", "_new")
   )
 
   if (any(is.na(prior$prior_old))) {
@@ -98,7 +99,8 @@
 .add_dpar_info <- function(family) {
   other_links <- family[[paste0("link_", setdiff(family$dpars, "mu"))]]
   other_bounds <- lapply(
-    family$dpars[-1], brms:::dpar_bounds, family = family$family
+    family$dpars[-1], brms:::dpar_bounds,
+    family = family$family
   )
   family$other_links <- other_links
   family$other_bounds <- other_bounds

README.Rmd

@@ -31,7 +31,7 @@ license](https://img.shields.io/badge/License-MIT-blue.svg)](https://github.com/
 ## Summary
 
 ```{r, results = "asis", echo=FALSE}
-cat(gsub("\n[ ]+"," ",packageDescription("epidist")$Description))
+cat(gsub("\n[ ]+", " ", packageDescription("epidist")$Description))
 ```
 
 ## Quickstart
@@ -60,7 +60,8 @@ You can use the [`remotes` package](https://remotes.r-lib.org/) to install the d
 
 ```{r, eval = FALSE}
 remotes::install_github(
-  "epinowcast/epidist", dependencies = TRUE
+  "epinowcast/epidist",
+  dependencies = TRUE
 )
 ```
 
@@ -84,7 +85,8 @@ By default `epidist` uses the `rstan` package for fitting models. If you wish to
 ```{r, eval = FALSE}
 # if you not yet installed `epidist`, or you installed it without `Suggests` dependencies
 install.packages(
-  "cmdstanr", repos = c("https://mc-stan.org/r-packages/", getOption("repos"))
+  "cmdstanr",
+  repos = c("https://mc-stan.org/r-packages/", getOption("repos"))
 )
 # once `cmdstanr` is installed:
 cmdstanr::install_cmdstan()

inst/make_hexsticker.R

@@ -3,7 +3,7 @@ library(ggplot2)
 library(dplyr)
 library(magick)
 
-# make standard plot
+# Make standard plot
 outbreak <- simulate_gillespie(seed = 101)
 
 secondary_dist <- data.frame(mu = 1.8, sigma = 0.5)
@@ -17,8 +17,9 @@ obs <- outbreak |>
   ) |>
   observe_process()
 
+obs_time <- 25
 truncated_obs <- obs |>
-  filter_obs_by_obs_time(obs_time = 25) |>
+  filter(.data$stime_upr <= obs_time) |>
   slice_sample(n = 200, replace = FALSE)
 
 combined_obs <- bind_rows(
@@ -35,11 +36,14 @@ hex_plot <- combined_obs |>
   aes(x = delay_daily, fill = obs_time) +
   geom_histogram(
     aes(y = after_stat(density)),
-    binwidth = 1, position = "dodge"
+    binwidth = 1,
+    position = "dodge"
   ) +
   lims(x = c(0, 18)) +
   stat_function(
-    fun = dlnorm, args = c(meanlog, sdlog), n = 100,
+    fun = dlnorm,
+    args = c(meanlog, sdlog),
+    n = 100,
     col = "#646770"
   ) +
   scale_fill_brewer(palette = "Blues", direction = 1) +

tests/testthat/setup.R

@@ -21,7 +21,7 @@ sim_obs <- simulate_gillespie() |>
     sdlog = sdlog
   ) |>
   observe_process() |>
-  filter_obs_by_obs_time(obs_time = obs_time) |>
+  dplyr::filter(.data$stime_upr <= obs_time) |>
   dplyr::slice_sample(n = sample_size, replace = FALSE)
 
 # Temporary solution for classing time data
@@ -42,7 +42,7 @@ sim_obs_gamma <- simulate_gillespie() |>
     rate = rate
   ) |>
   observe_process() |>
-  filter_obs_by_obs_time(obs_time = obs_time) |>
+  dplyr::filter(.data$stime_upr <= obs_time) |>
   dplyr::slice_sample(n = sample_size, replace = FALSE)
 
 # Temporary solution for classing time data
@@ -77,7 +77,7 @@ sim_obs_sex_f <- dplyr::filter(sim_obs_sex, sex == 1) |>
 
 sim_obs_sex <- dplyr::bind_rows(sim_obs_sex_m, sim_obs_sex_f) |>
   observe_process() |>
-  filter_obs_by_obs_time(obs_time = obs_time) |>
+  dplyr::filter(.data$stime_upr <= obs_time) |>
   dplyr::slice_sample(n = sample_size, replace = FALSE)
 
 # Temporary solution for classing time data

tests/testthat/test-formula.R

@@ -4,7 +4,8 @@ family_lognormal <- epidist_family(prep_obs, family = brms::lognormal())
 
 test_that("epidist_formula with default settings produces a brmsformula with the correct intercept only formula", { # nolint: line_length_linter.
   form <- epidist_formula(
-    prep_obs, family = family_lognormal, formula = mu ~ 1
+    prep_obs,
+    family = family_lognormal, formula = mu ~ 1
   )
   expect_s3_class(form, "brmsformula")
   expect_equal(
@@ -16,7 +17,8 @@ test_that("epidist_formula with default settings produces a brmsformula with the
     "sigma ~ 1"
   )
   form_explicit <- epidist_formula(
-    prep_obs, family = family_lognormal, formula = brms::bf(mu ~ 1, sigma ~ 1)
+    prep_obs,
+    family = family_lognormal, formula = brms::bf(mu ~ 1, sigma ~ 1)
   )
   attr(form$pforms$sigma, ".Environment") <- NULL
   attr(form_explicit$pforms$sigma, ".Environment") <- NULL
@@ -44,25 +46,29 @@ test_that("epidist_formula with custom formulas produces a brmsformula with corr
 test_that("epidist_formula with custom formulas errors for incorrect custom formulas", { # nolint: line_length_linter.
   expect_error(
     epidist_formula(
-      prep_obs, family = family_lognormal,
+      prep_obs,
+      family = family_lognormal,
       formula = brms::bf(mu ~ 1 + age, sigma ~ 1)
     )
   )
   expect_error(
     epidist_formula(
-      prep_obs, family = family_lognormal,
+      prep_obs,
+      family = family_lognormal,
       formula = brms::bf(mu ~ 1, sigma ~ 1 + age)
     )
   )
   expect_error(
     epidist_formula(
-      prep_obs, family = family_lognormal,
+      prep_obs,
+      family = family_lognormal,
       formula = brms::bf(list(), sigma ~ 1)
     )
   )
   expect_error(
     epidist_formula(
-      prep_obs, family = family_lognormal,
+      prep_obs,
+      family = family_lognormal,
       formula = brms::bf(mu ~ 1, shape ~ 1)
     )
   )

tests/testthat/test-latent_individual.R

@@ -48,10 +48,12 @@ test_that("epidist_validate.epidist_latent_individual returns FALSE for incorrec
 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)
+    prep_obs, epidist_family,
+    formula = brms::bf(mu ~ 1)
   )
   stancode <- epidist_stancode(
-    prep_obs, family = epidist_family, formula = epidist_formula
+    prep_obs,
+    family = epidist_family, formula = epidist_formula
   )
   expect_s3_class(stancode, "stanvars")
 })