tests/testthat/test-tablearn.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# tests/testthat/test-tablearn.R

testthat::test_that("explicit data is resolved from the test calling environment", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    time,
    data = lc_test,
    order = case,
    window = 5,
    breakpoint = FALSE,
    smooth = FALSE,
    plot = FALSE,
    console = FALSE,
    show = FALSE
  )
  testthat::expect_equal(nrow(x$raw), nrow(lc_test))
  testthat::expect_equal(x$raw$.value, lc_test$time, tolerance = 1e-10)
})


testthat::test_that("rolling windows are 1-5, 2-6, 3-7", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, window = 5,
                window_type = "rolling", window_align = "right",
                window_step = 1, breakpoint = FALSE, smooth = FALSE,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_equal(x$window$.start[1:3], c(1L, 2L, 3L))
  testthat::expect_equal(x$window$.end[1:3], c(5L, 6L, 7L))
  testthat::expect_equal(x$window$.value[1], mean(lc_test$time[1:5]), tolerance = 1e-10)
  testthat::expect_equal(x$window$.value[2], mean(lc_test$time[2:6]), tolerance = 1e-10)
})


testthat::test_that("block windows are non-overlapping", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, window = 5,
                window_type = "block", breakpoint = FALSE, smooth = FALSE,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_equal(x$window$.start[1:3], c(1L, 6L, 11L))
  testthat::expect_equal(x$window$.end[1:3], c(5L, 10L, 15L))
})


testthat::test_that("binary rolling outcome uses proportions", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(complication, data = lc_test, order = case, event = 1,
                window = 20, breakpoint = FALSE, smooth = FALSE,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_equal(x$window$.value[1], mean(lc_test$complication[1:20]), tolerance = 1e-10)
  testthat::expect_equal(x$window$.events[1], sum(lc_test$complication[1:20]))
  testthat::expect_true(x$window$.lower[1] >= 0 && x$window$.upper[1] <= 1)
})


testthat::test_that("current performance is the most recent rolling window", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, window = 10,
                breakpoint = FALSE, smooth = FALSE, plot = FALSE,
                console = FALSE, show = FALSE)
  testthat::expect_equal(x$current$estimate[1], mean(tail(lc_test$time, 10)), tolerance = 1e-10)
  testthat::expect_equal(x$current$window_start[1], 111)
  testthat::expect_equal(x$current$window_end[1], 120)
})


testthat::test_that("EWMA has one value per case", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, window = 5, ewma = TRUE,
                breakpoint = FALSE, smooth = FALSE, plot = FALSE,
                console = FALSE, show = FALSE)
  testthat::expect_equal(nrow(x$ewma), n)
  testthat::expect_true(all(is.finite(x$ewma$.value)))
})


testthat::test_that("piecewise breakpoint returns a structured result", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, window = 5,
                breakpoint = TRUE, break_min_n = 10, smooth = FALSE,
                plot = FALSE, console = FALSE, show = FALSE)
  bp <- x$breakpoint[[1]]
  testthat::expect_true(is.list(bp))
  testthat::expect_true(is.finite(bp$breakpoint))
  testthat::expect_true(is.logical(bp$detected))
})


testthat::test_that("LC-CUSUM produces decision limit and sequential scores", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(complication, data = lc_test, order = case, event = 1,
                window = 20, breakpoint = FALSE, smooth = FALSE,
                lccusum = TRUE, p_acceptable = 0.10, p_unacceptable = 0.25,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_equal(nrow(x$lccusum), n)
  testthat::expect_true(all(is.finite(x$lccusum$.limit)))
})


testthat::test_that("RA-CUSUM accepts case-specific expected risks", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(complication, data = lc_test, order = case, event = 1,
                window = 20, breakpoint = FALSE, smooth = FALSE,
                racusum = TRUE, expected = lc_test$risk, racusum_or = 2,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_equal(nrow(x$racusum), n)
  testthat::expect_true(all(x$racusum$.value >= 0))
})


testthat::test_that("operator-specific curves restart sequence within operator", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, operator = surgeon,
                window = 5, breakpoint = FALSE, smooth = FALSE,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_equal(sort(unique(x$raw$.operator)), c("A", "B"))

  mins <- tapply(x$raw$.case, x$raw$.operator, min)
  testthat::expect_equal(as.numeric(mins), c(1, 1))
  testthat::expect_equal(as.character(dimnames(mins)[[1L]]), c("A", "B"))
})


testthat::test_that("window sensitivity returns requested windows", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(time, data = lc_test, order = case, window = 5,
                breakpoint = FALSE, smooth = FALSE, sensitivity = TRUE,
                window_sensitivity = c(3, 5, 10), plot = FALSE,
                console = FALSE, show = FALSE)
  testthat::expect_equal(x$sensitivity$window, c(3, 5, 10))
})


testthat::test_that("plot is a ggplot when ggplot2 is available", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  testthat::skip_if_not_installed("ggplot2")
  x <- tablearn(time, data = lc_test, order = case, window = 5,
                plot = TRUE, console = FALSE, show = FALSE)
  testthat::expect_s3_class(x$plots$learning, "ggplot")
})


testthat::test_that("CUSUM plot honors plot creation path", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  testthat::skip_if_not_installed("ggplot2")
  x <- tablearn(complication, data = lc_test, order = case, event = 1,
                window = 20, breakpoint = FALSE, smooth = FALSE,
                lccusum = TRUE, p_acceptable = 0.10, p_unacceptable = 0.25,
                plot = TRUE, plot_type = "both",
                plot_opts = list(cusum = list(line_width = 1.4, points = TRUE)),
                console = FALSE, show = FALSE)
  testthat::expect_s3_class(x$plots$cusum, "ggplot")
})


testthat::test_that("multiple outcomes return a multi-outcome object", {
  lc_test <- .tablearn_test_data()
  n <- nrow(lc_test)
  x <- tablearn(c("time", "complication"), data = lc_test, order = case,
                event = 1, window = 10, breakpoint = FALSE, smooth = FALSE,
                plot = FALSE, console = FALSE, show = FALSE)
  testthat::expect_s3_class(x, "r4vn_tablearn_multi")
  testthat::expect_equal(names(x$outcomes), c("time", "complication"))
})


testthat::test_that("auto type keeps non-0/1 two-valued numeric outcomes continuous", {
  d <- data.frame(case = 1:20, time = c(rep(100, 10), rep(50, 10)))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_equal(x$settings$type, "continuous")
  testthat::expect_equal(x$window$.value[1], 100)
  testthat::expect_equal(x$window$.value[11], 50)
})


testthat::test_that("numeric two-level coding is binary when event is explicit", {
  d <- data.frame(case = 1:20, outcome = rep(c(1, 2), 10))
  x <- tablearn(
    outcome, data = d, order = case, event = 2, window = 5,
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_equal(x$settings$type, "binary")
  testthat::expect_true(all(x$window$.value >= 0 & x$window$.value <= 1))
})


testthat::test_that("target proficiency requires sustained rolling performance", {
  d <- data.frame(case = 1:40, time = c(rep(100, 10), rep(50, 30)))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    target = 55, target_hold = 3,
    proficiency_method = "target",
    phase_method = "proficiency",
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_true(x$proficiency$achieved[1])
  testthat::expect_equal(x$proficiency$target_first_case[1], 15)
  testthat::expect_equal(x$proficiency$target_confirmed_case[1], 17)
  testthat::expect_equal(x$proficiency$proficiency_case[1], 17)
  testthat::expect_true(x$proficiency$target_current[1])
  testthat::expect_equal(x$phases$phase, c("Learning", "Proficiency"))
  testthat::expect_equal(x$phases$end[1], 16)
  testthat::expect_equal(x$phases$start[2], 17)
})


testthat::test_that("first_stable reports the beginning of a sustained target run", {
  d <- data.frame(case = 1:40, time = c(rep(100, 10), rep(50, 30)))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    target = 55, target_hold = 3,
    proficiency_method = "target",
    proficiency_case_rule = "first_stable",
    breakpoint = FALSE, phase = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_equal(x$proficiency$proficiency_case[1], 15)
})


testthat::test_that("a supplied target prevents false proficiency when target is not reached", {
  d <- data.frame(case = 1:60, time = c(seq(110, 75, length.out = 25), rep(72, 35)))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    target = 60, target_hold = 3,
    proficiency_method = "combined",
    breakpoint = TRUE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_false(x$proficiency$achieved[1])
  testthat::expect_equal(x$proficiency$status[1], "Not achieved")
  testthat::expect_false(isTRUE(x$proficiency$target_achieved[1]))
  testthat::expect_false(any(x$phases$phase == "Proficiency"))
})


testthat::test_that("manual proficiency and manual phases are supported", {
  d <- data.frame(case = 1:50, time = seq(100, 60, length.out = 50))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    proficiency_method = "manual", proficiency_case = 30,
    phase_breaks = c(15, 29),
    phase_names = c("Initial learning", "Consolidation", "Proficiency"),
    phase_method = "manual",
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_true(x$proficiency$achieved[1])
  testthat::expect_equal(x$proficiency$status[1], "User-defined")
  testthat::expect_equal(x$proficiency$proficiency_case[1], 30)
  testthat::expect_equal(
    x$phases$phase,
    c("Initial learning", "Consolidation", "Proficiency")
  )
})


testthat::test_that("LC-CUSUM proficiency feeds the proficiency engine", {
  d <- data.frame(case = 1:60, failure = c(rep(1, 5), rep(0, 55)))
  x <- tablearn(
    failure, data = d, order = case, event = 1,
    better = "lower", window = 10,
    lccusum = TRUE, p_acceptable = 0.10, p_unacceptable = 0.30,
    proficiency_method = "lccusum",
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_true(x$proficiency$achieved[1])
  testthat::expect_true(is.finite(x$proficiency$lccusum_case[1]))
  testthat::expect_equal(
    x$proficiency$proficiency_case[1],
    x$proficiency$lccusum_case[1]
  )
})


testthat::test_that("proficiency evidence and current status are returned", {
  d <- data.frame(case = 1:40, time = c(rep(100, 10), rep(50, 30)))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    target = 60, target_hold = 2,
    proficiency_method = "target",
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    console = FALSE, show = FALSE
  )
  testthat::expect_true(is.data.frame(x$proficiency_evidence))
  testthat::expect_true(all(c("criterion", "available", "met", "case") %in% names(x$proficiency_evidence)))
  testthat::expect_true(is.data.frame(x$current_status))
  testthat::expect_equal(x$current_status$current_phase[1], "Proficiency")
  testthat::expect_true(x$current_status$cases_since_proficiency[1] >= 0)
})


testthat::test_that("proficiency plot layer has independent styling", {
  d <- data.frame(case = 1:40, time = c(rep(100, 10), rep(50, 30)))
  x <- tablearn(
    time, data = d, order = case, window = 5,
    target = 60, proficiency_method = "target",
    breakpoint = FALSE, smooth = FALSE, plot = FALSE,
    plot_opts = list(proficiency = list(color = "purple", line_width = 2.2, label = FALSE)),
    console = FALSE, show = FALSE
  )
  testthat::expect_equal(x$plot_options$proficiency$color, "purple")
  testthat::expect_equal(x$plot_options$proficiency$line_width, 2.2)
  testthat::expect_false(x$plot_options$proficiency$label)
})


testthat::test_that("publication-ready tables are returned for standard analyses", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    time, data = lc_test, order = case, window = 5,
    target = 70, breakpoint = TRUE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  testthat::expect_true(is.list(x$tables))
  testthat::expect_true(all(c(
    "Overview", "Current_performance", "Change_point", "Proficiency",
    "Proficiency_evidence", "Phase_classification", "Window_performance",
    "Window_sensitivity", "Sequential_monitoring"
  ) %in% names(x$tables)))
  testthat::expect_true(is.data.frame(x$tables$Current_performance))
  testthat::expect_true(is.data.frame(x$tables$Window_performance))
})


testthat::test_that("binary Viewer tables use percentages and percentage-point change", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    complication, data = lc_test, order = case, event = 1,
    target = 0.10, window = 20, breakpoint = FALSE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  tab <- x$tables$Current_performance
  testthat::expect_true("Change (percentage points)" %in% names(tab))
  testthat::expect_true(grepl("%", tab$`Estimate (95% CI)`[1], fixed = TRUE))
  testthat::expect_true(grepl("%", tab$Target[1], fixed = TRUE))
})


testthat::test_that("vars prefixes are resolved for RA-CUSUM adjustment", {
  lc_test <- .tablearn_test_data()
  x <- NULL
  testthat::expect_warning(
    x <- tablearn(
      complication, data = lc_test, order = case, event = 1,
      racusum = TRUE, adjust = vars(c.complexity), racusum_or = 2,
      breakpoint = FALSE, smooth = FALSE,
      plot = FALSE, console = FALSE, show = FALSE
    ),
    "RA-CUSUM expected risks are being estimated from the same analyzed dataset"
  )
  testthat::expect_equal(nrow(x$racusum), nrow(lc_test))
  testthat::expect_true(all(is.finite(x$racusum$.expected)))
})


testthat::test_that("plot_type auto includes sequential panel when CUSUM is requested", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    complication, data = lc_test, order = case, event = 1,
    lccusum = TRUE, p_acceptable = 0.10, p_unacceptable = 0.25,
    breakpoint = FALSE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  testthat::expect_equal(x$settings$plot_type, "both")
})


testthat::test_that("sequential monitoring table carries decision limits", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    complication, data = lc_test, order = case, event = 1,
    cusum = TRUE, target = 0.10, cusum_method = "llr", cusum_alt = 0.25,
    cusum_limit = 4,
    racusum = TRUE, expected = risk, racusum_or = 2, racusum_limit = 5,
    breakpoint = FALSE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  tab <- x$tables$Sequential_monitoring
  testthat::expect_true(any(tab$Method == "CUSUM" & tab$`Decision limit` == "4.00"))
  testthat::expect_true(any(tab$Method == "RA-CUSUM" & tab$`Decision limit` == "5.00"))
})


testthat::test_that("base learning plot works even when no ggplot was created", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    time, data = lc_test, order = case, window = 5,
    breakpoint = FALSE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  tf <- tempfile(fileext = ".pdf")
  grDevices::pdf(tf)
  on.exit({
    try(grDevices::dev.off(), silent = TRUE)
    unlink(tf)
  }, add = TRUE)
  testthat::expect_silent(plot(x, type = "learning"))
  grDevices::dev.off()
  testthat::expect_true(file.exists(tf))
})


testthat::test_that("base CUSUM plot works without a ggplot object", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    complication, data = lc_test, order = case, event = 1,
    lccusum = TRUE, p_acceptable = 0.10, p_unacceptable = 0.25,
    breakpoint = FALSE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  tf <- tempfile(fileext = ".pdf")
  grDevices::pdf(tf)
  on.exit({
    try(grDevices::dev.off(), silent = TRUE)
    unlink(tf)
  }, add = TRUE)
  testthat::expect_silent(plot(x, type = "cusum"))
  grDevices::dev.off()
  testthat::expect_true(file.exists(tf))
})


testthat::test_that("Viewer HTML embeds requested plots without external HTML packages", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    complication, data = lc_test, order = case, event = 1,
    lccusum = TRUE, p_acceptable = 0.10, p_unacceptable = 0.25,
    breakpoint = FALSE, smooth = FALSE,
    plot = TRUE, plot_type = "both", viewer_plot_format = "svg",
    console = FALSE, show = FALSE
  )
  doc <- .r4vn_viewer_tablearn(x)
  on.exit(unlink(doc$file), add = TRUE)
  testthat::expect_true(file.exists(doc$file))
  testthat::expect_true(grepl("Current performance", doc$html, fixed = TRUE))
  testthat::expect_true(grepl("Learning curve", doc$html, fixed = TRUE))
  testthat::expect_true(grepl("Sequential monitoring", doc$html, fixed = TRUE))
  testthat::expect_true(grepl("data:image/svg+xml;base64,", doc$html, fixed = TRUE))
})


testthat::test_that("interpretation is opt-in by default", {
  lc_test <- .tablearn_test_data()
  x <- tablearn(
    time, data = lc_test, order = case,
    breakpoint = FALSE, smooth = FALSE,
    plot = FALSE, console = FALSE, show = FALSE
  )
  testthat::expect_false(x$settings$interpretation)
  testthat::expect_true(is.character(x$interpretation))
})