tests/testthat/test-evaluation.R

In survalis: Interpretable Survival Machine Learning Framework

test_that("cindex_survmat works on simple no-censoring data and handles ties/columns", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")

  time   <- c(1, 2, 3, 4)
  status <- c(1, 1, 1, 1)
  y      <- survival::Surv(time, status)

  sp <- cbind("t=5" = c(0.1, 0.3, 0.6, 0.8))
  c1 <- cindex_survmat(y, predicted = sp, t_star = 5)
  expect_named(c1, "C index")
  expect_equal(unname(c1), 1, tolerance = 1e-12)

  c2 <- cindex_survmat(y, predicted = sp, t_star = NULL)
  expect_equal(unname(c2), unname(c1), tolerance = 1e-12)

  sp_tie <- cbind("t=5" = c(0.1, 0.1, 0.3, 0.4))
  c_tie <- cindex_survmat(y, predicted = sp_tie, t_star = 5)
  expect_gt(unname(c_tie), 0.5)
  expect_lt(unname(c_tie), 1)

  expect_error(
    cindex_survmat(y, predicted = sp, t_star = 10),
    "not found in predicted survival matrix"
  )

  expect_error(
    cindex_survmat(list(), predicted = sp, t_star = 5),
    "survival object"
  )
})

test_that("auc_survmat works on simple data and is listed as a supported metric", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")

  time <- c(1, 2, 3, 4)
  status <- c(1, 1, 1, 1)
  y <- survival::Surv(time, status)

  sp <- cbind("t=3" = c(0.1, 0.3, 0.6, 0.8))
  auc <- auc_survmat(y, predicted = sp, t_star = 3)
  expect_named(auc, "auc")
  expect_equal(unname(auc), 1, tolerance = 1e-12)

  auc_last <- auc_survmat(y, predicted = sp, t_star = NULL)
  expect_equal(unname(auc_last), unname(auc), tolerance = 1e-12)

  metrics_tbl <- listmetrics()
  expect_true("auc" %in% metrics_tbl$metric)
  expect_identical(metrics_tbl$direction[metrics_tbl$metric == "auc"], "maximize")

  expect_error(
    auc_survmat(y, predicted = sp, t_star = 5),
    "not found in predicted survival matrix"
  )
})

test_that("timeroc_survmat agrees numerically with timeROC::timeROC()", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")
  testthat::skip_if_not_installed("timeROC")

  data(veteran, package = "survalis")
  mod <- fit_coxph(
    survival::Surv(time, status) ~ age + karno + trt + celltype,
    data = veteran
  )
  times <- c(30, 90, 180, 300)
  pred <- predict_coxph(mod, newdata = veteran, times = times)
  y <- survival::Surv(veteran$time, veteran$status)

  ours <- timeroc_survmat(y, predicted = pred, times = times)
  expect_s3_class(ours, "timeroc_survmat")
  expect_named(ours, c("time", "auc"))
  expect_equal(ours$time, times)

  lp <- predict(mod$model, newdata = veteran, type = "lp")
  ref <- timeROC::timeROC(
    T = veteran$time, delta = veteran$status, marker = lp,
    cause = 1, times = times, weighting = "marginal"
  )

  expect_equal(ours$auc, unname(ref$AUC), tolerance = 1e-3)
})

test_that("brier reduces to unweighted score when no censoring; checks length", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")

  time   <- c(1, 2, 4, 6)
  status <- c(1, 1, 1, 1)
  y      <- survival::Surv(time, status)
  t_star <- 3

  pre_sp <- c(0.2, 0.5, 0.7, 0.9)
  exp_val <- mean(c(0.2^2, 0.5^2, (1 - 0.7)^2, (1 - 0.9)^2))

  b <- brier(y, pre_sp = pre_sp, t_star = t_star)
  expect_named(b, "brier")
  expect_equal(unname(b), round(exp_val, 6), tolerance = 1e-12)

  expect_error(
    brier(y, pre_sp = pre_sp[-1], t_star = t_star),
    "Length of predictions"
  )
})

test_that("ibs_survmat integrates Brier over multiple times", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")

  set.seed(1)
  n <- 8
  time   <- c(1,2,3,4,5,6,7,8)
  status <- rep(1, n)
  y      <- survival::Surv(time, status)

  times <- c(2, 4, 6)
  sp <- cbind("t=2" = rep(0.8, n),
              "t=4" = rep(0.6, n),
              "t=6" = rep(0.3, n))

  b_at <- function(t, Scol) {
    early <- which(time <= t)
    late  <- which(time > t)
    mean(c(rep(Scol[1]^2, length(early)), rep((1 - Scol[1])^2, length(late))))
  }
  b2 <- b_at(2, sp[,1]); b4 <- b_at(4, sp[,2]); b6 <- b_at(6, sp[,3])

  dt <- diff(times)
  exp_ibs <- (b2*dt[1] + b4*dt[2]) / (max(times) - min(times))

  ibs <- ibs_survmat(y, sp_matrix = sp, times = times)
  expect_named(ibs, "ibs")
  expect_equal(unname(ibs), round(exp_ibs, 6), tolerance = 1e-12)

  ibs1 <- ibs_survmat(y, sp_matrix = sp[, 1, drop = FALSE], times = times[1])
  expect_equal(unname(ibs1), unname(brier(y, pre_sp = sp[,1], t_star = times[1])))
})

test_that("iae_survmat and ise_survmat are ~0 when mean prediction matches KM", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")

  time   <- c(1,2,3,5,8,9,10,12)
  status <- c(1,1,0,1,0,1,0,1)
  y      <- survival::Surv(time, status)

  km <- survival::survfit(y ~ 1)
  grid <- km$time[km$n.event > 0]
  s_km <- km$surv[km$n.event > 0]

  sp <- matrix(rep(s_km, each = length(time)),
               nrow = length(time), byrow = FALSE)

  iae <- iae_survmat(y, sp_matrix = sp, times = grid)
  ise <- ise_survmat(y, sp_matrix = sp, times = grid)

  expect_named(iae, "iae"); expect_named(ise, "ise")
  expect_equal(unname(iae), 0, tolerance = 1e-8)
  expect_equal(unname(ise), 0, tolerance = 1e-8)
})

test_that("ece_survmat computes a bounded single-time calibration error", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")

  time <- c(1, 2, 3, 4, 6, 7, 8, 9)
  status <- c(1, 1, 0, 1, 0, 1, 1, 0)
  y <- survival::Surv(time, status)

  sp <- cbind("t=5" = c(0.15, 0.20, 0.35, 0.40, 0.55, 0.65, 0.75, 0.80))

  ece <- ece_survmat(y, sp_matrix = sp, t_star = 5, n_bins = 4)
  expect_named(ece, "ece")
  expect_true(is.finite(unname(ece)))
  expect_gte(unname(ece), 0)
  expect_lte(unname(ece), 1)

  expect_error(
    ece_survmat(y, sp_matrix = cbind("t=4" = sp[, 1], "t=6" = sp[, 1]), t_star = 5),
    "not found in sp_matrix"
  )

  expect_error(
    ece_survmat(y, sp_matrix = sp, t_star = c(3, 5)),
    "single numeric value"
  )
})

test_that("cv_survlearner returns the same results with one or multiple cores", {
  testthat::skip_on_cran()
  testthat::skip_if_not_installed("survival")
  testthat::skip_if_not_installed("rsample")

  df <- survival::veteran[, c("time", "status", "age", "karno")]
  form <- survival::Surv(time, status) ~ age + karno

  cv1 <- cv_survlearner(
    formula = form,
    data = df,
    fit_fun = fit_coxph,
    pred_fun = predict_coxph,
    times = 80,
    metrics = c("cindex", "ibs"),
    folds = 3,
    seed = 123,
    verbose = FALSE,
    ncores = 1,
    pb = FALSE
  )

  cv2 <- cv_survlearner(
    formula = form,
    data = df,
    fit_fun = fit_coxph,
    pred_fun = predict_coxph,
    times = 80,
    metrics = c("cindex", "ibs"),
    folds = 3,
    seed = 123,
    verbose = FALSE,
    ncores = 2,
    pb = FALSE
  )

  expect_equal(cv1$value, cv2$value, tolerance = 1e-12)
  expect_identical(cv1$metric, cv2$metric)
  expect_identical(cv1$fold, cv2$fold)
})