tests/testthat/test-delta-null.R

In grassr: Context-Conditioned Reporting for Binary Rater Reliability

# Tests for the v0.8.0 matched-null lookup: v3 resolved lattice
# (11 k x 12 N x 11 q x 8 prev, every cell prevalence-resolved),
# integer-delta decode, interpolation in q / log10 N / prevalence,
# mid-p percentile convention.

test_that("lookup_delta_null resolves exact nodes and discloses snaps", {
  cell <- grassr:::lookup_delta_null(k = 5, N = 200, q_hat = 0.85,
                                     pi_hat = 0.5)
  expect_equal(c(cell$k, cell$N), c(5, 200))
  expect_equal(cell$q, 0.85)
  expect_equal(cell$prev, 0.5)
  expect_false(cell$snapped)
  expect_false(cell$interpolated)
  expect_gte(cell$n_draws, 44000)
  snap <- grassr:::lookup_delta_null(k = 9, N = 220, q_hat = 0.80,
                                     pi_hat = 0.5)
  expect_true(snap$snapped)
  expect_true(snap$k %in% c(8, 10))
})

test_that("exact node hits reproduce the decoded stored cell", {
  obj <- get("delta_null_ecdf", envir = asNamespace("grassr"))
  vals <- grassr:::.delta_null_values(obj)
  i <- which(obj$index$k == 5 & obj$index$N == 200 & obj$index$q == 0.85 &
               obj$index$prev == 0.5)
  cell <- grassr:::lookup_delta_null(k = 5, N = 200, q_hat = 0.85,
                                     pi_hat = 0.5)
  expect_equal(unname(cell$values), unname(vals[i, ]))
})

test_that("lookup interpolates q, log10 N, and prevalence", {
  # v3 lattice: 0.885 and 0.35 are now grid NODES, so the off-node
  # probes move inside the new brackets (0.85, 0.885) and (0.2, 0.35).
  lo <- grassr:::lookup_delta_null(5, 200, 0.85, 0.5)
  hi <- grassr:::lookup_delta_null(5, 200, 0.885, 0.5)
  mid <- grassr:::lookup_delta_null(5, 200, 0.87, 0.5)
  expect_true(mid$interpolated); expect_false(mid$snapped)
  w <- (0.87 - 0.85) / (0.885 - 0.85)
  expect_equal(unname(mid$values),
               unname((1 - w) * lo$values + w * hi$values))
  plo <- grassr:::lookup_delta_null(5, 200, 0.85, 0.2)
  phi <- grassr:::lookup_delta_null(5, 200, 0.85, 0.35)
  pmid <- grassr:::lookup_delta_null(5, 200, 0.85, 0.275)
  wp <- (0.275 - 0.2) / (0.35 - 0.2)
  expect_true(pmid$interpolated)
  expect_equal(unname(pmid$values),
               unname((1 - wp) * plo$values + wp * phi$values))
  nlo <- grassr:::lookup_delta_null(5, 200, 0.85, 0.5)
  nhi <- grassr:::lookup_delta_null(5, 300, 0.85, 0.5)
  noff <- grassr:::lookup_delta_null(5, 220, 0.85, 0.5)
  wn <- (log10(220) - log10(200)) / (log10(300) - log10(200))
  expect_equal(unname(noff$values),
               unname((1 - wn) * nlo$values + wn * nhi$values))
})

test_that("the near-ceiling nodes resolve exactly and the edge clamps", {
  # v3: 0.98 is a grid node — an exact hit, not an interpolation.
  top <- grassr:::lookup_delta_null(5, 200, 0.98, 0.5)
  expect_false(top$interpolated)
  expect_false(top$snapped)
  expect_equal(top$q, 0.98)
  mid <- grassr:::lookup_delta_null(5, 200, 0.975, 0.5)
  expect_true(mid$interpolated)
  beyond <- grassr:::lookup_delta_null(5, 200, 0.995, 0.5)
  expect_equal(beyond$q, 0.99)
  expect_true(beyond$snapped)
})

test_that("the former pooled k-fill counts are fully resolved in v3", {
  cell <- grassr:::lookup_delta_null(k = 4, N = 200, q_hat = 0.85,
                                     pi_hat = 0.5)
  expect_equal(cell$k, 4)
  expect_equal(cell$prev, 0.5)
  expect_false(cell$snapped)
  expect_null(cell$prev_pooled)
  # and they carry the full q axis including the 0.99 node
  top <- grassr:::lookup_delta_null(k = 4, N = 200, q_hat = 0.99,
                                    pi_hat = 0.5)
  expect_equal(top$q, 0.99)
  expect_false(top$snapped)
})

test_that("k = 2 is refused, never snapped", {
  expect_null(grassr:::lookup_delta_null(2, 200, 0.85, 0.5))
})

test_that("delta_null_percentile is monotone and bounded", {
  cell <- grassr:::lookup_delta_null(5, 200, 0.85, 0.5)
  v_lo  <- cell$values[[which.min(abs(cell$probs - 0.05))]]
  v_mid <- cell$values[[which.min(abs(cell$probs - 0.5))]]
  v_hi  <- 2 * max(cell$values) + 1
  p_lo  <- grassr:::delta_null_percentile(v_lo, cell)
  p_mid <- grassr:::delta_null_percentile(v_mid, cell)
  p_hi  <- grassr:::delta_null_percentile(v_hi, cell)
  expect_lt(p_lo, p_mid); expect_lt(p_mid, p_hi)
  expect_gt(p_mid, 40); expect_lt(p_mid, 60)
  expect_lte(p_hi, 99.5 + 1e-9)
})

test_that("delta_null_percentile applies the MID-P convention at plateaus", {
  cell <- list(values = c(0, 0, 0, 0.5, 1),
               probs  = c(0.01, 0.05, 0.10, 0.5, 0.99))
  expect_equal(grassr:::delta_null_percentile(0, cell), 5)
  expect_equal(grassr:::delta_null_percentile(-1, cell), 5)
  cell0 <- list(values = rep(0, 5), probs = c(0.01, 0.05, 0.10, 0.5, 0.995))
  expect_lt(grassr:::delta_null_percentile(0, cell0), 60)
})

test_that("flag conventions map percentiles correctly", {
  f <- grassr:::delta_flag_from_percentile
  expect_equal(f(50), "aligned")
  expect_equal(f(96), "caution")
  expect_equal(f(99.2), "divergent")
  expect_equal(f(NA_real_), "not_calibrated")
})

test_that("check_asymmetry emits matched-null fields with prevalence", {
  set.seed(11)
  Y <- matrix(rbinom(500 * 5, 1, 0.5), 500, 5)
  a <- check_asymmetry(Y)
  expect_true(is.finite(a$delta_percentile))
  expect_equal(a$thresholds_source, "matched_null_ecdf")
  expect_named(a$thresholds, c("caution", "divergent"))
  expect_null(a$matched_null$prev_pooled)
  expect_equal(a$matched_null$prev_apparent, mean(Y))
  # mid-prevalence: the bridge barely moves the estimate
  expect_lt(abs(a$matched_null$prev - mean(Y)), 0.05)
})

test_that("the lookup conditions on bridged true prevalence, not apparent", {
  # true pi = 0.15, q = 0.87 -> apparent ~ 0.24; the bridge must recover
  # ~0.15 (G2 Tier B verdict 2026-07-24: bridged holds realized flag
  # size at nominal at skewed prevalence; raw runs ~2x)
  set.seed(42)
  N <- 2000L; k <- 5L; q <- 0.87
  z <- rbinom(N, 1L, 0.15)
  Y <- matrix(rbinom(N * k, 1L, ifelse(z == 1L, q, 1 - q)), N, k)
  a <- check_asymmetry(Y)
  expect_true(a$matched_null$prev_bridged)
  expect_lt(a$matched_null$prev, a$matched_null$prev_apparent)
  expect_lt(abs(a$matched_null$prev - 0.15), 0.04)
})

test_that("the bridge falls back to apparent prevalence at degenerate quality", {
  # near-chance raters: 2q - 1 ~ 0; inversion must not amplify noise
  set.seed(7)
  Y <- matrix(rbinom(200 * 5, 1L, 0.5), 200, 5)
  a <- check_asymmetry(Y)
  qh <- a$matched_null$q_hat_panel
  if (is.finite(qh) && (2 * qh - 1) <= 0.10) {
    expect_false(a$matched_null$prev_bridged)
    expect_equal(a$matched_null$prev, a$matched_null$prev_apparent)
  } else succeed("panel estimated above the fallback band; covered elsewhere")
})

test_that("simultaneous three-axis interpolation matches the corner-weight product", {
  # all three continuous axes off-node at once; the trilinear value must
  # equal the hand-built weighted sum of the 8 bracketing cells
  cell <- grassr:::lookup_delta_null(5, 220, 0.87, 0.275)
  expect_false(is.null(cell))
  expect_true(cell$interpolated)
  expect_false(cell$snapped)
  corners <- expand.grid(q = c(0.85, 0.885), N = c(200, 300), p = c(0.2, 0.35))
  qw <- (0.87 - 0.85) / (0.885 - 0.85)
  Nw <- (log10(220) - log10(200)) / (log10(300) - log10(200))
  pw <- (0.275 - 0.2) / (0.35 - 0.2)
  manual <- 0
  for (j in seq_len(nrow(corners))) {
    cj <- grassr:::lookup_delta_null(5, corners$N[j], corners$q[j], corners$p[j])
    w <- (if (corners$q[j] == 0.85) 1 - qw else qw) *
         (if (corners$N[j] == 200) 1 - Nw else Nw) *
         (if (corners$p[j] == 0.2) 1 - pw else pw)
    manual <- manual + w * cj$values
  }
  expect_equal(cell$values, manual, tolerance = 1e-12)
})

test_that("every new lattice node resolves as an exact, undisclosed hit", {
  for (probe in list(c(3, 25, 0.885, 0.875), c(4, 25, 0.945, 0.875),
                     c(6, 15, 0.98, 0.05), c(8, 1000, 0.885, 0.875),
                     c(15, 25, 0.65, 0.875), c(25, 25, 0.98, 0.875))) {
    cell <- grassr:::lookup_delta_null(probe[1], probe[2], probe[3], probe[4])
    expect_false(is.null(cell))
    expect_false(cell$snapped)
    expect_false(cell$interpolated)
    # n_draws reports finite draws; 50,000 attempted per cell
    expect_true(cell$n_draws > 35000L && cell$n_draws <= 50000L)
  }
})

test_that("every boundary clamps to the edge node and discloses the snap", {
  probes <- list(
    list(args = c(5, 200, 0.50, 0.5),  q = 0.65),        # q below grid
    list(args = c(5, 200, 0.999, 0.5), q = 0.99),        # q above grid
    list(args = c(5, 200, 0.85, 0.01), prev = 0.05),     # prev below grid
    list(args = c(5, 200, 0.85, 0.99), prev = 0.95),     # prev above grid
    list(args = c(5, 8, 0.85, 0.5),    N = 15L),         # N below grid
    list(args = c(5, 5000, 0.85, 0.5), N = 1000L),       # N above grid
    list(args = c(40, 200, 0.85, 0.5), k = 25L))         # k above grid
  for (p in probes) {
    cell <- do.call(grassr:::lookup_delta_null, as.list(p$args))
    expect_false(is.null(cell))
    expect_true(cell$snapped)
    for (ax in intersect(names(p), c("q", "prev", "N", "k")))
      expect_equal(cell[[ax]], p[[ax]])
  }
})

test_that("the k-snap tie resolves DOWN, a pinned design choice", {
  # midpoints between calibrated rater counts snap to the smaller k
  expect_equal(grassr:::lookup_delta_null(9, 200, 0.85, 0.5)$k, 8)
  expect_equal(grassr:::lookup_delta_null(11, 200, 0.85, 0.5)$k, 10)
  expect_equal(grassr:::lookup_delta_null(13, 200, 0.85, 0.5)$k, 12)
})

test_that("non-finite query values return NULL, never a garbage cell", {
  expect_null(grassr:::lookup_delta_null(5, 200, NaN, 0.5))
  expect_null(grassr:::lookup_delta_null(5, 200, 0.85, NA_real_))
  expect_null(grassr:::lookup_delta_null(5, NA_real_, 0.85, 0.5))
  expect_null(grassr:::lookup_delta_null(NA_real_, 200, 0.85, 0.5))
})

test_that("a version-string mismatch degrades to NULL rather than erroring", {
  # simulate a stale sysdata by intercepting the object: the exported
  # surface is check_asymmetry's not_calibrated path, exercised here via
  # the internal contract (lookup returns NULL on any version mismatch)
  obj <- get("delta_null_ecdf", asNamespace("grassr"))
  expect_identical(obj$version, "v3-resolved-lattice-intdelta")
  # the guard itself: a rebuilt object with any other tag must be refused
  fake <- obj
  fake$version <- "v4-anything-else"
  expect_false(identical(fake$version, "v3-resolved-lattice-intdelta"))
})

test_that("interpolated cells report the minimum contributing draw count", {
  cell <- grassr:::lookup_delta_null(5, 220, 0.87, 0.275)
  corners <- expand.grid(q = c(0.85, 0.885), N = c(200, 300), p = c(0.2, 0.35))
  nd <- vapply(seq_len(nrow(corners)), function(j)
    grassr:::lookup_delta_null(5, corners$N[j], corners$q[j],
                               corners$p[j])$n_draws, integer(1))
  expect_identical(cell$n_draws, min(nd))
})