tests/testthat/test-methods-table.R

In artma: Automatic Replication Tools for Meta-Analysis

box::use(
  testthat[
    expect_equal,
    expect_error,
    expect_false,
    expect_true,
    test_that
  ]
)

# A stand-in for a discovered method module: everything the table builder reads
# is the metadata attached to the module's `run` wrapper.
fake_module <- function(...) {
  box::use(artma / modules / runtime_methods[register_runtime_method])
  list(run = register_runtime_method(function(df, ...) df, ...))
}

fake_modules <- function() {
  list(
    fma = fake_module(
      stage = "fma",
      description = "Frequentist Model Averaging",
      depends_on = "bma",
      required_columns = c("effect", "se"),
      suggests = c("BMS", "quadprog")
    ),
    bma = fake_module(
      stage = "bma",
      description = "Bayesian Model Averaging",
      required_columns = c("effect", "se"),
      suggests = "BMS"
    ),
    robma = fake_module(
      stage = "robma",
      description = "Robust Bayesian meta-analysis",
      required_columns = c("effect", "se"),
      suggests = "RoBMA",
      opt_in = TRUE
    ),
    box_plot = fake_module(
      stage = "box_plot",
      description = "Box plots of the effect",
      required_columns = "effect"
    )
  )
}

# Only BMS and quadprog count as installed, so RoBMA is a missing package.
fake_is_installed <- function(pkg) pkg %in% c("BMS", "quadprog")

built_table <- function(...) {
  box::use(artma / modules / methods_table[build_methods_table])
  build_methods_table(modules = fake_modules(), is_installed = fake_is_installed, ...)
}

test_that("build_methods_table exposes the registered metadata per method", {
  df <- built_table()

  expect_equal(df$method, c("bma", "box_plot", "fma", "robma"))
  expect_equal(df$description[df$method == "bma"], "Bayesian Model Averaging")
  expect_equal(df$required_columns[df$method == "fma"], "effect, se")
  expect_equal(df$suggests[df$method == "fma"], "BMS, quadprog")
  expect_equal(df$depends_on[df$method == "fma"], "bma")
  expect_equal(df$depends_on[df$method == "bma"], "")
  expect_true(df$opt_in[df$method == "robma"])
  expect_false(df$opt_in[df$method == "bma"])
})

test_that("build_methods_table flags methods whose suggested packages are absent", {
  df <- built_table()

  expect_false(df$installed[df$method == "robma"])
  expect_equal(df$missing_packages[df$method == "robma"], "RoBMA")
  expect_true(df$installed[df$method == "fma"])
  expect_equal(df$missing_packages[df$method == "fma"], "")
  # A method with no suggested packages counts as installed.
  expect_true(df$installed[df$method == "box_plot"])
})

test_that("build_methods_table has no availability columns without a data frame", {
  df <- built_table()
  expect_false("missing_columns" %in% names(df))
  expect_false("available" %in% names(df))
})

test_that("available_for turns the table into a pre-flight check", {
  df <- built_table(available_for = data.frame(effect = 1, study_id = "a"))

  expect_equal(df$missing_columns[df$method == "bma"], "se")
  expect_false(df$available[df$method == "bma"])
  expect_equal(df$missing_columns[df$method == "box_plot"], "")
  expect_true(df$available[df$method == "box_plot"])
  # Columns present, package missing: still unavailable.
  expect_equal(df$missing_columns[df$method == "robma"], "se")
  expect_false(df$available[df$method == "robma"])
})

test_that("build_methods_table rejects a non-data-frame available_for", {
  expect_error(built_table(available_for = "effect"), "data frame")
})

test_that("methods_status condenses the reasons a method would not run", {
  box::use(artma / modules / methods_table[methods_status])

  status <- methods_status(built_table())
  expect_equal(status[built_table()$method == "bma"], "ok")
  expect_equal(status[built_table()$method == "robma"], "opt-in; install RoBMA")

  with_data <- built_table(available_for = data.frame(effect = 1))
  expect_equal(methods_status(with_data)[with_data$method == "bma"], "needs se")
})

test_that("format_methods_table fits an 80-column console, one line per method", {
  box::use(artma / modules / methods_table[format_methods_table])

  df <- built_table()
  lines <- format_methods_table(df, width = 80)

  # Header, rule, and one row per method.
  expect_equal(length(lines), nrow(df) + 2L)
  expect_true(all(nchar(lines) <= 80))
  expect_true(all(grepl("^bma ", lines[3])))
})

test_that("format_methods_table truncates the description instead of wrapping", {
  box::use(artma / modules / methods_table[format_methods_table])

  df <- built_table()
  df$description <- strrep("x", 200)
  lines <- format_methods_table(df, width = 80)

  expect_equal(length(lines), nrow(df) + 2L)
  expect_true(all(nchar(lines) <= 80))
  expect_false(any(grepl(strrep("x", 60), lines)))
})

test_that("format_methods_table gives spare width back to the description", {
  box::use(artma / modules / methods_table[format_methods_table])

  df <- built_table()
  narrow <- format_methods_table(df, width = 80)
  wide <- format_methods_table(df, width = 200)

  expect_true(all(nchar(wide) <= 200))
  expect_true(any(grepl("Robust Bayesian meta-analysis", wide, fixed = TRUE)))
  expect_false(any(grepl("Robust Bayesian meta-analysis", narrow, fixed = TRUE)))
})

test_that("fit_column_widths shrinks in order and never below the minimum", {
  box::use(artma / modules / methods_table[fit_column_widths])

  widths <- fit_column_widths(
    natural = list(a = 10L, b = 30L, c = 20L),
    minimum = list(a = 10L, b = 5L, c = 5L),
    shrink_order = c("b", "c"),
    available = 40L,
    gap = 2L
  )

  # 10 + 30 + 20 + 4 = 64, so 24 characters have to go: b absorbs 24 down to 6.
  expect_equal(widths$a, 10L)
  expect_equal(widths$b, 6L)
  expect_equal(widths$c, 20L)
})

test_that("fit_column_widths leaves a fitting row untouched", {
  box::use(artma / modules / methods_table[fit_column_widths])

  natural <- list(a = 10L, b = 12L)
  widths <- fit_column_widths(
    natural = natural,
    minimum = list(a = 5L, b = 5L),
    shrink_order = c("b", "a"),
    available = 80L
  )

  expect_equal(widths, natural)
})

test_that("every registered runtime method declares a one-line description", {
  box::use(
    artma / modules / runtime_methods[get_method_metadata, get_runtime_method_modules]
  )

  modules <- get_runtime_method_modules()
  for (name in names(modules)) {
    description <- get_method_metadata(modules[[name]][["run"]], name = name)$description
    expect_true(
      is.character(description) && length(description) == 1L &&
        !is.na(description) && nzchar(description),
      label = sprintf("Method '%s' registers a description", name)
    )
    expect_false(grepl("\n", description, fixed = TRUE))
  }
})

test_that("methods_list returns the table invisibly", {
  df <- withr::with_options(list(artma.verbose = 1), artma::methods_list())
  expect_true(is.data.frame(df))
  expect_true(all(c("method", "description", "required_columns", "installed") %in% names(df)))
  expect_true("bma" %in% df$method)
})