tests/testthat/test-check-items.R

In ackwards: Bass-Ackwards Hierarchical Structural Analysis

# check_items(): pre-analysis item screen + the shared internal screen that
# ackwards() runs (error on constant, warn on near-constant).

.mk_items <- function(n = 300, seed = 1) {
  set.seed(seed)
  mk <- function(p) sample(seq_along(p), n, replace = TRUE, prob = p)
  d <- as.data.frame(lapply(1:5, function(i) mk(rep(0.2, 5))))
  names(d) <- paste0("i", 1:5)
  d
}

test_that("check_items() returns a per-item report with the expected shape", {
  d <- .mk_items()
  out <- check_items(d, cor = "polychoric")
  expect_s3_class(out, "check_items")
  expect_s3_class(out, "data.frame")
  expect_equal(nrow(out), ncol(d))
  expect_named(
    out,
    c("item", "n_valid", "pct_missing", "n_distinct", "min_count", "top_prop", "flag")
  )
  expect_identical(attr(out, "basis"), "polychoric")
  # clean five-category items -> nothing flagged
  expect_true(all(out$flag == "ok"))
})

test_that("check_items() flags constant, near-constant, and sparse items", {
  n <- 300
  d <- .mk_items(n = n)
  d$const <- rep(3L, n) # no variance
  d$nearconst <- c(rep(2L, n - 2L), 3L, 4L) # 298,1,1 -> dominant category
  d$sparse <- c(rep(1L, 80), rep(2L, 80), rep(3L, 80), rep(4L, 57), rep(5L, 3))

  out <- check_items(d, cor = "polychoric")
  fl <- setNames(out$flag, out$item)
  expect_identical(unname(fl["const"]), "constant")
  expect_identical(unname(fl["nearconst"]), "near-constant")
  expect_identical(unname(fl["sparse"]), "sparse category")
})

test_that("check_items() sparse flag is polychoric-specific", {
  n <- 300
  d <- .mk_items(n = n)
  d$sparse <- c(rep(1L, 80), rep(2L, 80), rep(3L, 80), rep(4L, 57), rep(5L, 3))
  # Under pearson, a sparse category is not a problem -> not flagged.
  out_p <- check_items(d, cor = "pearson")
  expect_identical(out_p$flag[out_p$item == "sparse"], "ok")
  # A constant item is still flagged on any basis.
  d$const <- rep(2L, n)
  out_p2 <- check_items(d, cor = "pearson")
  expect_identical(out_p2$flag[out_p2$item == "const"], "constant")
})

test_that("check_items() flags high missingness", {
  n <- 300
  d <- .mk_items(n = n)
  d$holey <- d$i1
  d$holey[1:100] <- NA # 33% missing
  out <- check_items(d, cor = "pearson")
  expect_identical(out$flag[out$item == "holey"], "high missing")
  expect_gt(out$pct_missing[out$item == "holey"], 0.3)
})

test_that("check_items() print runs for clean and flagged inputs", {
  d <- .mk_items()
  expect_no_error(print(check_items(d, cor = "pearson")))
  # Flag both a constant (red) and a near-constant (yellow) item so both print
  # branches are exercised.
  d$const <- rep(1L, nrow(d))
  d$nc <- c(rep(2L, nrow(d) - 2L), 3L, 4L)
  expect_no_error(print(check_items(d)))
})

test_that("check_items() validates its input", {
  expect_error(check_items(1:10), "data frame or numeric matrix")
  expect_error(check_items(data.frame()), "no columns")
})

test_that("subsetting a check_items report returns a plain data frame", {
  d <- .mk_items()
  d$const <- rep(1L, nrow(d))
  out <- check_items(d)
  # Row + column subset -> a plain data frame (not the report's print summary),
  # even when the `flag` column is not selected.
  sub <- out[out$flag != "ok", c("item", "min_count")]
  expect_false(inherits(sub, "check_items"))
  expect_s3_class(sub, "data.frame")
  expect_named(sub, c("item", "min_count"))
  expect_equal(nrow(sub), sum(out$flag != "ok"))
  expect_null(attr(sub, "basis"))
  # The un-subset object keeps its class (and its summary print).
  expect_s3_class(out, "check_items")
  # Column access still works on the full object.
  expect_type(out$flag, "character")
})

test_that("ackwards() errors on a constant item, naming it", {
  skip_if_not_installed("psych")
  n <- 300
  d <- .mk_items(n = n)
  d$dead <- rep(3L, n)
  expect_error(
    suppressWarnings(ackwards(d, k_max = 3, engine = "efa", cor = "polychoric", correct = 0)),
    "dead"
  )
  expect_error(
    suppressWarnings(ackwards(d, k_max = 3, engine = "efa", cor = "polychoric", correct = 0)),
    "no variance"
  )
})

test_that("ackwards() warns on a near-constant item but still builds", {
  skip_if_not_installed("psych")
  n <- 300
  d <- .mk_items(n = n)
  d$nc <- c(rep(2L, n - 2L), 3L, 4L)
  rlang::reset_warning_verbosity("ackwards_degenerate_items")
  # A near-constant item also drives the matrix non-positive-definite (smoothing)
  # and psych emits its own notes; capture all warnings so none leak, and assert
  # the near-constant advisory is among them.
  w <- testthat::capture_warnings(
    x <- suppressMessages(
      ackwards(d, k_max = 3, engine = "efa", cor = "polychoric", correct = 0)
    )
  )
  expect_true(any(grepl("near-constant", w)))
  expect_s3_class(x, "ackwards")
})

test_that("ackwards() raises no item warning on clean data", {
  skip_if_not_installed("psych")
  expect_no_warning(
    suppressMessages(ackwards(sim16, k_max = 3, engine = "efa")),
    message = "near-constant|no variance"
  )
})

test_that("check_items() flags an all-NA column as constant (M49 review)", {
  d <- .mk_items()
  d$empty <- NA_integer_
  out <- check_items(d, cor = "pearson")
  expect_identical(out$flag[out$item == "empty"], "constant")
  expect_equal(out$n_valid[out$item == "empty"], 0L)
})