tests/testthat/test-data-column-recognition-provisional.R

In artma: Automatic Replication Tools for Meta-Analysis

box::use(
  testthat[
    expect_equal,
    expect_false,
    expect_gte,
    expect_length,
    expect_null,
    expect_true,
    test_that
  ]
)

box::use(
  artma / data / column_recognition[
    check_mapping_plausibility,
    format_declined_evidence,
    recognize_columns
  ]
)

# The confirm-me layer: what recognition reports about the roles it declined to
# accept on its own. None of it changes the mapping; it only gives an
# interactive caller (and external tooling) the evidence to ask about.

#' A dataset whose effect column carries no name signal at all: the real
#' failure family behind the missed cells on the benchmark (eis, habit,
#' excess_sensitivity), surrounded by identifier-flavored decoys.
make_nameless_effect_df <- function(n_studies = 25, k = 6, effect_col = "eis") {
  study <- rep(seq_len(n_studies), each = k)
  n <- length(study)
  effect <- round(stats::rnorm(n, 0.2, 0.5), 3)
  se <- pmax(round(exp(stats::rnorm(n, log(0.15), 0.5)), 3), 0.001)

  df <- data.frame(
    idstudy = study,
    study = rep(sprintf("Author%02d", seq_len(n_studies)), each = k),
    idcoeff = rep(seq_len(k), times = n_studies),
    placeholder = effect,
    se = se,
    nobs = rep(sample(80:2000, n_studies, replace = TRUE), each = k),
    ols = sample(0:1, n, replace = TRUE)
  )
  names(df)[names(df) == "placeholder"] <- effect_col
  df
}


test_that("a name-free effect column is offered as a provisional candidate", {
  withr::local_seed(11)
  withr::local_options(list("artma.verbose" = 1))
  df <- make_nameless_effect_df()

  mapping <- recognize_columns(df)

  # Auto-detection is unchanged: the nameless column is still not accepted.
  expect_null(mapping$effect)
  expect_equal(mapping$se, "se")

  provisional <- attr(mapping, "provisional")
  expect_equal(names(provisional), "effect")

  candidate <- provisional$effect
  expect_equal(candidate$kind, "unmapped")
  expect_equal(candidate$column, "eis")
  # The three conditions that make it worth a question: strong value evidence,
  # consistency with the accepted counterpart, a clear lead over the runner-up.
  expect_gte(candidate$evidence, 0.55)
  expect_equal(candidate$pair_with, "se")
  expect_gte(candidate$pair_consistency, 0.5)
  expect_gte(candidate$margin, 0.1)
  # No name signal is exactly why it was declined in the first place.
  expect_equal(candidate$name_score, 0)
  expect_equal(candidate$summary$coverage, 1)
})


test_that("an identifier-flavored candidate is never offered for confirmation", {
  withr::local_seed(3)
  withr::local_options(list("artma.verbose" = 1))
  df <- make_nameless_effect_df()
  df$eis <- NULL # no effect column at all; only decoys remain

  mapping <- recognize_columns(df)

  expect_null(mapping$effect)
  expect_null(attr(mapping, "provisional")$effect)
})


test_that("a confidently recognized dataset produces no provisional candidates", {
  withr::local_seed(5)
  withr::local_options(list("artma.verbose" = 1))
  n_studies <- 20
  k <- 6
  n <- n_studies * k
  effect <- round(stats::rnorm(n, 0.3, 0.4), 3)

  df <- data.frame(
    study = rep(sprintf("Author%02d", seq_len(n_studies)), each = k),
    effect = effect,
    se = pmax(round(exp(stats::rnorm(n, log(0.12), 0.4)), 3), 0.001),
    n_obs = rep(sample(50:900, n_studies, replace = TRUE), each = k)
  )

  mapping <- recognize_columns(df)

  expect_equal(mapping$effect, "effect")
  expect_length(attr(mapping, "provisional"), 0)
  expect_null(attr(mapping, "declined")$effect)
})


test_that("two near-tied effect candidates are recorded instead of resolved silently", {
  withr::local_seed(7)
  withr::local_options(list("artma.verbose" = 1))
  n_studies <- 20
  k <- 8
  n <- n_studies * k
  effect <- round(stats::rnorm(n, 0.3, 0.4), 3)

  df <- data.frame(
    study = rep(sprintf("Author%02d", seq_len(n_studies)), each = k),
    effect = effect,
    effect_M = round(effect * 1.02 + stats::rnorm(n, 0, 0.01), 3),
    se = pmax(round(exp(stats::rnorm(n, log(0.12), 0.4)), 3), 0.001),
    n_obs = rep(sample(50:900, n_studies, replace = TRUE), each = k)
  )

  mapping <- recognize_columns(df)

  # The automatic pick stands: only an interactive session asks about the twin.
  expect_equal(mapping$effect, "effect")

  tie <- attr(mapping, "provisional")$effect
  expect_equal(tie$kind, "tie")
  expect_equal(tie$column, "effect")
  expect_true("effect_M" %in% tie$alternatives)
})


test_that("candidates too close to call are all offered, not dropped", {
  withr::local_seed(11)
  withr::local_options(list("artma.verbose" = 1))
  df <- make_nameless_effect_df()
  # A winsorized twin of the effect column: the pair of them is exactly what
  # the recognizer cannot separate on the evidence alone.
  df$eis_w <- round(pmax(pmin(df$eis, 1), -1), 3)

  mapping <- recognize_columns(df)
  candidate <- attr(mapping, "provisional")$effect

  expect_null(mapping$effect)
  expect_true("eis_w" %in% c(candidate$column, candidate$alternatives))
  expect_true("eis" %in% c(candidate$column, candidate$alternatives))
  expect_length(candidate$alternative_summaries, length(candidate$alternatives))
})


test_that("declined required roles carry machine-readable evidence", {
  withr::local_seed(11)
  withr::local_options(list("artma.verbose" = 1))
  df <- make_nameless_effect_df()

  declined <- attr(recognize_columns(df), "declined")

  expect_true("effect" %in% names(declined))
  entry <- declined$effect
  expect_equal(entry$role, "effect")
  expect_true(nzchar(entry$reason))
  expect_true(length(entry$candidates) > 0)

  ranked <- vapply(entry$candidates, function(cand) cand$column, character(1))
  expect_equal(ranked[1], "eis")
  # Every candidate carries the numbers behind the decision, not just a name.
  for (cand in entry$candidates) {
    expect_true(all(c("score", "name_score", "evidence") %in% names(cand)))
  }

  lines <- format_declined_evidence(declined)
  expect_length(lines, length(declined))
  expect_true(any(grepl("^effect: ", lines)))
  expect_true(any(grepl("eis", lines, fixed = TRUE)))
})


test_that("a required role with no candidate at all still reports why", {
  withr::local_seed(2)
  withr::local_options(list("artma.verbose" = 1))
  df <- make_nameless_effect_df()
  df$nobs <- NULL

  declined <- attr(recognize_columns(df), "declined")

  expect_true("n_obs" %in% names(declined))
  expect_length(declined$n_obs$candidates, 0)
  expect_true(nzchar(declined$n_obs$reason))
})


test_that("check_mapping_plausibility flags contradictions and passes real columns", {
  withr::local_seed(11)
  withr::local_options(list("artma.verbose" = 1))
  df <- make_nameless_effect_df()

  good <- check_mapping_plausibility(df, "effect", "eis")
  expect_true(good$ok)

  bad <- check_mapping_plausibility(df, "effect", "idcoeff")
  expect_false(bad$ok)
  expect_true(nzchar(bad$reason))

  # The check is a report, not a gate: it stays silent where it cannot judge.
  expect_true(check_mapping_plausibility(df, "effect", "not_a_column")$ok)
  expect_true(check_mapping_plausibility(df, "study_id", "study")$ok)
})