tests/testthat/test-data-interactive-mapping.R

In artma: Automatic Replication Tools for Meta-Analysis

box::use(
  testthat[
    expect_equal,
    expect_false,
    expect_message,
    expect_no_error,
    expect_null,
    expect_true,
    test_that
  ]
)

box::use(
  artma / data / interactive_mapping[
    confirm_column_mapping,
    confirm_provisional_mappings,
    format_mapping_display,
    format_provisional_evidence,
    interactive_column_mapping
  ],
  artma / data_config / column_mapping[save_column_mapping_to_options],
  artma / data / column_recognition[get_required_column_names]
)


# Note: the prompting paths of interactive_column_mapping and
# column_mapping_workflow require user interaction via climenu, so they are
# tested in E2E tests instead. The non-interactive branches and helper
# functions are tested here.


test_that("interactive_column_mapping never guesses a missing required column non-interactively", {
  df <- data.frame(
    effect = c(0.5, 0.7),
    se = c(0.1, 0.2),
    study_id = c("A", "B")
  )

  # n_obs is required but absent from the data, so it cannot be auto-detected.
  auto_mapping <- list(
    effect = "effect",
    se = "se",
    study_id = "study_id"
  )

  withr::local_options(list("artma.verbose" = 2))

  # The warning must name the column that stays unmapped.
  expect_message(
    result <- interactive_column_mapping(
      df = df,
      auto_mapping = auto_mapping,
      required_only = TRUE,
      show_detected_first = TRUE,
      is_interactive = FALSE
    ),
    "n_obs"
  )

  # The missing required column stays unmapped instead of falling back to the
  # first menu entry, which used to silently map n_obs to effect.
  expect_equal(result, auto_mapping)
  expect_false("n_obs" %in% names(result))
})


test_that("confirm_column_mapping returns mapping unchanged", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect",
    se = "se",
    n_obs = "n_obs"
  )

  required_cols <- c("study_id", "effect", "se", "n_obs")

  withr::local_options(list("artma.verbose" = 1))
  result <- confirm_column_mapping(mapping, required_cols)

  expect_equal(result, mapping)
})


test_that("confirm_column_mapping handles empty mapping", {
  mapping <- list()
  required_cols <- c("study_id", "effect", "se", "n_obs")

  withr::local_options(list("artma.verbose" = 1))
  result <- confirm_column_mapping(mapping, required_cols)

  expect_equal(result, mapping)
})


test_that("confirm_column_mapping handles partial mapping", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect"
  )

  required_cols <- c("study_id", "effect", "se", "n_obs")

  withr::local_options(list("artma.verbose" = 1))
  result <- confirm_column_mapping(mapping, required_cols)

  expect_equal(result, mapping)
})


test_that("save_column_mapping_to_options sets session options correctly", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect_size",
    se = "std_error"
  )

  withr::local_options(list(
    "artma.verbose" = 1,
    "artma.data.columns" = list()
  ))

  # Save without options file (just to session)
  save_column_mapping_to_options(mapping, options_file_name = NULL)

  # Check that role records were written to the unified store
  store <- getOption("artma.data.columns")
  expect_equal(store$study_id$source_name, "study_name")
  expect_equal(store$effect$source_name, "effect_size")
  expect_equal(store$se$source_name, "std_error")
})


test_that("save_column_mapping_to_options handles empty mapping", {
  mapping <- list()

  withr::local_options(list("artma.verbose" = 1))

  expect_no_error(
    save_column_mapping_to_options(mapping, options_file_name = NULL)
  )
})


test_that("save_column_mapping_to_options handles multiple columns", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect",
    se = "se",
    n_obs = "n_obs",
    t_stat = "t_statistic",
    obs_id = "sid"
  )

  withr::local_options(list(
    "artma.verbose" = 1,
    "artma.data.columns" = list()
  ))

  save_column_mapping_to_options(mapping, options_file_name = NULL)

  # Genuine renames are stored; identity mappings (effect, se, n_obs) are not,
  # since a column already carrying the standard name needs no record.
  store <- getOption("artma.data.columns")
  expect_equal(store$study_id$source_name, "study_name")
  expect_equal(store$t_stat$source_name, "t_statistic")
  expect_equal(store$obs_id$source_name, "sid")
  expect_null(store$effect)
  expect_null(store$se)
  expect_null(store$n_obs)
})


test_that("confirm_column_mapping works with verbose output", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect"
  )

  required_cols <- c("study_id", "effect", "se", "n_obs")

  withr::local_options(list("artma.verbose" = 4))

  # Should not error even with verbose output
  expect_no_error(
    confirm_column_mapping(mapping, required_cols)
  )
})


test_that("save_column_mapping_to_options works with verbose output", {
  mapping <- list(
    study_id = "study_name"
  )

  withr::local_options(list(
    "artma.verbose" = 4,
    "artma.data.columns" = list()
  ))

  expect_no_error(
    save_column_mapping_to_options(mapping, options_file_name = NULL)
  )
})


test_that("save_column_mapping_to_options preserves existing analysis fields", {
  withr::local_options(list(
    "artma.verbose" = 1,
    "artma.data.columns" = list(
      effect = list(bma = TRUE)
    )
  ))

  save_column_mapping_to_options(
    list(effect = "effect_size"),
    options_file_name = NULL
  )

  store <- getOption("artma.data.columns")
  expect_equal(store$effect$source_name, "effect_size")
  expect_true(store$effect$bma)
})


test_that("format_mapping_display correctly separates required and optional", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect_size",
    se = "se",
    n_obs = "n_obs",
    t_stat = "t_statistic"
  )

  required_cols <- get_required_column_names()

  result <- format_mapping_display(mapping, required_cols)

  expect_true(is.list(result))
  expect_true("required" %in% names(result))
  expect_true("optional" %in% names(result))

  # All required columns should be in required list
  expect_true(all(required_cols %in% names(result$required)))

  # Optional columns should be in optional list
  expect_true("t_stat" %in% names(result$optional))
  expect_false("t_stat" %in% names(result$required))
})


test_that("format_mapping_display handles empty optional columns", {
  mapping <- list(
    study_id = "study_name",
    effect = "effect_size",
    se = "se",
    n_obs = "n_obs"
  )

  required_cols <- get_required_column_names()

  result <- format_mapping_display(mapping, required_cols)

  expect_equal(length(result$optional), 0)
  expect_equal(length(result$required), 4)
})


test_that("read_stored_columns seeds from the options file, not the session", {
  box::use(
    artma / data_config / column_mapping[read_stored_columns],
    artma / options / files[write_options_file]
  )

  tmp_dir <- withr::local_tempdir()
  file_name <- "seed-test.yaml"

  write_options_file(
    file.path(tmp_dir, file_name),
    list(data = list(columns = list(gdp_growth = list(bma = TRUE))))
  )

  # The session store is empty, as it is during options file creation.
  withr::local_options(list(
    "artma.verbose" = 1,
    "artma.data.columns" = list()
  ))

  store <- read_stored_columns(file_name, options_dir = tmp_dir)

  expect_true(store$gdp_growth$bma)
})


test_that("save_column_mapping_to_options keeps records already in the file", {
  box::use(
    artma / data_config / column_mapping[save_column_mapping_to_options],
    artma / options / files[options_file_path, read_options_file, write_options_file]
  )

  tmp_dir <- withr::local_tempdir()
  file_name <- "keep-records.yaml"
  path <- options_file_path(tmp_dir, file_name)

  # Build a file valid against the real template, then seed it with records
  # a user would have configured before the mapping flow runs.
  artma::options_create(
    options_file_name = file_name,
    options_dir = tmp_dir,
    user_input = list("data.source_path" = "some-data.csv"),
    should_validate = FALSE,
    should_overwrite = TRUE
  )

  seeded <- read_options_file(path)
  seeded$data$columns <- list(
    gdp_growth = list(bma = TRUE),
    effect = list(bma = FALSE)
  )
  write_options_file(path, seeded)

  # Empty session store, as during options file creation.
  withr::local_options(list(
    "artma.verbose" = 1,
    "artma.data.columns" = list()
  ))

  save_column_mapping_to_options(
    list(effect = "effect_size"),
    options_file_name = file_name,
    options_dir = tmp_dir
  )

  written <- read_options_file(path)$data$columns

  # The moderator record survives the write
  expect_true(written$gdp_growth$bma)

  # The mapped role record gains source_name without losing its other fields
  expect_equal(written$effect$source_name, "effect_size")
  expect_false(written$effect$bma)
})


test_that("read_stored_columns falls back to the session store when absent", {
  box::use(artma / data_config / column_mapping[read_stored_columns])

  withr::local_options(list(
    "artma.verbose" = 1,
    "artma.data.columns" = list(effect = list(source_name = "b"))
  ))

  store <- read_stored_columns("no-such-file-here.yaml")

  expect_equal(store$effect$source_name, "b")
})


# --- Confirming sub-threshold candidates ------------------------------------
# `select_fn` and `is_interactive` make the confirm path drivable without a
# terminal: the menu is the only part that needs one.

#' One provisional candidate of the family the benchmark keeps missing: a
#' column whose values and pair consistency say "effect" while its name says
#' nothing at all.
nameless_effect_candidate <- function(column = "eis", kind = "unmapped", alternatives = character(0)) {
  list(
    kind = kind,
    role = "effect",
    column = column,
    score = 0.65,
    evidence = 0.95,
    name_score = 0,
    pair_consistency = 0.98,
    pair_with = "se",
    runner_up = "idstudy",
    margin = 0.3,
    alternatives = alternatives,
    summary = list(
      column = column,
      coverage = 1,
      n_distinct = 140L,
      non_integer_share = 1,
      has_both_signs = TRUE,
      median_abs = 0.3
    )
  )
}

pick_first <- function(choices, prompt) choices[1]
pick_last <- function(choices, prompt) choices[length(choices)]


test_that("confirming a provisional candidate maps the role", {
  withr::local_options(list("artma.verbose" = 1))
  mapping <- list(se = "se", study_id = "study", n_obs = "nobs")

  result <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = nameless_effect_candidate()),
    select_fn = pick_first,
    is_interactive = TRUE
  )

  expect_equal(result$effect, "eis")
})


test_that("declining a provisional candidate leaves the role unmapped", {
  withr::local_options(list("artma.verbose" = 1))
  mapping <- list(se = "se")

  result <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = nameless_effect_candidate()),
    select_fn = pick_last,
    is_interactive = TRUE
  )

  expect_equal(result, mapping)
  expect_false("effect" %in% names(result))

  # Cancelling the menu is a decline, not an error.
  cancelled <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = nameless_effect_candidate()),
    select_fn = function(choices, prompt) NULL,
    is_interactive = TRUE
  )
  expect_equal(cancelled, mapping)
})


test_that("a non-interactive session is never asked", {
  withr::local_options(list("artma.verbose" = 1))
  mapping <- list(se = "se")

  result <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = nameless_effect_candidate()),
    select_fn = function(choices, prompt) stop("must not prompt"),
    is_interactive = FALSE
  )

  expect_equal(result, mapping)
})


test_that("a near-tie asks which twin holds the role", {
  withr::local_options(list("artma.verbose" = 1))
  mapping <- list(effect = "effect", se = "se")
  tie <- nameless_effect_candidate(column = "effect", kind = "tie", alternatives = "effect_M")

  swapped <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = tie),
    select_fn = function(choices, prompt) choices[2],
    is_interactive = TRUE
  )
  expect_equal(swapped$effect, "effect_M")

  kept <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = tie),
    select_fn = pick_first,
    is_interactive = TRUE
  )
  expect_equal(kept$effect, "effect")

  # Ties are the non-critical half of this: they are skipped where the autonomy
  # level does not ask about such choices.
  ignored <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = tie),
    allow_ties = FALSE,
    select_fn = function(choices, prompt) stop("must not prompt"),
    is_interactive = TRUE
  )
  expect_equal(ignored, mapping)
})


test_that("candidates too close to call are offered as one pick-one question", {
  withr::local_options(list("artma.verbose" = 1))
  mapping <- list(se = "se")
  candidate <- nameless_effect_candidate(alternatives = c("eis_w", "realrate"))
  candidate$alternative_summaries <- list(
    list(column = "eis_w", evidence = 0.95, pair_consistency = 0.9),
    list(column = "realrate", evidence = 0.9, pair_consistency = 0.75)
  )

  seen <- NULL
  result <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = candidate),
    select_fn = function(choices, prompt) {
      seen <<- choices
      choices[2]
    },
    is_interactive = TRUE
  )

  expect_equal(seen[seq_len(3)], c("eis", "eis_w", "realrate"))
  expect_true(grepl("None of these", seen[length(seen)], fixed = TRUE))
  expect_equal(result$effect, "eis_w")

  # Picking the decline entry still leaves the role unmapped.
  declined <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = candidate),
    select_fn = pick_last,
    is_interactive = TRUE
  )
  expect_false("effect" %in% names(declined))
})


test_that("a column another role already holds is not offered", {
  withr::local_options(list("artma.verbose" = 1))
  mapping <- list(se = "eis", study_id = "study")

  result <- confirm_provisional_mappings(
    mapping = mapping,
    provisional = list(effect = nameless_effect_candidate()),
    select_fn = function(choices, prompt) stop("must not prompt"),
    is_interactive = TRUE
  )

  expect_equal(result, mapping)
})


test_that("interactive_column_mapping confirms provisional candidates before prompting", {
  withr::local_options(list("artma.verbose" = 1))
  df <- data.frame(
    study = rep(c("A", "B"), each = 3),
    eis = c(0.1, -0.2, 0.3, 0.15, -0.25, 0.35),
    se = c(0.05, 0.08, 0.06, 0.04, 0.09, 0.07),
    nobs = rep(c(120, 340), each = 3)
  )
  auto_mapping <- list(se = "se", study_id = "study", n_obs = "nobs")
  attr(auto_mapping, "provisional") <- list(effect = nameless_effect_candidate())

  result <- interactive_column_mapping(
    df = df,
    auto_mapping = auto_mapping,
    required_only = TRUE,
    show_detected_first = FALSE,
    is_interactive = TRUE,
    select_fn = pick_first
  )

  # The confirmed column fills the missing required role, so the column menus
  # below it never run.
  expect_equal(result$effect, "eis")
})


test_that("interactive_column_mapping leaves the mapping alone non-interactively", {
  withr::local_options(list("artma.verbose" = 1))
  df <- data.frame(
    study = rep(c("A", "B"), each = 3),
    eis = c(0.1, -0.2, 0.3, 0.15, -0.25, 0.35),
    se = c(0.05, 0.08, 0.06, 0.04, 0.09, 0.07),
    nobs = rep(c(120, 340), each = 3)
  )
  auto_mapping <- list(se = "se", study_id = "study", n_obs = "nobs")
  attr(auto_mapping, "provisional") <- list(effect = nameless_effect_candidate())

  result <- interactive_column_mapping(
    df = df,
    auto_mapping = auto_mapping,
    required_only = TRUE,
    show_detected_first = FALSE,
    is_interactive = FALSE,
    select_fn = function(choices, prompt) stop("must not prompt")
  )

  expect_false("effect" %in% names(result))
})


test_that("format_provisional_evidence explains why the candidate is plausible", {
  lines <- format_provisional_evidence(nameless_effect_candidate())

  expect_true(any(grepl("effect values", lines, fixed = TRUE)))
  expect_true(any(grepl("rows populated", lines, fixed = TRUE)))
  expect_true(any(grepl("consistent with the mapped column se", lines, fixed = TRUE)))
  expect_true(any(grepl("name carries no signal", lines, fixed = TRUE)))
  expect_true(any(grepl("idstudy", lines, fixed = TRUE)))
})