tests/testthat/test-vars-selectors.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

testthat::test_that("existing vars syntax is unchanged", {
  x <- vars(b2.sex, b3.education, c.age, q.bmi, f.sbp)

  testthat::expect_s3_class(x, "r4vn_vars")
  testthat::expect_identical(
    names(x),
    c("variable", "type", "specification", "reference_index")
  )
  testthat::expect_identical(
    x$variable,
    c("sex", "education", "age", "bmi", "sbp")
  )
  testthat::expect_identical(
    x$type,
    c("categorical", "categorical", "mean", "median", "full")
  )
  testthat::expect_identical(
    x$reference_index,
    c(2L, 3L, NA_integer_, NA_integer_, NA_integer_)
  )
})


testthat::test_that("vars with no arguments remains an error", {
  testthat::expect_error(
    vars(),
    "vars\\(\\.\\)"
  )
})


testthat::test_that("deferred selectors are captured", {
  all_vars <- vars(.)
  prefix <- vars(`kt*`)
  suffix <- vars(`*kt`)
  contains <- vars(`*kt*`)
  exclusion <- vars(., -id)

  testthat::expect_identical(all_vars$variable, ".")
  testthat::expect_identical(all_vars$type, "default")

  testthat::expect_identical(prefix$variable, "kt*")
  testthat::expect_identical(suffix$variable, "*kt")
  testthat::expect_identical(contains$variable, "*kt*")

  testthat::expect_identical(
    exclusion$specification,
    c(".", "-id")
  )
})


testthat::test_that("wildcard containing only stars is rejected", {
  testthat::expect_error(
    vars(`*`),
    "vars\\(\\.\\)"
  )

  testthat::expect_error(
    vars(`**`),
    "vars\\(\\.\\)"
  )
})


testthat::test_that("selectors resolve in data order", {
  dat <- data.frame(
    id = 1:5,
    kt3 = 1:5,
    age = c(31, 42, 38, 50, 46),
    kt1 = 6:10,
    sex = factor(c("F", "M", "F", "M", "F")),
    kt2 = 11:15,
    kt_total = 16:20,
    score_kt = 21:25,
    check.names = FALSE
  )

  x <- .r4vn_resolve_vars(vars(`kt*`), dat)

  testthat::expect_identical(
    x$variable,
    c("kt3", "kt1", "kt2", "kt_total")
  )
})


testthat::test_that("dot selects all variables and auto types deferred selectors", {
  dat <- data.frame(
    id = 1:4,
    age = c(20, 30, 40, 50),
    sex = factor(c("F", "M", "F", "M")),
    smoking = c(TRUE, FALSE, FALSE, TRUE)
  )

  x <- .r4vn_resolve_vars(vars(.), dat)

  testthat::expect_identical(
    x$variable,
    names(dat)
  )
  testthat::expect_identical(
    x$type,
    c("mean", "mean", "categorical", "categorical")
  )
})


testthat::test_that("exact unprefixed variables are automatically typed from data", {
  dat <- data.frame(
    age = c(20, 30, 40, 50),
    gestational_age = c(30, 32, 34, 36),
    sex = factor(c("F", "M", "F", "M")),
    yesno = c(0, 1, 0, 1)
  )

  x <- .r4vn_resolve_vars(vars(age, sex, gestational_age), dat)
  testthat::expect_identical(x$type, c("mean", "categorical", "mean"))

  # Numeric-coded categorical variables remain available explicitly via b1./b2.
  y <- .r4vn_resolve_vars(vars(b1.yesno), dat)
  testthat::expect_identical(y$type, "categorical")
  testthat::expect_identical(y$reference_index, 1L)
  testthat::expect_identical(y$specification, "b1.yesno")
})


testthat::test_that("prefix suffix and contains wildcards work", {
  dat <- data.frame(
    kt1 = 1:3,
    kt_total = 4:6,
    score_kt = 7:9,
    pre_kt_post = 10:12,
    other = 13:15,
    check.names = FALSE
  )

  testthat::expect_identical(
    .r4vn_resolve_vars(vars(`kt*`), dat)$variable,
    c("kt1", "kt_total")
  )

  testthat::expect_identical(
    .r4vn_resolve_vars(vars(`*kt`), dat)$variable,
    c("score_kt")
  )

  testthat::expect_identical(
    .r4vn_resolve_vars(vars(`*kt*`), dat)$variable,
    c("kt1", "kt_total", "score_kt", "pre_kt_post")
  )
})


testthat::test_that("typed wildcards preserve R4VN prefixes", {
  dat <- data.frame(
    lab_hb = 1:4,
    lab_wbc = 5:8,
    lab_crp = 9:12,
    sex = factor(c("F", "M", "F", "M"))
  )

  x <- .r4vn_resolve_vars(
    vars(`c.lab*`, q.lab_crp),
    dat
  )

  testthat::expect_identical(
    x$variable,
    c("lab_hb", "lab_wbc", "lab_crp")
  )
  testthat::expect_identical(
    x$type,
    c("mean", "mean", "median")
  )
  testthat::expect_identical(
    x$specification,
    c("c.lab_hb", "c.lab_wbc", "q.lab_crp")
  )
})


testthat::test_that("exact selector overrides wildcard and wildcard overrides dot", {
  dat <- data.frame(
    age = 20:23,
    lab_hb = 1:4,
    lab_crp = 5:8,
    sex = factor(c("F", "M", "F", "M"))
  )

  x <- .r4vn_resolve_vars(
    vars(., `c.lab*`, q.lab_crp),
    dat
  )

  testthat::expect_identical(
    x$type,
    c("mean", "mean", "median", "categorical")
  )
})


testthat::test_that("later declaration wins at equal specificity", {
  dat <- data.frame(
    lab_crp = 1:4,
    lab_hb = 5:8
  )

  x <- .r4vn_resolve_vars(
    vars(`c.lab*`, `q.*crp`),
    dat
  )

  testthat::expect_identical(
    x$type,
    c("median", "mean")
  )
})


testthat::test_that("exclusions are applied last", {
  dat <- data.frame(
    id = 1:4,
    id_site = 5:8,
    age = 20:23,
    kt1 = 1:4,
    kt2 = 5:8,
    kt_total = 9:12
  )

  x1 <- .r4vn_resolve_vars(vars(., -id), dat)
  testthat::expect_false("id" %in% x1$variable)

  x2 <- .r4vn_resolve_vars(vars(., -`id*`), dat)
  testthat::expect_false(any(c("id", "id_site") %in% x2$variable))

  x3 <- .r4vn_resolve_vars(vars(`kt*`, -kt_total), dat)
  testthat::expect_identical(x3$variable, c("kt1", "kt2"))
})


testthat::test_that("duplicate matches are collapsed", {
  dat <- data.frame(
    kt1 = 1:4,
    kt2 = 5:8
  )

  x <- .r4vn_resolve_vars(
    vars(kt1, `kt*`),
    dat
  )

  testthat::expect_identical(
    x$variable,
    c("kt1", "kt2")
  )

  # Exact unprefixed numeric variables now use the same automatic typing rule
  # as wildcard/dot selectors: numeric -> mean/SD.
  testthat::expect_identical(
    x$type,
    c("mean", "mean")
  )
})


testthat::test_that("b-prefix works with wildcard selectors", {
  dat <- data.frame(
    item1 = factor(c("No", "Yes", "No", "Yes"),
                   levels = c("No", "Yes")),
    item2 = factor(c("Low", "High", "Low", "High"),
                   levels = c("Low", "High")),
    other = 1:4
  )

  x <- .r4vn_resolve_vars(
    vars(`b2.item*`),
    dat
  )

  testthat::expect_identical(
    x$variable,
    c("item1", "item2")
  )
  testthat::expect_identical(
    x$type,
    c("categorical", "categorical")
  )
  testthat::expect_identical(
    x$reference_index,
    c(2L, 2L)
  )
  testthat::expect_identical(
    x$specification,
    c("b2.item1", "b2.item2")
  )
})


testthat::test_that("bad selectors fail loudly", {
  dat <- data.frame(
    age = 1:3,
    sex = factor(c("F", "M", "F"))
  )

  testthat::expect_error(
    .r4vn_resolve_vars(vars(not_here), dat),
    "not found"
  )

  testthat::expect_error(
    .r4vn_resolve_vars(vars(`xyz*`), dat),
    "No variables matched"
  )

  testthat::expect_error(
    .r4vn_resolve_vars(vars(-age), dat),
    "inclusion selector"
  )
})


test_that("i. prefix explicitly declares a categorical variable", {
  d <- data.frame(sex = c(0, 1, 1, 0), age = c(20, 30, 40, 50))
  z <- R4VN:::.r4vn_resolve_vars(vars(i.sex, c.age), d, default_type = "auto", strict = TRUE)
  expect_equal(z$variable, c("sex", "age"))
  expect_equal(z$type, c("categorical", "mean"))
  expect_equal(z$reference_index[1], 1L)
})