tests/testthat/test-data-preprocess.R

In artma: Automatic Replication Tools for Meta-Analysis

box::use(
  testthat[
    expect_equal,
    expect_error,
    expect_true,
    expect_false,
    expect_warning,
    expect_no_warning,
    test_that
  ],
  withr[local_options]
)

test_that <- getFromNamespace("test_that", "testthat")
expect_equal <- getFromNamespace("expect_equal", "testthat")
expect_error <- getFromNamespace("expect_error", "testthat")
expect_true <- getFromNamespace("expect_true", "testthat")
expect_false <- getFromNamespace("expect_false", "testthat")
expect_warning <- getFromNamespace("expect_warning", "testthat")
expect_no_warning <- getFromNamespace("expect_no_warning", "testthat")

# Tests for remove_redundant_columns, verify_variable_names, and
# handle_extra_columns_with_data have been removed. Those functions were
# deleted and their responsibilities moved to inst/artma/data/schema_reconcile.R.
# See tests/testthat/test-data-schema-reconcile.R for the replacement tests.

# -- enforce_data_types --------------------------------------------------------

test_that("enforce_data_types coerces columns according to the config", {
  box::use(artma / data / preprocess[enforce_data_types])

  # With no dataframe source, get_data_config returns the overrides as-is
  withr::local_options(list(
    "artma.data.source_path" = NA,
    "artma.data.columns" = list(
      x = list(var_name = "x", data_type = "int"),
      y = list(var_name = "y", data_type = "category"),
      z = list(var_name = "z", data_type = "float")
    ),
    "artma.verbose" = 1
  ))

  df <- data.frame(x = c(1, 2), y = c(TRUE, FALSE), z = c("1.5", "2.5"))
  result <- enforce_data_types(df)

  expect_true(is.integer(result$x))
  expect_true(is.character(result$y))
  expect_true(is.numeric(result$z))
})

test_that("enforce_data_types errors on a column with no config entry", {
  box::use(artma / data / preprocess[enforce_data_types])

  withr::local_options(list(
    "artma.data.source_path" = NA,
    "artma.data.columns" = list(
      x = list(var_name = "x", data_type = "float")
    ),
    "artma.verbose" = 1
  ))

  df <- data.frame(x = c(1.5, 2.5), y = c("a", "b"))

  expect_error(enforce_data_types(df), "No data config entry")
})

test_that("enforce_data_types skips entries without type information", {
  box::use(artma / data / preprocess[enforce_data_types])

  withr::local_options(list(
    "artma.data.source_path" = NA,
    "artma.data.columns" = list(
      x = list(var_name = "x", data_type = "float"),
      y = list(var_name = "y")
    ),
    "artma.verbose" = 1
  ))

  df <- data.frame(x = c(1.5, 2.5), y = c("a", "b"))
  result <- enforce_data_types(df)

  expect_true(is.numeric(result$x))
  expect_equal(result$y, df$y)
})

# -- apply_subset_conditions ---------------------------------------------------

test_that("apply_subset_conditions returns the data frame unchanged when unset", {
  box::use(artma / data / preprocess[apply_subset_conditions])

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

  df <- data.frame(country = c("USA", "UK"), year = c(1999, 2001))
  expect_equal(apply_subset_conditions(df), df)
})

test_that("apply_subset_conditions filters rows matching a single condition", {
  box::use(artma / data / preprocess[apply_subset_conditions])

  withr::local_options(list(
    "artma.data.subset_conditions" = "year >= 2000",
    "artma.verbose" = 1
  ))

  df <- data.frame(country = c("USA", "UK", "USA"), year = c(1999, 2001, 2005))
  result <- apply_subset_conditions(df)

  expect_equal(result$year, c(2001, 2005))
})

test_that("apply_subset_conditions combines multiple conditions with AND", {
  box::use(artma / data / preprocess[apply_subset_conditions])

  withr::local_options(list(
    "artma.data.subset_conditions" = c("year >= 2000", "country == 'USA'"),
    "artma.verbose" = 1
  ))

  df <- data.frame(
    country = c("USA", "UK", "USA"),
    year = c(1999, 2001, 2005)
  )
  result <- apply_subset_conditions(df)

  expect_equal(nrow(result), 1)
  expect_equal(result$year, 2005)
})

test_that("apply_subset_conditions drops rows where the condition evaluates to NA", {
  box::use(artma / data / preprocess[apply_subset_conditions])

  withr::local_options(list(
    "artma.data.subset_conditions" = "year >= 2000",
    "artma.verbose" = 1
  ))

  df <- data.frame(country = c("USA", "UK"), year = c(NA, 2001))
  result <- apply_subset_conditions(df)

  expect_equal(nrow(result), 1)
  expect_equal(result$country, "UK")
})

test_that("apply_subset_conditions errors on an unparseable condition", {
  box::use(artma / data / preprocess[apply_subset_conditions])

  withr::local_options(list(
    "artma.data.subset_conditions" = "year >=",
    "artma.verbose" = 1
  ))

  df <- data.frame(year = c(1999, 2001))
  expect_error(apply_subset_conditions(df), "Invalid subset condition")
})

test_that("apply_subset_conditions errors when a condition targets a missing column", {
  box::use(artma / data / preprocess[apply_subset_conditions])

  withr::local_options(list(
    "artma.data.subset_conditions" = "region == 'EU'",
    "artma.verbose" = 1
  ))

  df <- data.frame(country = c("USA", "UK"), year = c(1999, 2001))
  expect_error(apply_subset_conditions(df), "Failed to evaluate subset condition")
})

# -- enforce_correct_values ------------------------------------------------------

test_that("enforce_correct_values defaults to removing rows with zero SE when unset", {
  box::use(artma / data / preprocess[enforce_correct_values])

  withr::local_options(list(
    "artma.calc.se_zero_handling" = NULL,
    "artma.verbose" = 3
  ))

  df <- data.frame(se = c(0.1, 0, 0.2, 0))
  expect_warning(result <- enforce_correct_values(df), "Removed 2 rows")

  expect_equal(nrow(result), 2)
  expect_true(all(result$se != 0))
})

test_that("enforce_correct_values treats an NA option as remove", {
  box::use(artma / data / preprocess[enforce_correct_values])

  # Options with a `.na` template default are loaded into options() as a
  # literal NA; the read must fall back to "remove" instead of crashing on
  # `if (NA == "stop")` (issue #321, bug 1).
  withr::local_options(list(
    "artma.calc.se_zero_handling" = NA,
    "artma.verbose" = 3
  ))

  df <- data.frame(se = c(0.1, 0, 0.2))
  expect_warning(result <- enforce_correct_values(df), "Removed 1 row")

  expect_equal(result$se, c(0.1, 0.2))
})

test_that("enforce_correct_values 'remove' strategy drops zero-SE rows with a warning", {
  box::use(artma / data / preprocess[enforce_correct_values])

  withr::local_options(list(
    "artma.calc.se_zero_handling" = "remove",
    "artma.verbose" = 3
  ))

  df <- data.frame(se = c(0.1, 0, 0.2))
  expect_warning(result <- enforce_correct_values(df), "stricter validation")

  expect_equal(result$se, c(0.1, 0.2))
})

test_that("enforce_correct_values 'remove' strategy is a no-op without zero SE", {
  box::use(artma / data / preprocess[enforce_correct_values])

  withr::local_options(list(
    "artma.calc.se_zero_handling" = "remove",
    "artma.verbose" = 1
  ))

  df <- data.frame(se = c(0.1, 0.2))
  result <- expect_no_warning(enforce_correct_values(df))

  expect_equal(result, df)
})

test_that("enforce_correct_values 'stop' strategy aborts on zero SE", {
  box::use(artma / data / preprocess[enforce_correct_values])

  withr::local_options(list(
    "artma.calc.se_zero_handling" = "stop",
    "artma.verbose" = 1
  ))

  df <- data.frame(se = c(0.1, 0))
  expect_error(enforce_correct_values(df), "contains zero values in 1 row")
  # The abort names the option that decides the policy (#540).
  expect_error(enforce_correct_values(df), "se_zero_handling")
})

test_that("enforce_correct_values 'warn' strategy keeps rows but warns", {
  box::use(artma / data / preprocess[enforce_correct_values])

  withr::local_options(list(
    "artma.calc.se_zero_handling" = "warn",
    "artma.verbose" = 3
  ))

  df <- data.frame(se = c(0.1, 0))
  expect_warning(result <- enforce_correct_values(df), "contains zero values")

  expect_equal(result, df)
})

test_that("enforce_correct_values 'ignore' strategy silently keeps rows", {
  box::use(artma / data / preprocess[enforce_correct_values])

  withr::local_options(list(
    "artma.calc.se_zero_handling" = "ignore",
    "artma.verbose" = 3
  ))

  df <- data.frame(se = c(0.1, 0))
  result <- expect_no_warning(enforce_correct_values(df))

  expect_equal(result, df)
})

# resolve_se_zero_handling now lives in inst/artma/data/configure.R; see
# tests/testthat/test-data-configure.R for its tests.

# -- winsorize_data ------------------------------------------------------------

test_that("winsorize_data clips to order statistics, not interpolated quantiles", {
  box::use(artma / data / preprocess[winsorize_data])

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

  # With 20 observations and p = 0.1, the type 1 (inverse ECDF) quantiles are
  # the 2nd and 18th order statistics. Type 7 would interpolate to 2.9 and
  # 18.1, values no observation attains.
  df <- data.frame(effect = 1:20 / 1, se = 20:1 / 10)
  result <- winsorize_data(df)

  expect_equal(min(result$effect), 2)
  expect_equal(max(result$effect), 18)
  expect_equal(result$effect, pmax(pmin(df$effect, 18), 2))
  expect_true(all(result$effect %in% df$effect))

  expect_equal(min(result$se), 0.2)
  expect_equal(max(result$se), 1.8)
  expect_equal(result$se, pmax(pmin(df$se, 1.8), 0.2))
  expect_true(all(result$se %in% df$se))
})

test_that("winsorize_data ignores NA values when locating the clip points", {
  box::use(artma / data / preprocess[winsorize_data])

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

  df <- data.frame(effect = c(NA, 1:20, NA), se = rep(0.5, 22))
  result <- winsorize_data(df)

  expect_true(all(is.na(result$effect[c(1, 22)])))
  expect_equal(result$effect[2:21], pmax(pmin(1:20, 18), 2))
  expect_equal(result$se, df$se)
})

test_that("winsorize_data is a no-op when the level is zero", {
  box::use(artma / data / preprocess[winsorize_data])

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

  df <- data.frame(effect = 1:20 / 1, se = 20:1 / 10)
  expect_equal(winsorize_data(df), df)
})

# -- numeric roles -------------------------------------------------------------

test_that("enforce_data_types coerces a numeric role typed as category to numeric", {
  box::use(artma / data / preprocess[enforce_data_types])

  withr::local_options(list(
    "artma.data.source_path" = NA,
    "artma.data.columns" = list(
      effect = list(var_name = "effect", data_type = "category"),
      se = list(var_name = "se", data_type = "category"),
      label = list(var_name = "label", data_type = "category")
    ),
    "artma.verbose" = 1
  ))

  df <- data.frame(
    effect = c("0.817", NA, "-9.846"),
    se = factor(c("0.1", "0.2", "0.3")),
    label = c("a", "b", "c"),
    stringsAsFactors = FALSE
  )
  result <- enforce_data_types(df)

  expect_equal(result$effect, c(0.817, NA, -9.846))
  expect_equal(result$se, c(0.1, 0.2, 0.3))
  expect_true(is.character(result$label))
})

test_that("enforce_data_types aborts on a numeric role that does not parse, naming the source column", {
  box::use(artma / data / preprocess[enforce_data_types])

  withr::local_options(list(
    "artma.data.source_path" = NA,
    "artma.data.columns" = list(
      effect = list(var_name = "effect", source_name = "beta_estimate", data_type = "category"),
      se = list(var_name = "se", data_type = "float")
    ),
    "artma.verbose" = 1
  ))

  df <- data.frame(
    effect = c("0,817", "0,794", "-9,846", "1,023"),
    se = c("0.1", "0.2", "0.3", "0.4"),
    stringsAsFactors = FALSE
  )

  err <- expect_error(enforce_data_types(df), class = "rlang_error")
  msg <- cli::ansi_strip(conditionMessage(err))
  expect_true(grepl('"effect"', msg, fixed = TRUE))
  expect_true(grepl('mapped from "beta_estimate"', msg, fixed = TRUE))
  expect_true(grepl("0,817", msg, fixed = TRUE))
  expect_true(grepl("comma decimal separators", msg, fixed = TRUE))
})

test_that("enforce_data_types does not blame a decimal comma for arbitrary text", {
  box::use(artma / data / preprocess[enforce_data_types])

  withr::local_options(list(
    "artma.data.source_path" = NA,
    "artma.data.columns" = list(
      n_obs = list(var_name = "n_obs", data_type = "category")
    ),
    "artma.verbose" = 1
  ))

  df <- data.frame(n_obs = c("120", "n/a", "80 obs"), stringsAsFactors = FALSE)

  err <- expect_error(enforce_data_types(df), class = "rlang_error")
  msg <- cli::ansi_strip(conditionMessage(err))
  expect_true(grepl('"n_obs"', msg, fixed = TRUE))
  expect_true(grepl("n/a", msg, fixed = TRUE))
  expect_true(grepl("80 obs", msg, fixed = TRUE))
  expect_false(grepl("120", msg, fixed = TRUE))
  expect_false(grepl("comma decimal", msg, fixed = TRUE))
})

test_that("assert_numeric_roles passes numeric frames through unchanged", {
  box::use(artma / data / preprocess[assert_numeric_roles])

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

  df <- data.frame(
    study_id = c("a", "b"),
    effect = c(1.5, 2.5),
    se = 1:2,
    n_obs = c(10L, 20L),
    moderator = c("x", "y"),
    stringsAsFactors = FALSE
  )
  expect_equal(assert_numeric_roles(df), df)
})

test_that("assert_numeric_roles aborts on a text numeric role", {
  box::use(artma / data / preprocess[assert_numeric_roles])

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

  df <- data.frame(effect = c(1, 2), se = c("0.1", "0.2"), stringsAsFactors = FALSE)

  err <- expect_error(assert_numeric_roles(df), class = "rlang_error")
  msg <- cli::ansi_strip(conditionMessage(err))
  expect_true(grepl('"se"', msg, fixed = TRUE))
  expect_true(grepl("0.1", msg, fixed = TRUE))
  expect_false(grepl("mapped from", msg, fixed = TRUE))
})

test_that("winsorize_data refuses to clip a text column", {
  box::use(artma / data / preprocess[winsorize_data])

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

  df <- data.frame(
    effect = c("0,817", "0,057", "-9,846", "1,023"),
    se = c(0.1, 0.2, 0.3, 0.4),
    stringsAsFactors = FALSE
  )

  err <- expect_error(winsorize_data(df), class = "rlang_error")
  msg <- cli::ansi_strip(conditionMessage(err))
  expect_true(grepl('"effect"', msg, fixed = TRUE))
  expect_true(grepl("is not numeric", msg, fixed = TRUE))
})