tests/testthat/test-utils-helpers.R

In erplots: Model-Agnostic Exposure-Response Plots

test_that("ci_t matches stats::t.test for a plain numeric vector", {
  set.seed(2837)
  x <- rnorm(15, mean = 5, sd = 2)

  ci <- ci_t(x)
  ref <- stats::t.test(x, conf.level = 0.95)$conf.int

  expect_equal(unname(ci["lower"]), ref[1])
  expect_equal(unname(ci["upper"]), ref[2])
})

test_that("ci_t respects conf_level and stores it as an attribute", {
  x <- c(1, 2, 3, 4, 5)

  ci_95 <- ci_t(x, conf_level = 0.95)
  ci_80 <- ci_t(x, conf_level = 0.80)

  expect_equal(attr(ci_95, "conf_level"), 0.95)
  expect_equal(attr(ci_80, "conf_level"), 0.80)

  # A narrower confidence level should give a narrower interval
  width_95 <- ci_95["upper"] - ci_95["lower"]
  width_80 <- ci_80["upper"] - ci_80["lower"]
  expect_true(width_80 < width_95)
})

test_that("ci_t is centred on the sample mean", {
  x <- c(2, 4, 6, 8, 10)
  ci <- ci_t(x)

  midpoint <- unname((ci["lower"] + ci["upper"]) / 2)
  expect_equal(midpoint, mean(x))
})

test_that("ci_t drops NAs before computing the interval", {
  x <- c(1, 2, 3, NA, 4, 5, NA)
  ci_with_na <- ci_t(x)
  ci_without_na <- ci_t(x[!is.na(x)])

  expect_equal(ci_with_na, ci_without_na)
})

test_that("ci_t returns NA bounds for fewer than 2 non-missing values", {
  ci_zero <- ci_t(numeric(0))
  ci_one <- ci_t(5)
  ci_one_after_na <- ci_t(c(5, NA, NA))

  expect_true(all(is.na(ci_zero)))
  expect_true(all(is.na(ci_one)))
  expect_true(all(is.na(ci_one_after_na)))

  # conf_level should still be recorded even in the degenerate case
  expect_equal(attr(ci_zero, "conf_level"), 0.95)
})

test_that("ci_t returns a named lower/upper vector", {
  ci <- ci_t(c(1, 2, 3))
  expect_named(ci, c("lower", "upper"))
  expect_true(ci["lower"] < ci["upper"])
})


test_that("ci_poisson matches stats::poisson.test for a single count", {
  ci <- ci_poisson(7, 10)
  ref <- stats::poisson.test(7, 10, conf.level = 0.95)$conf.int

  expect_equal(unname(ci["lower"]), ref[1])
  expect_equal(unname(ci["upper"]), ref[2])
})

test_that("ci_poisson brackets the rate and respects conf_level", {
  ci_95 <- ci_poisson(20, 50, conf_level = 0.95)
  ci_80 <- ci_poisson(20, 50, conf_level = 0.80)

  rate <- 20 / 50
  expect_true(ci_95["lower"] <= rate && rate <= ci_95["upper"])
  expect_equal(attr(ci_95, "conf_level"), 0.95)
  expect_equal(attr(ci_80, "conf_level"), 0.80)

  width_95 <- ci_95["upper"] - ci_95["lower"]
  width_80 <- ci_80["upper"] - ci_80["lower"]
  expect_true(width_80 < width_95)
})

test_that("ci_poisson sums a vector of counts and never returns a negative lower bound", {
  ci_vec <- ci_poisson(c(0, 1, 2, 0, 1), n = 5)
  ci_sum <- ci_poisson(4, n = 5)
  expect_equal(ci_vec, ci_sum)

  ci_zero <- ci_poisson(0, n = 10)
  expect_equal(unname(ci_zero["lower"]), 0)
  expect_true(ci_zero["upper"] >= 0)
})

test_that("ci_poisson returns a named lower/upper vector", {
  ci <- ci_poisson(5, 20)
  expect_named(ci, c("lower", "upper"))
  expect_true(ci["lower"] < ci["upper"])
})

test_that(".apply_exposure_breaks() defaults reproduce its prior, hardcoded behaviour", {
  x <- c(0, 0, 1:9, rep(10, 5), 11:15)
  breaks <- attr(cut_exposure_quantile(x, n_bins = 4), "breaks")

  result <- .apply_exposure_breaks(x, breaks, is_placebo = x == 0)
  expect_equal(levels(result), c("Placebo", "Q1", "Q2", "Q3", "Q4"))
  # matches a direct `cut(..., right = TRUE, include.lowest = TRUE)` call
  expect_equal(
    as.character(result[x != 0]),
    as.character(cut(x[x != 0], breaks, labels = paste0("Q", 1:4), include.lowest = TRUE))
  )
})

test_that(".apply_exposure_breaks() honours ties/labels/seed", {
  x <- c(1:9, rep(10, 5), 11:15)
  breaks <- attr(cut_exposure_quantile(x, n_bins = 4), "breaks")

  up <- .apply_exposure_breaks(x, breaks, ties = "upward")
  down <- .apply_exposure_breaks(x, breaks, ties = "downward")
  expect_false(identical(as.character(up), as.character(down)))

  labelled <- .apply_exposure_breaks(x, breaks, labels = c("Low", "Mid-low", "Mid-high", "High"))
  expect_equal(levels(labelled), c("Placebo", "Low", "Mid-low", "Mid-high", "High"))

  split1 <- .apply_exposure_breaks(x, breaks, ties = "split-even", seed = 823)
  split2 <- .apply_exposure_breaks(x, breaks, ties = "split-even", seed = 823)
  expect_identical(split1, split2)
})

test_that("cut_exposure_quantile errors clearly on constant, all-NA, or too-few-value exposure", {
  expect_error(cut_exposure_quantile(rep(5, 10)), "found only 1 distinct")
  expect_error(cut_exposure_quantile(rep(NA_real_, 10)), "found only 0 distinct")
  # only one non-placebo value; the rest are placebo (0)
  expect_error(cut_exposure_quantile(c(0, 0, 0, 5)), "found only 1 distinct")
  # a single row overall
  expect_error(cut_exposure_quantile(5), "found only 1 distinct")
})

test_that("cut_exposure_quantile works normally with at least 2 distinct non-placebo values", {
  x <- c(0, 0, 1, 2, 3, 4)
  result <- cut_exposure_quantile(x, n_bins = 2)
  expect_s3_class(result, "factor")
  expect_equal(levels(result), c("Placebo", "Q1", "Q2"))
  expect_equal(as.character(result[1:2]), c("Placebo", "Placebo"))
})

test_that("cut_exposure_quantile warns and gracefully degrades when requested bins exceed the exposure column's resolution", {
  # heavily skewed: only 2 distinct values, requesting 4 bins produces
  # duplicate stats::quantile() breaks -- this used to crash with the
  # opaque 'breaks' are not unique cut() error
  x <- c(rep(1, 18), 2)
  expect_warning(
    result <- cut_exposure_quantile(x, n_bins = 4),
    "only 1 are distinguishable"
  )
  expect_equal(levels(result), c("Placebo", "Q1"))
  expect_true(all(as.character(result) == "Q1"))

  # a case that degrades to more than 1 (but still fewer than requested) bin
  x2 <- c(rep(1, 10), rep(2, 10), 3)
  expect_warning(
    result2 <- cut_exposure_quantile(x2, n_bins = 10),
    "only 2 are distinguishable"
  )
  expect_equal(levels(result2), c("Placebo", "Q1", "Q2"))

  # enough resolution for the requested bins -- no warning
  expect_no_warning(cut_exposure_quantile(1:100, n_bins = 4))
})

test_that("cut_quantile errors clearly on constant, all-NA, or too-few-value input", {
  expect_error(cut_quantile(rep(5, 10)), "found only 1 distinct")
  expect_error(cut_quantile(rep(NA_real_, 10)), "found only 0 distinct")
  expect_error(cut_quantile(5), "found only 1 distinct")
})

test_that("cut_quantile works normally with at least 2 distinct values", {
  result <- cut_quantile(c(1, 2, 3, 4, 5, 6, 7, 8), n_bins = 4)
  expect_s3_class(result, "factor")
  expect_equal(levels(result), paste0("Q", 1:4))
})

test_that("cut_quantile defaults to ties = \"upward\" and records it as an attribute", {
  x <- c(1:9, rep(10, 5), 11:15)
  default_result <- cut_quantile(x, n_bins = 4)
  upward_result <- cut_quantile(x, n_bins = 4, ties = "upward")

  expect_equal(default_result, upward_result)
  expect_equal(attr(default_result, "ties"), "upward")
})

test_that("cut_quantile's ties argument controls how a tied break value is assigned", {
  # a run of `10`s straddles the 50%/75% quantile breaks (10 and 10.5)
  x <- c(1:9, rep(10, 5), 11:15)

  upward <- cut_quantile(x, n_bins = 4, ties = "upward")
  downward <- cut_quantile(x, n_bins = 4, ties = "downward")

  # "upward" (right = TRUE): ties at a break go to the lower bin
  expect_equal(as.integer(table(upward)), c(5, 9, 0, 5))
  # "downward" (right = FALSE): ties at a break go to the higher bin
  expect_equal(as.integer(table(downward)), c(5, 4, 5, 5))

  expect_equal(attr(upward, "ties"), "upward")
  expect_equal(attr(downward, "ties"), "downward")
})

test_that("cut_quantile's ties = \"split-even\" balances bin sizes and is reproducible with a seed", {
  x <- c(1:9, rep(10, 5), 11:15)

  split_even <- cut_quantile(x, n_bins = 4, ties = "split-even", seed = 7148)
  counts <- as.integer(table(split_even))

  # as close to equal as 19 observations across 4 bins can get
  expect_equal(sort(counts), c(4, 5, 5, 5))
  expect_equal(attr(split_even, "ties"), "split-even")

  # same seed -> identical result
  expect_identical(
    cut_quantile(x, n_bins = 4, ties = "split-even", seed = 7148),
    split_even
  )
})

test_that("cut_quantile defaults to quantile_type = 7 and records it as an attribute", {
  x <- c(1:9, rep(10, 5), 11:15)
  default_result <- cut_quantile(x, n_bins = 4)
  type7_result <- cut_quantile(x, n_bins = 4, quantile_type = 7)

  expect_equal(default_result, type7_result)
  expect_equal(attr(default_result, "quantile_type"), 7)
})

test_that("cut_quantile's quantile_type argument is forwarded to stats::quantile()", {
  x <- c(1:9, rep(10, 5), 11:15)
  result_type1 <- cut_quantile(x, n_bins = 4, quantile_type = 1)
  result_type7 <- cut_quantile(x, n_bins = 4, quantile_type = 7)

  # the two types disagree on this skewed vector, so the resulting bin
  # membership should differ
  expect_false(identical(result_type1, result_type7))
  expect_equal(attr(result_type1, "quantile_type"), 1)
})

test_that("cut_exposure_quantile's quantile_type controls the breaks attribute and is recorded", {
  x <- c(rep(0, 5), 1:9, rep(10, 5), 11:15)
  non_placebo_x <- x[x != 0]

  result <- cut_exposure_quantile(x, n_bins = 4, quantile_type = 1)

  expect_equal(
    unname(attr(result, "breaks")),
    unname(stats::quantile(non_placebo_x, probs = (0:4) / 4, type = 1))
  )
  expect_equal(attr(result, "quantile_type"), 1)
})

test_that("cut_quantile defaults to Q1..Qn labels when labeller is NULL", {
  result <- cut_quantile(c(1, 2, 3, 4, 5, 6, 7, 8), n_bins = 4, labeller = NULL)
  expect_equal(levels(result), paste0("Q", 1:4))
})

test_that("cut_quantile accepts a function labeller, called with (n, breaks)", {
  x <- c(1, 2, 3, 4, 5, 6, 7, 8)
  captured <- list()
  labeller <- function(n, breaks) {
    captured$n <<- n
    captured$breaks <<- breaks
    paste0("Group ", seq_len(n))
  }

  result <- cut_quantile(x, n_bins = 4, labeller = labeller)

  expect_equal(levels(result), paste0("Group ", 1:4))
  expect_equal(captured$n, 4)
  expect_equal(unname(captured$breaks), unname(stats::quantile(x, probs = (0:4) / 4)))
})

test_that("cut_quantile accepts a character vector labeller", {
  result <- cut_quantile(c(1, 2, 3, 4, 5, 6, 7, 8), n_bins = 4, labeller = c("Low", "Mid-low", "Mid-high", "High"))
  expect_equal(levels(result), c("Low", "Mid-low", "Mid-high", "High"))
})

test_that("cut_quantile errors informatively when labeller's length doesn't match the actual bin count", {
  expect_error(
    cut_quantile(c(1, 2, 3, 4, 5, 6, 7, 8), n_bins = 4, labeller = c("a", "b")),
    "must produce 4 labels"
  )
  expect_error(
    cut_quantile(c(1, 2, 3, 4, 5, 6, 7, 8), n_bins = 4, labeller = function(n, breaks) "only one"),
    "must produce 4 labels"
  )

  # the actual bin count (after resolution-driven fallback) is what's
  # checked against, not the originally requested n
  x <- c(rep(1, 18), 2)
  expect_warning(
    expect_error(
      cut_quantile(x, n_bins = 4, labeller = c("a", "b", "c", "d")),
      "must produce 1 label"
    ),
    "only 1 are distinguishable"
  )
})

test_that("cut_exposure_quantile's labeller only relabels the non-placebo bins", {
  x <- c(0, 0, 1, 2, 3, 4, 5, 6, 7, 8)
  result <- cut_exposure_quantile(x, n_bins = 4, labeller = c("Low", "Mid-low", "Mid-high", "High"))
  expect_equal(levels(result), c("Placebo", "Low", "Mid-low", "Mid-high", "High"))
})

test_that("cut_exposure_quantile's ties argument only affects the non-placebo bins", {
  x <- c(rep(0, 5), 1:9, rep(10, 5), 11:15)

  upward <- cut_exposure_quantile(x, n_bins = 4, ties = "upward")
  split_even <- cut_exposure_quantile(x, n_bins = 4, ties = "split-even", seed = 314)

  expect_equal(as.integer(table(upward)), c(5, 5, 9, 0, 5))
  expect_equal(sort(as.integer(table(split_even))[-1]), c(4, 5, 5, 5))
  expect_equal(unname(table(split_even)["Placebo"]), 5L)
  expect_equal(attr(split_even, "ties"), "split-even")
})

test_that(".dodge_quantile_strata adds a symmetric, scale-appropriate offset per stratum", {
  summary <- data.frame(
    x_mid = c(10, 10, 50, 50),
    strata = factor(c("Female", "Male", "Female", "Male"), levels = c("Female", "Male"))
  )

  dodged <- .dodge_quantile_strata(summary, exposure_limits = c(0, 100))

  expect_true("x_dodge" %in% names(dodged))
  # offsets are symmetric around x_mid within each bin
  expect_equal(mean(dodged$x_dodge[1:2]) , 10)
  expect_equal(mean(dodged$x_dodge[3:4]), 50)
  # the two strata get distinct positions at the same x_mid
  expect_false(dodged$x_dodge[1] == dodged$x_dodge[2])
  # offset magnitude scales with the exposure range
  dodged_wide <- .dodge_quantile_strata(summary, exposure_limits = c(0, 1000))
  offset_narrow <- dodged$x_dodge[1] - dodged$x_mid[1]
  offset_wide <- dodged_wide$x_dodge[1] - dodged_wide$x_mid[1]
  expect_equal(offset_wide, offset_narrow * 10)
})

test_that(".dodge_quantile_strata handles non-factor strata and a single stratum", {
  summary_char <- data.frame(x_mid = c(5, 5), strata = c("b", "a"))
  dodged_char <- .dodge_quantile_strata(summary_char, exposure_limits = c(0, 10))
  expect_false(dodged_char$x_dodge[1] == dodged_char$x_dodge[2])

  summary_one <- data.frame(x_mid = 5, strata = factor("a"))
  dodged_one <- .dodge_quantile_strata(summary_one, exposure_limits = c(0, 10))
  expect_equal(dodged_one$x_dodge, dodged_one$x_mid)
})

test_that("ci_quantile() brackets the sample quantile with a wider interval at lower conf_level", {
  set.seed(9142)
  x <- rnorm(200)
  ci90 <- ci_quantile(x, prob = 0.1, conf_level = 0.90)
  ci99 <- ci_quantile(x, prob = 0.1, conf_level = 0.99)
  q10 <- unname(stats::quantile(x, 0.1))

  expect_true(ci90["lower"] <= q10 && q10 <= ci90["upper"])
  expect_true(ci99["lower"] <= ci90["lower"])
  expect_true(ci99["upper"] >= ci90["upper"])
  expect_equal(unname(attr(ci90, "conf_level")), 0.90)
})

test_that("ci_quantile() returns NA for fewer than 2 non-missing values", {
  ci <- ci_quantile(c(1, NA), prob = 0.5)
  expect_true(all(is.na(ci)))
})

test_that("ci_quantile() clips to the available order statistics for a small/extreme case", {
  x <- 1:5
  ci <- ci_quantile(x, prob = 0.9, conf_level = 0.99)
  expect_true(ci["lower"] >= min(x) && ci["upper"] <= max(x))
})