test_that("algebra and scores paths agree for PCA engine on all adjacent pairs", { skip_if_not_installed("psych") set.seed(42) n <- 150 f1 <- rnorm(n) f2 <- rnorm(n) data <- data.frame( x1 = f1 + 0.3 * rnorm(n), x2 = f1 + 0.3 * rnorm(n), x3 = f1 + 0.3 * rnorm(n), x4 = f2 + 0.3 * rnorm(n), x5 = f2 + 0.3 * rnorm(n), x6 = f2 + 0.3 * rnorm(n) ) R <- cor(data) x <- cached(ackwards(data, k_max = 4)) E_scores_all <- compute_edges( levels = x$levels, R = R, edge_method = "scores", pairs = "adjacent", data = data )$matrices for (key in names(x$edges$matrices)) { E_alg <- x$edges$matrices[[key]] E_sc <- E_scores_all[[key]] expect_lt( max(abs(abs(E_alg) - abs(E_sc))), 1e-6, label = paste("algebra vs scores for pair", key) ) } }) test_that("compute_edges errors when algebra forced but R missing", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2)) expect_error( compute_edges(x$levels, R = NULL, edge_method = "algebra"), "conditions not met" ) }) test_that("compute_edges with explicit edge_method='algebra' and valid R succeeds", { # Covers the TRUE branch inside the algebra case of the switch, # which is only reached when edge_method = "algebra" and algebra_ok = TRUE. skip_if_not_installed("psych") x <- cached(ackwards(bfi25[, 1:6], k_max = 3)) R <- cor(bfi25[, 1:6], use = "pairwise.complete.obs") result <- compute_edges(x$levels, R = R, edge_method = "algebra") expect_type(result, "list") expect_true(!is.null(result$matrices)) }) test_that("compute_edges errors when scores needed but data absent", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 2)) expect_error( compute_edges(x$levels, R = NULL, edge_method = "scores", data = NULL), "data" ) }) test_that("pairs='all' produces skip-level edge matrices in ackwards()", { skip_if_not_installed("psych") set.seed(1) n <- 200 g <- rnorm(n) s1 <- rnorm(n) s2 <- rnorm(n) data <- data.frame( x1 = g + s1 + rnorm(n, sd = 0.3), x2 = g + s1 + rnorm(n, sd = 0.3), x3 = g + s1 + rnorm(n, sd = 0.3), x4 = g + s2 + rnorm(n, sd = 0.3), x5 = g + s2 + rnorm(n, sd = 0.3), x6 = g + s2 + rnorm(n, sd = 0.3) ) x_adj <- cached(ackwards(data, k_max = 4, pairs = "adjacent")) x_all <- cached(ackwards(data, k_max = 4, pairs = "all")) # Default is adjacent expect_equal(x_adj$meta$pairs, "adjacent") expect_equal(x_all$meta$pairs, "all") # adjacent: only consecutive level keys adj_keys <- names(x_adj$edges$matrices) expect_setequal(adj_keys, c("1:2", "2:3", "3:4")) # all: includes skip-level keys all_keys <- names(x_all$edges$matrices) expect_true(all(c("1:2", "2:3", "3:4", "1:3", "1:4", "2:4") %in% all_keys)) # Adjacent edges are consistent between the two modes (same aligned weights) for (key in c("1:2", "2:3", "3:4")) { expect_equal( x_adj$edges$matrices[[key]], x_all$edges$matrices[[key]], tolerance = 1e-10, label = paste("adjacent edge", key, "consistent between pairs modes") ) } }) test_that("skip-level edges in pairs='all' have is_primary=FALSE and correct level_from/to", { skip_if_not_installed("psych") set.seed(2) n <- 200 g <- rnorm(n) s1 <- rnorm(n) s2 <- rnorm(n) data <- data.frame( x1 = g + s1 + rnorm(n, sd = 0.3), x2 = g + s1 + rnorm(n, sd = 0.3), x3 = g + s1 + rnorm(n, sd = 0.3), x4 = g + s2 + rnorm(n, sd = 0.3), x5 = g + s2 + rnorm(n, sd = 0.3), x6 = g + s2 + rnorm(n, sd = 0.3) ) x <- cached(ackwards(data, k_max = 3, pairs = "all")) tidy <- x$edges$tidy # Skip-level pair 1:3 should exist skip <- tidy[tidy$level_from == 1 & tidy$level_to == 3, ] expect_gt(nrow(skip), 0) # All skip-level edges must be non-primary expect_true(all(!skip$is_primary)) # level_from < level_to throughout expect_true(all(tidy$level_from < tidy$level_to)) }) test_that("algebra and scores agree for all-levels edges (PCA)", { skip_if_not_installed("psych") set.seed(3) n <- 200 g <- rnorm(n) s1 <- rnorm(n) s2 <- rnorm(n) data <- data.frame( x1 = g + s1 + rnorm(n, sd = 0.3), x2 = g + s1 + rnorm(n, sd = 0.3), x3 = g + s1 + rnorm(n, sd = 0.3), x4 = g + s2 + rnorm(n, sd = 0.3), x5 = g + s2 + rnorm(n, sd = 0.3), x6 = g + s2 + rnorm(n, sd = 0.3) ) R <- cor(data) x <- cached(ackwards(data, k_max = 4, pairs = "all")) E_scores_all <- compute_edges( levels = x$levels, R = R, edge_method = "scores", pairs = "all", data = data )$matrices for (key in names(x$edges$matrices)) { E_alg <- x$edges$matrices[[key]] E_sc <- E_scores_all[[key]] expect_lt( max(abs(abs(E_alg) - abs(E_sc))), 1e-6, label = paste("algebra vs scores for all-pairs edge", key) ) } }) # --- match_parents unit tests --------------------------------------------------- # Adjacent levels always have n_b = n_a + 1 (non-square). LSAP (bijection) would # require a padding row that can return index > nrow(E) → subscript OOB. # The greedy argmax is correct: each child independently picks its closest parent; # multiple children may share a parent, which is normal in the hierarchy. test_that("match_parents: non-square (n_b > n_a) assigns correct greedy parents", { # Level k-1 has 2 factors (rows), level k has 3 factors (cols). # Col 1 and 2 both peak at row 1; col 3 peaks at row 2. E <- matrix( c( 0.9, 0.8, 0.1, 0.1, 0.2, 0.7 ), nrow = 2 ) result <- ackwards:::match_parents(E) expect_equal(result, c(1L, 1L, 2L)) # All returned indices must be within 1..nrow(E) expect_true(all(result >= 1L & result <= nrow(E))) }) test_that("match_parents: square case assigns correct parents", { E <- matrix( c( 0.9, 0.1, 0.1, 0.2, 0.8, 0.2, 0.1, 0.2, 0.7 ), nrow = 3, byrow = TRUE ) result <- ackwards:::match_parents(E) expect_equal(result, c(1L, 2L, 3L)) }) # --- .align_signs sign-propagation unit tests ----------------------------------- # Regression (M35): a level-k factor's flip must be chosen against its primary # parent's *aligned* sign, so that a parent which is itself flipped does not leave # its children's PRIMARY edge displaying negative. Sign propagates top-down # (DESIGN s.7: "propagating top-down"). test_that(".align_signs: a flipped parent keeps its child's primary edge positive", { # Level 1: 1 factor (positive colSum -> no flip). # Level 2: 2 factors; factor 2's raw edge to m1f1 is negative -> it is flipped. # Level 3: 3 factors; factor 2's primary parent is the flipped level-2 factor 2, # with a raw positive edge (+0.9). Pre-fix this displayed as -0.9. loadings_list <- list( matrix(rep(0.7, 4), ncol = 1), matrix(seq_len(8) / 10, ncol = 2), matrix(seq_len(12) / 10, ncol = 3) ) edges_list <- list( "1:2" = matrix(c(0.8, -0.9), nrow = 1), "2:3" = matrix(c(0.85, -0.1, 0.05, 0.90, 0.1, 0.7), nrow = 2) ) lineage <- list(NULL, c(1L, 1L), c(1L, 2L, 1L)) aligned <- ackwards:::.align_signs(loadings_list, edges_list, lineage) # Level-2 factor 2 was flipped negative (its raw edge to m1f1 was -0.9). expect_equal(aligned$signs[[2]], c(1L, -1L)) # Level-3 factor 2's primary parent is the *flipped* level-2 factor 2 with a # raw positive edge (+0.9): the child must flip too (-1) so its primary edge # displays positive once ackwards() recomputes edges from the flipped # weights. Under the pre-M35 raw-edge rule it stayed +1 (the bug). Factors 1 # and 3 hang off the unflipped factor 1 with positive raw edges -> no flip. expect_equal(aligned$signs[[3]], c(1L, -1L, 1L)) # Loadings columns are flipped consistently with the recorded signs. expect_equal(aligned$loadings[[2]][, 2], -loadings_list[[2]][, 2]) expect_equal(aligned$loadings[[3]][, 2], -loadings_list[[3]][, 2]) expect_equal(aligned$loadings[[3]][, c(1, 3)], loadings_list[[3]][, c(1, 3)]) }) test_that("ackwards(): every primary edge is non-negative across engines", { skip_if_not_installed("psych") check_primary_nonneg <- function(x, label) { te <- x$edges$tidy prim <- te[!is.na(te$is_primary) & te$is_primary, , drop = FALSE] expect_gt(nrow(prim), 0L) expect_true(all(prim$r >= 0), label = paste("primary edges >= 0:", label)) } for (eng in c("pca", "efa")) { check_primary_nonneg( suppressWarnings(ackwards(sim16, k_max = 5, engine = eng)), paste("sim16", eng) ) check_primary_nonneg( suppressWarnings(ackwards(bfi25, k_max = 5, engine = eng)), paste("bfi25", eng) ) } skip_if_not_installed("lavaan") check_primary_nonneg( suppressWarnings(ackwards(.make_esem_data(), k_max = 3, engine = "esem")), "esem" ) }) test_that("ackwards() parent indices are always within bounds (regression: LSAP padding)", { skip_if_not_installed("psych") # This call previously triggered subscript OOB when clue was installed, # because LSAP padding rows returned indices > nrow(E) for non-square levels. x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5)) expect_s3_class(x, "ackwards") expect_equal(x$k_max, 5L) # Verify every lineage index is in bounds for its level for (ki in seq(2L, x$k_max)) { parents <- x$lineage[[as.character(ki)]] n_parents <- ki - 1L # nrow of edge matrix for level ki-1 → ki expect_true( all(parents >= 1L & parents <= n_parents), label = paste("lineage indices in bounds at level", ki) ) } })