tests/testthat/test-brier-ibs.R

In partDSA: Partitioning Using Deletion, Substitution, and Addition Moves

# Regression test for the Integrated Brier Score (IBS) reporting.
#
# Previously the per-time-point Brier scores were combined with a raw
# sum (default IBS.wt = rep(1, length(brier.vec))), so supplying k time
# points inflated the reported "Brier score" by roughly a factor of k
# and pushed it outside the valid [0, 0.25] range.  The default is now a
# proper trapezoidal integration (weights sum to 1), so the reported
# value stays a genuine (integrated) Brier score.

make_surv_data <- function(n = 250, p = 5, seed = 1) {
  set.seed(seed)
  x <- data.frame(matrix(sample(1:100, n * p, replace = TRUE), n, p))
  names(x) <- paste0("X", seq_len(p))
  scale <- ifelse(x[[1]] > 50 | x[[2]] > 75, 5, 0.5)
  time <- -scale * log(1 - runif(n))
  cens <- rbinom(n, 1, 0.7)
  y <- survival::Surv(pmin(time, quantile(time, 0.95)), cens)
  list(x = x, y = y)
}

test_that("ibs.trapezoid.weights sum to 1 and handle a single time point", {
  expect_equal(ibs.trapezoid.weights(5), 1)
  w <- ibs.trapezoid.weights(c(1, 2, 4, 8))
  expect_equal(sum(w), 1)
  expect_true(all(w >= 0))
  # evenly spaced grid -> interior points weighted twice the endpoints
  we <- ibs.trapezoid.weights(c(0, 1, 2, 3))
  expect_equal(we, c(0.5, 1, 1, 0.5) / 3)
})

test_that("single-cutpoint Brier is a valid Brier score (unchanged behavior)", {
  d <- make_surv_data()
  ctrl <- DSA.control(vfold = 1, MPD = 0.05, minsplit = 40, minbuck = 15,
                      loss.function = "Brier", cut.off.growth = 4,
                      missing = "no")
  fit <- partDSA(d$x, d$y, control = ctrl)
  r <- fit$test.set.risk.DSA
  r <- r[!is.na(r)]
  expect_true(all(r >= 0 & r <= 0.25),
              info = paste("risks:", paste(round(r, 4), collapse = ", ")))
})

test_that("multi-cutpoint IBS stays on the [0, 0.25] Brier scale", {
  d <- make_surv_data()
  bv <- as.numeric(quantile(d$y[, 1], c(0.25, 0.5, 0.75)))
  ctrl <- DSA.control(vfold = 1, MPD = 0.05, minsplit = 40, minbuck = 15,
                      loss.function = "Brier", brier.vec = bv,
                      cut.off.growth = 4, missing = "no")
  fit <- partDSA(d$x, d$y, control = ctrl)
  r <- fit$test.set.risk.DSA
  r <- r[!is.na(r)]
  # before the fix these summed to ~0.43-0.64; a proper IBS must be <= 0.25
  expect_true(all(r >= 0 & r <= 0.25),
              info = paste("IBS:", paste(round(r, 4), collapse = ", ")))
})

test_that("unsorted brier.vec is handled (weights follow sorted times)", {
  d <- make_surv_data(seed = 3)
  bv <- as.numeric(quantile(d$y[, 1], c(0.75, 0.25, 0.5)))  # deliberately unsorted
  ctrl <- DSA.control(vfold = 1, MPD = 0.05, minsplit = 40, minbuck = 15,
                      loss.function = "Brier", brier.vec = bv,
                      cut.off.growth = 3, missing = "no")
  expect_no_error(fit <- partDSA(d$x, d$y, control = ctrl))
  r <- fit$test.set.risk.DSA
  r <- r[!is.na(r)]
  expect_true(all(r >= 0 & r <= 0.25))
})