tests/testthat/helper-data.R

In erplots: Model-Agnostic Exposure-Response Plots

# testthat loads helper files in alphabetical order, so helper-toy-model.R
# (needed below) would otherwise load *after* this file -- source it
# explicitly rather than relying on load order.
source(testthat::test_path("helper-toy-model.R"), local = TRUE)

# `er_test_data` is a frozen snapshot of `erglm::erglm_data` (see
# `tests/testthat/fixtures/er_test_data.rds` -- regenerated by hand with
# `saveRDS(erglm::erglm_data, "tests/testthat/fixtures/er_test_data.rds",
# version = 2)` if erglm's own `erglm_data` is ever revised), so most of the
# suite doesn't need erglm installed just to get a data frame with the
# right column names/shape.
er_test_data <- readRDS(testthat::test_path("fixtures", "er_test_data.rds"))

# `er_test_mod1`/`er_test_mod2`/`er_test_mod_gaussian` are built via the
# internal, test-only `er_test_toy_model()` (see helper-toy-model.R)
# instead of `erglm::erglm_model()`, so they -- and the many tests that
# just consume them -- don't require erglm to be installed.
er_test_mod1 <- er_test_toy_model(ae1 ~ aucss, er_test_data, family = binomial())
er_test_mod2 <- er_test_toy_model(ae1 ~ aucss + sex, er_test_data, family = binomial())
# continuous-response fixture, used by the Stage 0 (and later) tests for
# response-type detection/handling
er_test_mod_gaussian <- er_test_toy_model(biomarker_change ~ aucss, er_test_data, family = gaussian())
# landmark fixture (see `er_test_landmark_model`'s methods further down this
# file, defined after `er_test_mod1`'s own class since they wrap the same
# `er_test_toy_model()` shape) -- reuses `er_test_mod1`'s underlying `glm()`
# fit, just tagged with a different class so its `er_predict()`/
# `er_summary()`/`er_simulate()` methods require `landmark_time`
er_test_mod_landmark <- structure(list(fit = er_test_mod1$fit), class = "er_test_landmark_model")

if (requireNamespace("erglm", quietly = TRUE)) {
  # count-response fixture. `er_test_toy_model()` deliberately doesn't
  # support Poisson (see helper-toy-model.R), so this one stays erglm-backed
  # and gated. Count responses auto-detect as "continuous" and are routed
  # through the same mean + t-interval path (a documented approximation,
  # not an exact Poisson interval).
  er_test_mod_poisson <- erglm::erglm_model(ae_count ~ aucss, er_test_data, family = poisson())
}

# test-only fixture with no `er_predict()` method, used to exercise the
# `er_summary()` contract's `coefficients`/`glance` fields (see
# `?er_model_interface`) without depending on erglm implementing them --
# `.layer_summary()` never calls `er_predict()`, so this is enough for
# `er_plot_add_summary(model = ...)`, but not for `er_plot_add_model()`.
er_summary.er_test_fake_summary_model <- function(model, ...) {
  list(
    p_value = NULL, # e.g. a multi-parameter model with no single privileged term
    coefficients = tibble::tibble(
      term = c("(Intercept)", "aucss"),
      estimate = c(0.1, 0.02),
      p_value = c(0.5, 0.02)
    ),
    glance = tibble::tibble(n = 100L, aic = 123.4, bic = 130.1, r_squared = 0.42)
  )
}
# a second fixture with a partially-populated `glance` (only `aic`; `bic`/
# `r_squared` absent, `n` present but `NA`) -- exercises
# `er_style_summary_gof()`'s "show only what's present and non-NA" branch
er_summary.er_test_partial_gof_model <- function(model, ...) {
  list(glance = tibble::tibble(n = NA_integer_, aic = 88.8))
}
# `er_summary()` is called from inside erplots' own internals
# (`.layer_summary()`), several frames away from this test file, so plain
# lexical scoping won't find an informally-defined method here -- register
# it explicitly, the same runtime pattern erglm itself uses (see AGENTS.md).
registerS3method("er_summary", "er_test_fake_summary_model", er_summary.er_test_fake_summary_model)
registerS3method("er_summary", "er_test_partial_gof_model", er_summary.er_test_partial_gof_model)

# test-only fixture used to exercise `er_vpc_add_simulated(model = ...)`
# without depending on erglm/emaxnls implementing the `sim_resp` extension
# to `er_simulate()` -- see `?er_model_interface`. `prob` is the (constant,
# covariate-independent) response probability used to draw simulated
# binary responses; `fit_resp` is included alongside `sim_resp` in the
# returned data frame to mirror the real contract (a method can supply
# both from one call).
er_simulate.er_test_fake_vpc_model <- function(model, newdata, nsim = 100, seed = NULL, ...) {
  reps <- vector("list", nsim)
  withr::with_seed(seed %||% 1, {
    for (ii in seq_len(nsim)) {
      row <- newdata
      row$sim_id <- ii
      row$fit_resp <- model$prob
      row$sim_resp <- stats::rbinom(nrow(newdata), size = 1, prob = model$prob)
      reps[[ii]] <- row
    }
  })
  dplyr::bind_rows(reps)
}
# a second fixture with only `fit_resp` (no `sim_resp`), used to exercise
# `er_vpc_add_simulated(model = ...)`'s "predictive simulation not
# available" error path -- this is the shape every `er_simulate()` method had before
# `sim_resp` was added to the contract (e.g. still true of erglm/emaxnls
# at the time this fixture was written).
er_simulate.er_test_fake_spaghetti_only_model <- function(model, newdata, nsim = 100, seed = NULL, ...) {
  reps <- vector("list", nsim)
  withr::with_seed(seed %||% 1, {
    for (ii in seq_len(nsim)) {
      row <- newdata
      row$sim_id <- ii
      row$fit_resp <- model$prob
      reps[[ii]] <- row
    }
  })
  dplyr::bind_rows(reps)
}
registerS3method("er_simulate", "er_test_fake_vpc_model", er_simulate.er_test_fake_vpc_model)
registerS3method("er_simulate", "er_test_fake_spaghetti_only_model", er_simulate.er_test_fake_spaghetti_only_model)

# test-only fixture mirroring the `ertte` landmark-binary use case that
# motivated issue #10 (`predict_args`/`summary_args`/`simulate_args`): each
# method *requires* a `landmark_time` argument with no other slot in the
# fixed `er_predict()`/`er_summary()`/`er_simulate()` contract, and errors
# informatively if it's missing -- exercising that
# `er_plot_add_model(predict_args = ...)`/`er_plot_add_summary(summary_args
# = ...)`/`er_vpc_add_simulated(simulate_args = ...)` actually reach the
# generic, not just the style builder's `config$dots`.
.check_landmark_time <- function(landmark_time) {
  if (is.null(landmark_time)) {
    rlang::abort("`landmark_time` is required (e.g. via `predict_args`/`summary_args`/`simulate_args`).")
  }
}
er_predict.er_test_landmark_model <- function(model, newdata, conf_level = 0.95, landmark_time = NULL, ...) {
  .check_landmark_time(landmark_time)
  fit <- model$fit
  z_scale <- -stats::qnorm((1 - conf_level) / 2)
  # a deliberately simplistic "landmark" transform (scales the underlying
  # toy model's fitted probability by how far `landmark_time` is from a
  # fixed reference) -- realistic enough to prove `landmark_time` reached
  # this method, nothing more is needed for the fixture's purpose
  scale <- landmark_time / 90
  link_pred <- stats::predict(fit, newdata, se.fit = TRUE, type = "link")
  inverse_link <- stats::family(fit)$linkinv
  newdata$fit_resp <- pmin(inverse_link(link_pred$fit) * scale, 1)
  newdata$ci_lower <- pmin(inverse_link(link_pred$fit - z_scale * link_pred$se.fit) * scale, 1)
  newdata$ci_upper <- pmin(inverse_link(link_pred$fit + z_scale * link_pred$se.fit) * scale, 1)
  newdata
}
er_summary.er_test_landmark_model <- function(model, conf_level = 0.95, landmark_time = NULL, ...) {
  .check_landmark_time(landmark_time)
  list(p_value = landmark_time / 1000) # arbitrary, just needs to reflect `landmark_time`
}
er_simulate.er_test_landmark_model <- function(model, newdata, nsim = 100, seed = NULL, landmark_time = NULL, ...) {
  .check_landmark_time(landmark_time)
  reps <- vector("list", nsim)
  withr::with_seed(seed %||% 1, {
    for (ii in seq_len(nsim)) {
      row <- newdata
      row$sim_id <- ii
      row$fit_resp <- landmark_time / 90
      row$sim_resp <- stats::rbinom(nrow(newdata), size = 1, prob = min(landmark_time / 90, 1))
      reps[[ii]] <- row
    }
  })
  dplyr::bind_rows(reps)
}
registerS3method("er_predict", "er_test_landmark_model", er_predict.er_test_landmark_model)
registerS3method("er_summary", "er_test_landmark_model", er_summary.er_test_landmark_model)
registerS3method("er_simulate", "er_test_landmark_model", er_simulate.er_test_landmark_model)