tests/testthat/test-pca.R

In ackwards: Bass-Ackwards Hierarchical Structural Analysis

test_that("ackwards() returns a valid ackwards object for the smoke-test case", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5))

  expect_s3_class(x, "ackwards")
  validate_ackwards(x) # internal: checks all required fields

  expect_equal(x$engine, "pca")
  expect_equal(x$k_max, 5L)
  expect_equal(x$n_obs, 2800L)
  expect_equal(x$cor, "pearson")

  # All five levels present and converged
  expect_equal(length(x$levels), 5L)
  expect_true(all(vapply(x$levels, `[[`, logical(1), "converged")))

  # Four adjacent edge matrices (1:2, 2:3, 3:4, 4:5)
  expect_equal(length(x$edges$matrices), 4L)
  expect_named(x$edges$matrices, c("1:2", "2:3", "3:4", "4:5"))

  # Edge matrix dimensions
  for (i in 1:4) {
    E <- x$edges$matrices[[paste0(i, ":", i + 1)]]
    expect_equal(nrow(E), i, info = paste("rows of", i, ":", i + 1))
    expect_equal(ncol(E), i + 1, info = paste("cols of", i, ":", i + 1))
    expect_true(all(abs(E) <= 1 + 1e-9), info = "correlations in [-1, 1]")
  }
})

test_that("PCA edge correlations match psych::bassAckward within tolerance", {
  skip_if_not_installed("psych")

  ba <- psych::bassAckward(
    psych::bfi[, 1:25],
    nfactors = 5, fm = "pca", rotate = "varimax", plot = FALSE
  )
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5))

  for (i in 1:4) {
    # psych stores (k+1) × k; ours is k × (k+1) — transpose to align
    psych_mat <- t(ba$bass.ack[[i + 1L]])
    our_mat <- x$edges$matrices[[paste0(i, ":", i + 1)]]

    max_diff <- max(abs(abs(psych_mat) - abs(our_mat)))
    expect_lt(max_diff, 1e-4, label = paste("Level", i, "->", i + 1))
  }
})

test_that("levels have correct structure and label formats", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3))

  for (ki in 1:3) {
    lev <- x$levels[[as.character(ki)]]
    expect_equal(ncol(lev$loadings), ki)
    expect_equal(nrow(lev$loadings), 25L)
    expect_equal(lev$labels, paste0("m", ki, "f", seq_len(ki)))
    expect_equal(colnames(lev$loadings), lev$labels)
    expect_true(isTRUE(lev$converged))
    expect_equal(dim(lev$scoring$weights), c(25L, ki))
  }
})

test_that("ackwards() errors informatively on bad inputs", {
  skip_if_not_installed("psych")
  d <- psych::bfi[, 1:5]
  expect_error(ackwards(d, k_max = 0), "integer >= 2")
  expect_error(ackwards(d, k_max = 1), "integer >= 2")
  expect_error(ackwards(d, k_max = 100), "cannot exceed")
  expect_error(ackwards(d, k_max = 1.5), "integer >= 2")
  expect_error(ackwards(list(), k_max = 2), "data frame")
  # cut_show thresholds |r|, so it must be a single number in [0, 1] (M42/m8)
  expect_error(ackwards(d, k_max = 2, cut_show = 5), "\\[0, 1\\]")
  expect_error(ackwards(d, k_max = 2, cut_show = -0.1), "\\[0, 1\\]")
  expect_error(ackwards(d, k_max = 2, cut_show = c(0.3, 0.5)), "\\[0, 1\\]")
  expect_error(ackwards(d, k_max = 2, cut_show = NA), "\\[0, 1\\]")
  expect_error(ackwards(d, k_max = 2, cut_show = "0.3"), "\\[0, 1\\]")
})

test_that("keep_scores = TRUE stores a named list of score matrices", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2, keep_scores = TRUE))
  expect_false(is.null(x$scores))
  expect_named(x$scores, c("1", "2"))
  expect_equal(nrow(x$scores[["1"]]), nrow(psych::bfi))
  expect_equal(ncol(x$scores[["1"]]), 1L)
  expect_equal(ncol(x$scores[["2"]]), 2L)
})

test_that("keep_fits = TRUE stores a named list of raw fit objects", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2, keep_fits = TRUE))
  expect_false(is.null(x$fits))
  expect_named(x$fits, c("1", "2"))
  expect_true(inherits(x$fits[["1"]], "psych"))
})

test_that("meta$cut_show stores the cut_show value", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2, cut_show = 0.4))
  expect_equal(x$meta$cut_show, 0.4)
})

test_that("detect_ordinal() flags bfi columns", {
  skip_if_not_installed("psych")
  expect_length(ackwards:::detect_ordinal(psych::bfi[, 1:25]), 25L)
})

test_that("ordinal-detection warning names the flagged columns (M42/e3)", {
  skip_if_not_installed("psych")
  d <- data.frame(
    L1 = sample(1:5, 100, replace = TRUE),
    L2 = sample(1:5, 100, replace = TRUE),
    c1 = rnorm(100), c2 = rnorm(100), c3 = rnorm(100)
  )
  rlang::reset_warning_verbosity("ackwards_ordinal_warning")
  expect_warning(ackwards(d, k_max = 2), "L1")
})

test_that("detect_ordinal() flags nothing for continuous data", {
  set.seed(1)
  d <- data.frame(matrix(rnorm(500), 100, 5))
  expect_identical(ackwards:::detect_ordinal(d), character(0))
})

test_that("meta$ordinal_warned is TRUE for bfi data", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2))
  expect_true(x$meta$ordinal_warned)
})

test_that("kappa is not a parameter of ackwards() (M13: removed dead arg)", {
  expect_false("kappa" %in% names(formals(ackwards)))
})

test_that("ackwards() meta does not store kappa (M13: removed)", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2))
  expect_false("kappa" %in% names(x$meta))
})

# ── tidy(sort = "strength") ────────────────────────────────────────────────────

test_that("tidy(x, sort = 'strength') returns edges in descending |r| order", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5))
  out <- tidy(x, sort = "strength")
  expect_s3_class(out, "data.frame")
  expect_true(all(diff(abs(out$r)) <= 0))
})

test_that("tidy(x, sort = 'none') is byte-identical to the default", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5))
  expect_identical(tidy(x, sort = "none"), tidy(x))
})

test_that("tidy(x, sort = 'strength', what = 'loadings') errors informatively", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2))
  expect_error(tidy(x, what = "loadings", sort = "strength"), "edges")
})

# ── tidy(primary_only = TRUE) ──────────────────────────────────────────────────

test_that("tidy(x, primary_only = TRUE) returns only is_primary edges", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5))
  full <- tidy(x, what = "edges")
  prim <- tidy(x, what = "edges", primary_only = TRUE)
  expect_true(all(prim$is_primary))
  expect_identical(nrow(prim), sum(full$is_primary))
})

test_that("tidy(x, primary_only = TRUE, sort = 'strength') filters and sorts", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5))
  out <- tidy(x, what = "edges", primary_only = TRUE, sort = "strength")
  expect_true(all(out$is_primary))
  expect_true(all(diff(abs(out$r)) <= 0))
})

test_that("tidy(x, primary_only = TRUE, what = 'loadings') errors informatively", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2))
  expect_error(
    tidy(x, what = "loadings", primary_only = TRUE),
    "edges"
  )
})

# ── tidy(what = "loadings") has SE/CI columns, NA for PCA ──────────────────────

test_that("tidy(x, what = 'loadings') has se/ci cols present but NA for PCA", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2))
  ld <- tidy(x, what = "loadings")
  expect_true(all(c("se", "ci_lower", "ci_upper") %in% names(ld)))
  expect_true(all(is.na(ld$se)))
})

# ── glance() fit columns ───────────────────────────────────────────────────────

test_that("glance() for PCA has fit columns present but all NA", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3))
  g <- generics::glance(x)
  expect_true(all(c("CFI", "TLI", "RMSEA", "SRMR", "BIC") %in% names(g)))
  expect_true(is.na(g$CFI))
  expect_true(is.na(g$TLI))
  expect_true(is.na(g$RMSEA))
  expect_true(is.na(g$SRMR))
  expect_true(is.na(g$BIC))
})

# ── .glance_fit defensive branches (Invariant 7: truncation) ──────────────────

test_that("glance() returns all-NA fit when deepest_converged < 2", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3))
  # Simulate a run that truncated to the 1-factor anchor only.
  x$meta$deepest_converged <- 1L
  g <- generics::glance(x)
  expect_true(is.na(g$CFI))
  expect_true(is.na(g$RMSEA))
  expect_true(is.na(g$BIC))
})

test_that("glance() returns all-NA fit when the deepest level carries no fit", {
  skip_if_not_installed("psych")
  x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3))
  # Force the empty-fit guard: deepest level has no stored fit vector.
  x$levels[[as.character(x$meta$deepest_converged)]]$fit <- numeric(0)
  g <- generics::glance(x)
  expect_true(is.na(g$CFI))
  expect_true(is.na(g$RMSEA))
  expect_true(is.na(g$BIC))
})

test_that("near-singularity is flagged on the Pearson basis too (M49 review)", {
  skip_if_not_installed("psych")
  # Duplicate continuous columns -> perfectly collinear -> rank-deficient R,
  # even on the Pearson basis (the near-singular flag is basis-agnostic).
  set.seed(5)
  n <- 250
  m <- as.data.frame(matrix(rnorm(n * 5), n, 5))
  m <- cbind(m, m)
  names(m) <- paste0("c", 1:10)
  rlang::reset_warning_verbosity("ackwards_near_singular")
  w <- testthat::capture_warnings(
    x <- suppressMessages(ackwards(m, k_max = 3, engine = "pca"))
  )
  expect_true(any(grepl("near-singular", w)))
  expect_true(x$meta$near_singular)
  expect_lt(x$meta$min_eigenvalue, 1e-4)
})