tests/testthat/test-data.R

In ackwards: Bass-Ackwards Hierarchical Structural Analysis

test_that("bfi25 has the expected shape and structure", {
  expect_equal(dim(bfi25), c(1000L, 25L))
  expect_equal(
    colnames(bfi25),
    c(
      paste0("A", 1:5), paste0("C", 1:5), paste0("E", 1:5),
      paste0("N", 1:5), paste0("O", 1:5)
    )
  )
  expect_true(all(vapply(bfi25, is.integer, logical(1))))
  expect_true(anyNA(bfi25))
  expect_true(all(bfi25 >= 1L | is.na(bfi25)))
  expect_true(all(bfi25 <= 6L | is.na(bfi25)))
})

test_that("bfi25 ships public-domain IPIP labels that flow into top_items()", {
  skip_if_not_installed("psych")

  # Every column carries a non-empty scalar "label" attribute.
  labs <- vapply(
    bfi25,
    function(col) attr(col, "label", exact = TRUE) %||% NA_character_,
    character(1)
  )
  expect_equal(sum(!is.na(labs)), 25L)
  expect_true(all(nzchar(labs)))
  expect_identical(unname(labs[["E4"]]), "Make friends easily")

  # Fit on the raw dataset (labels survive; NAs handled by `missing`) -> the
  # labels are captured and surfaced by top_items() with zero user setup.
  x <- suppressWarnings(ackwards(bfi25, k_max = 3))
  expect_length(x$meta$item_labels, 25L)
  ti <- top_items(x, level = 3, cut = 0.4)
  expect_true("label" %in% names(ti$data))
  expect_true(any(ti$data$label == "Make friends easily", na.rm = TRUE))
})

test_that("bfi25 labels are captured regardless of the missing-data route (M50)", {
  skip_if_not_installed("psych")
  # Capture happens on the supplied data before any missing handling, so both
  # the pairwise (default) and listwise routes carry the labels through.
  x_pair <- suppressWarnings(ackwards(bfi25, k_max = 2, missing = "pairwise"))
  x_list <- suppressWarnings(ackwards(bfi25, k_max = 2, missing = "listwise"))
  expect_length(x_pair$meta$item_labels, 25L)
  expect_length(x_list$meta$item_labels, 25L)
})

test_that("base row-subsetting drops bfi25's plain label attributes (M50 contract)", {
  # Documented caveat: plain `label` attributes do not survive base `[`, unlike
  # class-based labelled/haven vectors, so na.omit() / row-indexing strip them
  # and top_items() then falls back to bare codes. Guards the roxygen guidance
  # to fit the dataset directly (with `missing =`) rather than pre-filtering.
  expect_null(attr(na.omit(bfi25)$E4, "label", exact = TRUE))
  expect_null(attr(bfi25[1:100, ]$E4, "label", exact = TRUE))
  # Column selection (not row subsetting) keeps the attribute.
  expect_identical(
    attr(bfi25[, "E4"], "label", exact = TRUE),
    "Make friends easily"
  )
})

test_that("sim16 has the expected shape and structure", {
  expect_equal(dim(sim16), c(1000L, 16L))
  expect_equal(colnames(sim16), paste0("i", 1:16))
  expect_true(all(vapply(sim16, is.double, logical(1))))
  expect_false(anyNA(sim16))
  # Continuous, not ordinal-looking: far more than 7 distinct values per column.
  expect_true(all(vapply(sim16, function(v) length(unique(v)) > 7L, logical(1))))
})

test_that("sim16 triggers no ordinal-detection warning under pca or efa", {
  skip_if_not_installed("psych")
  x_pca <- suppressMessages(ackwards(sim16, k_max = 4, engine = "pca"))
  x_efa <- suppressMessages(ackwards(sim16, k_max = 4, engine = "efa"))
  expect_false(x_pca$meta$ordinal_warned)
  expect_false(x_efa$meta$ordinal_warned)
})

test_that("sim16 recovers its known 1 -> 2 -> 4 hierarchy under efa", {
  skip_if_not_installed("psych")
  x <- suppressMessages(ackwards(sim16, k_max = 4, engine = "efa"))

  .primary_groups <- function(level) {
    load_mat <- x$levels[[as.character(level)]]$loadings
    unname(apply(abs(load_mat), 1, which.max))
  }

  # k = 1: a single general factor spans all 16 items.
  expect_equal(length(unique(.primary_groups(1))), 1L)

  # k = 2: splits exactly along the metatrait line (i1-i8 vs. i9-i16).
  g2 <- .primary_groups(2)
  expect_equal(length(unique(g2[1:8])), 1L)
  expect_equal(length(unique(g2[9:16])), 1L)
  expect_false(g2[1] == g2[9])

  # k = 4: recovers the 4 true group factors (i1-4, i5-8, i9-12, i13-16) exactly.
  g4 <- .primary_groups(4)
  true_groups <- rep(1:4, each = 4)
  expect_equal(length(unique(g4)), 4L)
  for (grp in 1:4) {
    idx <- which(true_groups == grp)
    expect_equal(length(unique(g4[idx])), 1L)
  }
})

test_that("suggest_k(sim16) converges on the true k = 4 (idealized case)", {
  skip_if_not_installed("psych")
  skip_if_not_installed("EFAtools")
  sk <- suggest_k(sim16, n_iter = 5L, seed = 1L)

  # sim16 is deliberately the *idealized* teaching case: a strong, clean planted
  # signal on which the criteria converge (contrast bfi25, where the same
  # criteria span k = 4-6). We assert that convergence robustly rather than
  # pinning all six criteria to 4 exactly -- PA-PC/PA-FA/CD resample, so their
  # exact value can wobble +/-1 across platforms/RNG even under a fixed seed.
  expect_equal(sk$k_map, 4L) # MAP is deterministic -> a stable anchor on k = 4

  ks <- c(
    sk$k_parallel_pc, sk$k_parallel_fa, sk$k_map,
    sk$k_vss1, sk$k_vss2, sk$k_cd
  )
  # The majority of criteria (the "consensus") lands on the true k = 4.
  expect_equal(as.integer(names(which.max(table(ks)))), 4L)
})

test_that("sim16 at k_max = 5 guarantees a redundant chain and an artifact signal", {
  skip_if_not_installed("psych")
  x <- suppressMessages(
    ackwards(sim16, k_max = 5, engine = "efa") |>
      prune(c("redundant", "artifact"))
  )

  # Redundancy: the true (non-splitting) factors persist across levels, so at
  # least one adjacent-level chain is flagged (|r| >= .9 and phi >= .95).
  expect_gte(sum(x$prune$nodes$pruned), 1L)
  expect_gte(nrow(subset(x$prune$phi, abs_phi >= 0.95)), 1L)

  # Artifact: k = 5 has no real 5th dimension, so the extra factor is an
  # orphan with too few primary-loading items.
  structural <- x$prune$structural
  expect_gte(sum(structural$few_items | structural$orphan), 1L)

  # Stronger: the artefact factor is a primary loader for *zero* items (the
  # doc's "orphan with zero primary-loading items"), and that same factor is
  # exactly the one flagged both few_items and orphan.
  load5 <- x$levels[["5"]]$loadings
  primary5 <- colnames(load5)[apply(abs(load5), 1, which.max)]
  counts5 <- table(factor(primary5, levels = colnames(load5)))
  expect_true(any(counts5 == 0L))
  orphan_ids <- names(counts5)[counts5 == 0L]
  flagged_ids <- subset(structural, few_items & orphan)$id
  expect_true(all(orphan_ids %in% flagged_ids))
})

test_that("forbes2023 is a valid 155x155 correlation matrix with symptom labels", {
  expect_true(is.matrix(forbes2023))
  expect_true(is.numeric(forbes2023))
  expect_equal(dim(forbes2023), c(155L, 155L))
  # Symmetric with a unit diagonal -- a genuine correlation matrix.
  expect_true(isSymmetric(unname(forbes2023)))
  expect_equal(diag(forbes2023), rep(1, 155L), ignore_attr = TRUE)
  expect_true(all(abs(forbes2023) <= 1 + 1e-12))
  # Row and column names are the (identical, non-empty, unique) symptom labels.
  expect_false(is.null(rownames(forbes2023)))
  expect_identical(rownames(forbes2023), colnames(forbes2023))
  expect_true(all(nzchar(rownames(forbes2023))))
  expect_false(anyDuplicated(rownames(forbes2023)) > 0L)
})

test_that("data-raw/sim16.R regenerates sim16 identically (fixed-seed reproducibility)", {
  script_path <- testthat::test_path("..", "..", "data-raw", "sim16.R")
  skip_if(!file.exists(script_path), "data-raw/sim16.R not reachable from this test context")

  # Drop the trailing usethis::use_data() call (writes to disk; not what this
  # test is checking) without referencing usethis:: literally -- R CMD check's
  # unstated-dependency scan flags any pkg:: token in tests/, even in a string.
  exprs <- parse(script_path)
  is_use_data_call <- function(e) {
    is.call(e) && grepl("use_data", deparse(e[[1]])[1], fixed = TRUE)
  }
  exprs <- Filter(Negate(is_use_data_call), exprs)

  env <- new.env(parent = globalenv())
  for (e in exprs) eval(e, envir = env)

  expect_equal(env$sim16, sim16, ignore_attr = TRUE)
})