tests/testthat/test-tabdiag.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

test_that("tabdiagi calculates a standard 2 x 2 table correctly", {
  x <- tabdiagi(80, 20, 10, 90, show = FALSE)

  expect_s3_class(x, "r4vn_diagi")
  expect_equal(unname(x$estimates["sensitivity"]), 80 / 90)
  expect_equal(unname(x$estimates["specificity"]), 90 / 110)
  expect_equal(unname(x$estimates["ppv"]), 80 / 100)
  expect_equal(unname(x$estimates["npv"]), 90 / 100)
  expect_equal(unname(x$estimates["accuracy"]), 170 / 200)
  expect_equal(unname(x$estimates["lr_pos"]), (80 / 90) / (20 / 110))
  expect_equal(unname(x$estimates["lr_neg"]), (10 / 90) / (90 / 110))
  expect_equal(unname(x$estimates["dor"]), 36)
})

test_that("tabdiagi accepts a b c d aliases", {
  x <- tabdiagi(a = 80, b = 20, c = 10, d = 90, show = FALSE)
  expect_equal(unname(x$estimates["tp"]), 80)
  expect_equal(unname(x$estimates["fp"]), 20)
  expect_equal(unname(x$estimates["fn"]), 10)
  expect_equal(unname(x$estimates["tn"]), 90)
})

test_that("tabdiagi rejects mixed naming systems", {
  expect_error(
    tabdiagi(tp = 80, fp = 20, fn = 10, tn = 90, a = 80, show = FALSE),
    "either"
  )
})

test_that("tabdiagi calculates requested Wilson confidence intervals", {
  x <- tabdiagi(
    80, 20, 10, 90,
    ci = c("sens", "spec"),
    show = FALSE
  )
  expect_true(all(c("sensitivity", "specificity") %in% names(x$ci)))
  expect_true(x$ci$sensitivity[1] < x$estimates["sensitivity"])
  expect_true(x$ci$sensitivity[2] > x$estimates["sensitivity"])
  expect_null(x$ci$ppv)
})

test_that("tabdiagi ci TRUE requests supported intervals", {
  x <- tabdiagi(80, 20, 10, 90, ci = TRUE, show = FALSE)
  expect_true(all(
    c("sensitivity", "specificity", "ppv", "npv", "accuracy", "lr_pos", "lr_neg", "dor") %in%
      names(x$ci)
  ))
})

test_that("tabdiagi prevalence changes PPV and NPV but not sensitivity specificity", {
  x1 <- tabdiagi(80, 20, 10, 90, show = FALSE)
  x2 <- tabdiagi(80, 20, 10, 90, prevalence = 0.10, show = FALSE)

  expect_equal(x1$estimates["sensitivity"], x2$estimates["sensitivity"])
  expect_equal(x1$estimates["specificity"], x2$estimates["specificity"])
  expect_false(isTRUE(all.equal(x1$estimates["ppv"], x2$estimates["ppv"])))
  expect_false(isTRUE(all.equal(x1$estimates["npv"], x2$estimates["npv"])))
})

test_that("tabdiagi handles zero cells without crashing", {
  # FP = 0 -> specificity = 1 -> LR+ = Inf when sensitivity > 0.
  x <- tabdiagi(10, 0, 2, 20, ci = TRUE, show = FALSE)
  expect_true(is.infinite(x$estimates["lr_pos"]))
  expect_gt(unname(x$estimates["lr_pos"]), 0)
  expect_true("dor" %in% names(x$ci))
  expect_true(isTRUE(attr(x$ci$dor, "zero_corrected")))

  # TN = 0 -> specificity = 0 -> LR- = Inf when sensitivity < 1.
  y <- tabdiagi(8, 12, 2, 0, ci = FALSE, show = FALSE)
  expect_true(is.infinite(y$estimates["lr_neg"]))
  expect_gt(unname(y$estimates["lr_neg"]), 0)
})

test_that("tabdiagi validates counts", {
  expect_error(tabdiagi(-1, 2, 3, 4, show = FALSE), "non-negative")
  expect_error(tabdiagi(1.5, 2, 3, 4, show = FALSE), "integer")
  expect_error(tabdiagi(0, 0, 0, 0, show = FALSE), "no observations")
})

# -----------------------------------------------------------------------------
# tabdiag() comprehensive ROC/diagnostic reporting contract
# -----------------------------------------------------------------------------

test_that("tabdiag publication defaults are compact but calculations are complete", {
  expect_identical(formals(tabdiag)$ci, TRUE)
  expect_identical(formals(tabdiag)$measures, "core")
  expect_identical(formals(tabdiag)$interpretation, FALSE)
  expect_identical(formals(tabdiag)$missing, FALSE)

  d <- data.frame(
    disease = c(1, 1, 1, 1, 0, 0, 0, 0),
    rapid = c(1, 1, 1, 0, 1, 0, 0, 0)
  )
  z <- tabdiag(disease, rapid, data = d, show = FALSE)

  expect_s3_class(z, "r4vn_diag")
  expect_true(all(c(
    "descriptive", "estimates", "tests", "diagnostics", "interpretation",
    "tables", "plots", "models", "metadata", "call"
  ) %in% names(z)))
  expect_null(z$interpretation)
  expect_true(all(c("tp", "fp", "fn", "tn", "mcc", "kappa", "dor") %in% names(z$thresholds)))
  expect_true(all(c("Sensitivity", "Specificity", "PPV", "NPV", "LR+", "LR-", "Accuracy") %in%
                    names(z$tables$Diagnostic_performance)))
  expect_false("TP" %in% names(z$tables$Diagnostic_performance))
})

test_that("tabdiag binary calculations agree with tabdiagi", {
  d <- data.frame(
    disease = c(rep(1, 90), rep(0, 110)),
    test = c(rep(1, 80), rep(0, 10), rep(1, 20), rep(0, 90))
  )
  z <- tabdiag(disease, test, data = d, show = FALSE)
  q <- tabdiagi(80, 20, 10, 90, ci = TRUE, show = FALSE)

  expect_equal(z$thresholds$sensitivity[1], unname(q$estimates["sensitivity"]))
  expect_equal(z$thresholds$specificity[1], unname(q$estimates["specificity"]))
  expect_equal(z$thresholds$ppv[1], unname(q$estimates["ppv"]))
  expect_equal(z$thresholds$npv[1], unname(q$estimates["npv"]))
  expect_equal(z$thresholds$dor[1], unname(q$estimates["dor"]))
})

test_that("tabdiag accepts vars() marker selection and preserves requested order", {
  set.seed(101)
  d <- data.frame(
    disease = rep(c(0, 1), each = 40),
    marker1 = c(rnorm(40), rnorm(40, 1.5)),
    marker2 = c(rnorm(40), rnorm(40, 1.0)),
    other = rnorm(80)
  )
  z <- tabdiag(disease, data = d, vars = vars(marker2, marker1), show = FALSE)
  expect_identical(z$settings$markers, c("marker2", "marker1"))
  expect_identical(z$summary$marker, c("marker2", "marker1"))
})

test_that("tabdiag can combine direct markers and vars() without duplication", {
  set.seed(102)
  d <- data.frame(
    disease = rep(c(0, 1), each = 30),
    a = c(rnorm(30), rnorm(30, 1.2)),
    b = c(rnorm(30), rnorm(30, 1.0))
  )
  z <- tabdiag(disease, a, data = d, vars = vars(a, b), show = FALSE)
  expect_identical(z$settings$markers, c("a", "b"))
})

test_that("tabdiag uses variable labels in publication display while retaining names", {
  set.seed(103)
  d <- data.frame(
    disease = rep(c(0, 1), each = 35),
    crp = c(rnorm(35, 4, 1), rnorm(35, 8, 1.5))
  )
  attr(d$disease, "label") <- "Reference diagnosis"
  attr(d$crp, "label") <- "C-reactive protein"
  z <- tabdiag(disease, crp, data = d, show = FALSE)

  expect_identical(z$summary$marker[1], "crp")
  expect_identical(z$summary$marker_label[1], "C-reactive protein")
  expect_identical(z$tables$ROC_summary$Marker[1], "C-reactive protein")
  expect_identical(z$metadata$outcome_label, "Reference diagnosis")
})

test_that("tabdiag continuous marker returns AUC inference and selected cutoff metrics", {
  set.seed(104)
  d <- data.frame(
    disease = rep(c(0, 1), each = 60),
    marker = c(rnorm(60, 0, 1), rnorm(60, 1.5, 1))
  )
  z <- tabdiag(disease, marker, data = d, show = FALSE)

  expect_equal(nrow(z$summary), 1L)
  expect_true(is.finite(z$summary$auc[1]))
  expect_true(is.finite(z$summary$auc_low[1]))
  expect_true(is.finite(z$summary$auc_high[1]))
  expect_true("Youden" %in% z$thresholds$criterion)
  expect_true(all(c("auc", "auc_se", "auc_z", "auc_p") %in% names(z$tests$auc_vs_0.5)))
})

test_that("tabdiag user cutoffs are retained as separate rows", {
  set.seed(105)
  d <- data.frame(
    disease = rep(c(0, 1), each = 50),
    marker = c(rnorm(50, 4, 1), rnorm(50, 7, 1.5))
  )
  z <- tabdiag(disease, marker, data = d, cuts = c(4, 5, 6), show = FALSE)
  u <- z$thresholds[z$thresholds$criterion == "User specified", , drop = FALSE]
  expect_equal(sort(u$cutoff), c(4, 5, 6))
})

test_that("tabdiag supports all optimal cutoff definitions", {
  set.seed(106)
  d <- data.frame(
    disease = rep(c(0, 1), each = 80),
    marker = c(rnorm(80, 0, 1), rnorm(80, 2, 1))
  )
  z <- tabdiag(
    disease, marker, data = d,
    best = c("youden", "closest", "ruleout", "rulein"),
    target = 0.85, show = FALSE
  )
  expect_true(any(grepl("Youden", z$thresholds$criterion)))
  expect_true(any(grepl("Closest", z$thresholds$criterion)))
  expect_true(any(grepl("Rule-out", z$thresholds$criterion)))
  expect_true(any(grepl("Rule-in", z$thresholds$criterion)))
})

test_that("tabdiag can suppress automatic cutoff selection", {
  set.seed(107)
  d <- data.frame(
    disease = rep(c(0, 1), each = 40),
    marker = c(rnorm(40), rnorm(40, 1.2))
  )
  z <- tabdiag(disease, marker, data = d, best = NULL, cuts = 0.5, show = FALSE)
  expect_identical(unique(z$thresholds$criterion), "User specified")
})

test_that("tabdiag display profiles do not alter stored calculations", {
  set.seed(108)
  d <- data.frame(
    disease = rep(c(0, 1), each = 40),
    marker = c(rnorm(40), rnorm(40, 1.2))
  )
  z0 <- tabdiag(disease, marker, data = d, measures = "minimal", show = FALSE)
  z1 <- tabdiag(disease, marker, data = d, measures = "all", show = FALSE)
  z2 <- tabdiag(disease, marker, data = d, measures = "counts", show = FALSE)

  expect_equal(z0$thresholds, z1$thresholds)
  expect_true(all(c("Sensitivity", "Specificity", "PPV", "NPV") %in% names(z0$tables$Diagnostic_performance)))
  expect_false(any(c("TP", "FP", "FN", "TN") %in% names(z1$tables$Diagnostic_performance)))
  expect_false(any(c("TP", "FP", "FN", "TN") %in% names(z2$tables$Diagnostic_performance)))
  expect_true(all(c("Test result", "Reference positive", "Reference negative", "Total") %in%
                    names(z2$tables$Confusion_matrix)))
  expect_true("MCC" %in% names(z1$tables$Diagnostic_performance))
})

test_that("tabdiag hide works after display profile selection", {
  d <- data.frame(
    disease = c(1, 1, 1, 1, 0, 0, 0, 0),
    rapid = c(1, 1, 1, 0, 1, 0, 0, 0)
  )
  z <- tabdiag(disease, rapid, data = d, measures = "publication", hide = c("npv", "accuracy"), show = FALSE)
  expect_false("NPV" %in% names(z$tables$Diagnostic_performance))
  expect_false("Accuracy" %in% names(z$tables$Diagnostic_performance))
  expect_true("DOR" %in% names(z$tables$Diagnostic_performance))
})

test_that("tabdiag target prevalence changes predictive values but not sensitivity specificity", {
  d <- data.frame(
    disease = c(rep(1, 50), rep(0, 50)),
    test = c(rep(1, 40), rep(0, 10), rep(1, 10), rep(0, 40))
  )
  z1 <- tabdiag(disease, test, data = d, show = FALSE)
  z2 <- tabdiag(disease, test, data = d, prevalence = 0.10, show = FALSE)
  expect_equal(z1$thresholds$sensitivity, z2$thresholds$sensitivity)
  expect_equal(z1$thresholds$specificity, z2$thresholds$specificity)
  expect_false(isTRUE(all.equal(z1$thresholds$ppv, z2$thresholds$ppv)))
  expect_false(isTRUE(all.equal(z1$thresholds$npv, z2$thresholds$npv)))
})

test_that("tabdiag pairwise DeLong comparison reports pair-specific N and adjustment", {
  set.seed(109)
  d <- data.frame(
    disease = rep(c(0, 1), each = 60),
    m1 = c(rnorm(60), rnorm(60, 1.6)),
    m2 = c(rnorm(60), rnorm(60, 1.1)),
    m3 = c(rnorm(60), rnorm(60, 0.8))
  )
  d$m1[1:5] <- NA
  d$m2[11:18] <- NA
  z <- tabdiag(disease, m1, m2, m3, data = d, compare = TRUE, adjust = "holm", show = FALSE)

  expect_equal(nrow(z$comparison), 3L)
  expect_true(all(z$comparison$n <= nrow(d)))
  expect_true(all(c("p", "p_adjusted", "difference", "lower", "upper") %in% names(z$comparison)))
  expect_identical(z$tests$roc_comparison, z$comparison)
})

test_that("tabdiag constant ROC marker is omitted with a note rather than crashing", {
  d <- data.frame(
    disease = rep(c(0, 1), each = 20),
    constant = rep(5, 40),
    useful = c(rnorm(20), rnorm(20, 1.5))
  )
  z <- tabdiag(disease, constant, useful, data = d, show = FALSE)
  expect_false("constant" %in% z$summary$marker)
  expect_true(any(grepl("constant", z$notes, ignore.case = TRUE)))
  expect_true(any(grepl("constant marker", z$descriptive$analysis, ignore.case = TRUE)))
})

test_that("tabdiag unordered factor with more than two levels is rejected", {
  d <- data.frame(
    disease = rep(c(0, 1), each = 6),
    marker = factor(rep(c("low", "mid", "high"), 4))
  )
  expect_error(tabdiag(disease, marker, data = d, show = FALSE), "unordered factor")
})

test_that("tabdiag ordered factor is accepted for ROC analysis", {
  d <- data.frame(
    disease = c(0, 0, 0, 0, 1, 1, 1, 1, 1, 0),
    score = ordered(
      c("Low", "Low", "Medium", "Low", "Medium", "High", "High", "Medium", "High", "Medium"),
      levels = c("Low", "Medium", "High")
    )
  )
  z <- tabdiag(disease, score, data = d, show = FALSE)
  expect_equal(nrow(z$summary), 1L)
  expect_identical(z$summary$marker, "score")
})

test_that("tabdiag retains marker-specific missing-data accounting", {
  set.seed(110)
  d <- data.frame(
    disease = rep(c(0, 1), each = 30),
    m1 = c(rnorm(30), rnorm(30, 1.5)),
    m2 = c(rnorm(30), rnorm(30, 1.0))
  )
  d$m1[1:4] <- NA
  d$m2[10:16] <- NA
  z <- tabdiag(disease, m1, m2, data = d, missing = TRUE, show = FALSE)
  expect_equal(z$descriptive$missing[z$descriptive$marker == "m1"], 4L)
  expect_equal(z$descriptive$missing[z$descriptive$marker == "m2"], 7L)
  expect_true(nrow(z$tables$Sample) == 2L)
})

test_that("tabdiag all_cuts retains complete threshold metrics", {
  set.seed(111)
  d <- data.frame(
    disease = rep(c(0, 1), each = 25),
    marker = c(rnorm(25), rnorm(25, 1.2))
  )
  z <- tabdiag(disease, marker, data = d, all_cuts = TRUE, show = FALSE)
  expect_gt(nrow(z$all_cutoffs), 0L)
  expect_true(all(c("sensitivity", "specificity", "ppv", "npv", "dor", "mcc") %in% names(z$all_cutoffs)))
  expect_identical(z$diagnostics$all_cutoffs, z$all_cutoffs)
})

test_that("tabdiag interpretation is explicit opt-in and cautious", {
  set.seed(112)
  d <- data.frame(
    disease = rep(c(0, 1), each = 40),
    marker = c(rnorm(40), rnorm(40, 1.8))
  )
  z0 <- tabdiag(disease, marker, data = d, show = FALSE)
  z1 <- tabdiag(disease, marker, data = d, interpretation = TRUE, show = FALSE)
  expect_null(z0$interpretation)
  expect_true(is.data.frame(z1$interpretation))
  expect_gt(nrow(z1$interpretation), 0L)
  expect_true(any(grepl("clinical utility|externally validated", z1$interpretation$interpretation, ignore.case = TRUE)))
})

test_that("tabdiag partial AUC is retained", {
  set.seed(113)
  d <- data.frame(
    disease = rep(c(0, 1), each = 40),
    marker = c(rnorm(40), rnorm(40, 1.5))
  )
  z <- tabdiag(
    disease, marker, data = d,
    partial_auc = c(1, 0.80), partial_focus = "specificity",
    partial_correct = TRUE, ci = FALSE, show = FALSE
  )
  expect_true(is.finite(z$summary$partial_auc[1]))
})

test_that("tabdiag supports lower values indicating disease", {
  set.seed(114)
  d <- data.frame(
    disease = rep(c(0, 1), each = 40),
    marker = c(rnorm(40, 2), rnorm(40, -1))
  )
  z <- tabdiag(disease, marker, data = d, direction = ">", show = FALSE)
  expect_identical(z$summary$direction[1], "lower = positive")
  expect_true(all(z$thresholds$direction[z$thresholds$marker == "marker"] == "<="))
})

test_that("tabdiag validates new presentation arguments", {
  d <- data.frame(
    disease = c(1, 1, 0, 0),
    rapid = c(1, 0, 1, 0)
  )
  expect_error(tabdiag(disease, rapid, data = d, interpretation = NA, show = FALSE), "interpretation")
  expect_error(tabdiag(disease, rapid, data = d, missing = NA, show = FALSE), "missing")
  expect_error(tabdiag(disease, rapid, data = d, plot_args = list(1), show = FALSE), "named list")
})

test_that("tabdiag ROC plotting enforces 0-1 axes and accepts styling controls", {
  set.seed(115)
  d <- data.frame(
    disease = rep(c(0, 1), each = 30),
    m1 = c(rnorm(30), rnorm(30, 1.5)),
    m2 = c(rnorm(30), rnorm(30, 1.0))
  )
  z <- tabdiag(disease, m1, m2, data = d, show = FALSE)
  f <- tempfile(fileext = ".pdf")
  grDevices::pdf(f)
  on.exit({
    grDevices::dev.off()
    unlink(f)
  }, add = TRUE)
  expect_silent(plot(
    z, what = "roc", xlim = c(-0.2, 1.2), ylim = c(-0.1, 1.1),
    line_width = 1.5, diagonal = TRUE, grid = TRUE, legend = TRUE
  ))
  u <- graphics::par("usr")
  expect_equal(u[1:2], c(0, 1), tolerance = 1e-8)
  expect_equal(u[3:4], c(0, 1), tolerance = 1e-8)
})

test_that("tabdiag cutoff plotting works for more than one marker", {
  set.seed(116)
  d <- data.frame(
    disease = rep(c(0, 1), each = 25),
    m1 = c(rnorm(25), rnorm(25, 1.2)),
    m2 = c(rnorm(25), rnorm(25, 0.8))
  )
  z <- tabdiag(disease, m1, m2, data = d, show = FALSE)
  f <- tempfile(fileext = ".pdf")
  grDevices::pdf(f)
  on.exit({
    grDevices::dev.off()
    unlink(f)
  }, add = TRUE)
  expect_silent(plot(z, what = "cutoff", cutoff_mark = TRUE))
})

test_that("tabdiag retains a readable confusion-matrix table", {
  d <- data.frame(
    disease = c(1, 1, 1, 1, 0, 0, 0, 0),
    rapid = c(1, 1, 1, 0, 1, 0, 0, 0)
  )
  z <- tabdiag(disease, rapid, data = d, measures = "all", show = FALSE)
  cm <- z$tables$Confusion_matrix
  expect_true(is.data.frame(cm))
  expect_equal(nrow(cm), 3L)
  expect_true(all(c("Test result", "Reference positive", "Reference negative", "Total") %in% names(cm)))
  expect_equal(cm$`Reference positive`[cm$`Test result` == "Positive"], 3L)
  expect_equal(cm$`Reference negative`[cm$`Test result` == "Positive"], 1L)
  expect_equal(cm$`Reference positive`[cm$`Test result` == "Negative"], 1L)
  expect_equal(cm$`Reference negative`[cm$`Test result` == "Negative"], 3L)
  expect_equal(cm$Total[cm$`Test result` == "Total"], 8L)
})

test_that("tabdiag Viewer uses a 2 x 2 classification table for binary tests", {
  d <- data.frame(
    disease = c(1, 1, 1, 1, 0, 0, 0, 0),
    rapid = c(1, 1, 1, 0, 1, 0, 0, 0)
  )
  z <- tabdiag(disease, rapid, data = d, measures = "all", show = FALSE)
  rendered <- .r4vn_viewer_tabdiag(z)
  expect_match(rendered$html, "2 x 2 diagnostic classification", fixed = TRUE)
  expect_match(rendered$html, "Reference positive", fixed = TRUE)
  expect_match(rendered$html, "Reference negative", fixed = TRUE)
  expect_false(grepl(">TP<", rendered$html, fixed = TRUE))
  expect_false(grepl(">FP<", rendered$html, fixed = TRUE))
  expect_false(grepl(" | </h2>", rendered$html, fixed = TRUE))
})

test_that("tabdiag requested plots are retained and embedded in Viewer output", {
  set.seed(118)
  d <- data.frame(
    disease = rep(c(0, 1), each = 25),
    marker = c(rnorm(25), rnorm(25, 1.4))
  )
  z <- tabdiag(disease, marker, data = d, plot = "both", show = FALSE)
  expect_true(all(c("roc", "cutoff") %in% names(z$plots)))
  expect_true(all(vapply(z$plots, file.exists, logical(1))))
  rendered <- .r4vn_viewer_tabdiag(z)
  expect_true(file.exists(rendered$file))
  expect_match(rendered$html, "<img", fixed = TRUE)
  expect_match(rendered$html, "ROC curve", fixed = TRUE)
  expect_match(rendered$html, "Sensitivity and specificity across thresholds", fixed = TRUE)
})

test_that("plot.r4vn_diag can save publication graphics directly", {
  set.seed(117)
  d <- data.frame(
    disease = rep(c(0, 1), each = 25),
    marker = c(rnorm(25), rnorm(25, 1.3))
  )
  z <- tabdiag(disease, marker, data = d, show = FALSE)
  f <- tempfile(fileext = ".pdf")
  on.exit(unlink(f), add = TRUE)
  expect_silent(plot(z, what = "roc", file = f, width = 6, height = 6))
  expect_true(file.exists(f))
  expect_gt(file.info(f)$size, 0)
})