test_that("ba_layout() returns a list with nodes and edges data frames", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4)) lay <- ba_layout(x) expect_type(lay, "list") expect_named(lay, c("nodes", "edges")) expect_s3_class(lay$nodes, "data.frame") expect_s3_class(lay$edges, "data.frame") }) test_that("ba_layout() nodes have correct structure and counts", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4)) lay <- ba_layout(x) nodes <- lay$nodes # Columns expect_true(all(c("id", "level", "x", "y", "label") %in% names(nodes))) # Total nodes: 1+2+3+4 = 10 expect_equal(nrow(nodes), 10L) # One node per level per factor for (k in 1:4) { expect_equal(sum(nodes$level == k), k, info = paste("level", k, "has", k, "nodes") ) } }) test_that("ba_layout() y positions equal -level", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) lay <- ba_layout(x) nodes <- lay$nodes expect_equal(nodes$y, -nodes$level) }) test_that("ba_layout() level-1 node is at x = 0", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) lay <- ba_layout(x) nodes <- lay$nodes expect_equal(nodes$x[nodes$level == 1], 0) }) test_that("ba_layout() respects min_sep between nodes at same level", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5)) for (sep in c(0.5, 1.0, 1.5)) { lay <- ba_layout(x, min_sep = sep) nodes <- lay$nodes for (k in 2:5) { xs <- sort(nodes$x[nodes$level == k]) diffs <- diff(xs) expect_true( all(diffs >= sep - 1e-9), info = paste("min_sep", sep, "at level", k) ) } } }) test_that("ba_layout() node IDs and labels match level labels", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) lay <- ba_layout(x) nodes <- lay$nodes expect_equal(nodes$id, nodes$label) # IDs follow m{k}f{j} scheme expect_true(all(grepl("^m[0-9]+f[0-9]+$", nodes$id))) }) test_that("ba_layout() errors on non-ackwards input", { expect_error(ba_layout(list()), "ackwards") }) test_that("ba_layout() places each parent at mean x of its primary children", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5)) lay <- ba_layout(x) nodes <- lay$nodes edges <- lay$edges nx <- stats::setNames(nodes$x, nodes$id) # For every adjacent level pair, compute the ideal parent position as the # simple mean of its primary children's x coordinates, and assert it agrees # with the actual parent x within tolerance (spreading can shift by up to # min_sep when siblings collide, but in the typical case they agree exactly). primary_edges <- edges[!is.na(edges$is_primary) & edges$is_primary, ] for (parent_id in unique(primary_edges$from)) { child_ids <- primary_edges$to[primary_edges$from == parent_id] ideal_x <- mean(nx[child_ids]) actual_x <- nx[[parent_id]] # Alignment is exact when no spreading is needed; after spreading it may # differ, so assert within 1 * min_sep (default). expect_lte( abs(actual_x - ideal_x), 1.0 + 1e-9, label = paste(parent_id, "aligned to primary children") ) } # Specifically verify single-child parents are directly above their child # (before any spreading, diff should be 0; after spreading can be up to min_sep). single_child <- names(which(table(primary_edges$from) == 1)) for (parent_id in single_child) { child_id <- primary_edges$to[primary_edges$from == parent_id] expect_equal( nx[[parent_id]], nx[[child_id]], tolerance = 1.0 + 1e-9, label = paste(parent_id, "directly above sole primary child", child_id) ) } }) test_that(".spread_positions() enforces min_sep, preserves order, and recentres", { # Access internal function from the package namespace spread <- ackwards:::.spread_positions # Colliding input: three positions bunched at 0 bary <- c(0, 0, 0) out <- spread(bary, min_sep = 1.0) expect_equal(length(out), 3L) # All gaps should be >= min_sep expect_true(all(diff(sort(out)) >= 1.0 - 1e-9)) # Group should be re-centred around original mean (0) expect_equal(mean(out), 0, tolerance = 1e-9) # Already-separated input: should be unchanged (no spreading needed) bary2 <- c(-2, 0, 2) out2 <- spread(bary2, min_sep = 1.0) expect_equal(out2, bary2, tolerance = 1e-9) # Order preservation: largest bary stays largest bary3 <- c(1, 3, 2) out3 <- spread(bary3, min_sep = 0.5) expect_equal(order(out3), order(bary3)) # Single element: returned as-is expect_equal(spread(5, min_sep = 1.0), 5) }) test_that("autoplot.ackwards() returns a ggplot object", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x) expect_s3_class(p, "ggplot") }) test_that("autoplot(x) dispatches correctly without library(ggplot2)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) # The package defines its own autoplot generic so this works without ggplot2 attached p <- autoplot(x) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() respects cut_show", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_no_error(ggplot2::autoplot(x, cut_show = 0.1)) expect_no_error(ggplot2::autoplot(x, cut_show = 0.5)) }) test_that("autoplot.ackwards() deprecates cut_strong (warns, no effect)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_warning(ggplot2::autoplot(x, cut_strong = 0.4), "deprecated") }) test_that("autoplot.ackwards() validates cut_show (M42/m8)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_error(ggplot2::autoplot(x, cut_show = 5), "\\[0, 1\\]") expect_error(ggplot2::autoplot(x, cut_show = c(0.3, 0.5)), "\\[0, 1\\]") expect_error(ggplot2::autoplot(x, cut_show = NA), "\\[0, 1\\]") }) test_that("autoplot.ackwards() warns when cut_show hides all edges", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) # cut_show = 1 (the legal maximum since M42/m8 validation) hides every edge # here: no between-level correlation in these data reaches exactly 1.0 expect_warning(ggplot2::autoplot(x, cut_show = 1), "No edges") }) test_that("autoplot.ackwards() warns when min_sep < node_width", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_warning(ggplot2::autoplot(x, min_sep = 0.3, node_width = 0.8), "overlap") }) test_that("plot.ackwards() runs without error and returns x invisibly", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_no_error(plot(x)) expect_invisible(plot(x)) }) test_that("autoplot.ackwards() renders skip-level edges with pairs='all'", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) p <- expect_no_error(ggplot2::autoplot(x)) expect_s3_class(p, "ggplot") # show_skip defaults to TRUE when meta$pairs == "all" expect_no_error(ggplot2::autoplot(x, show_skip = FALSE)) expect_no_error(ggplot2::autoplot(x, show_skip = TRUE, curvature = 0.3)) }) test_that("autoplot.ackwards() fades pruned nodes", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") set.seed(42) n <- 500 g <- rnorm(n) s1 <- rnorm(n) s2 <- rnorm(n) data <- data.frame( x1 = 0.9 * g + 0.2 * s1 + rnorm(n, sd = 0.05), x2 = 0.9 * g + 0.2 * s1 + rnorm(n, sd = 0.05), x3 = 0.9 * g + 0.2 * s1 + rnorm(n, sd = 0.05), x4 = 0.9 * g + 0.2 * s2 + rnorm(n, sd = 0.05), x5 = 0.9 * g + 0.2 * s2 + rnorm(n, sd = 0.05), x6 = 0.9 * g + 0.2 * s2 + rnorm(n, sd = 0.05) ) x <- suppressWarnings(suppressMessages( ackwards(data, k_max = 4) |> prune("redundant", redundancy_r = 0.9) )) p <- expect_no_error(ggplot2::autoplot(x)) expect_s3_class(p, "ggplot") # Custom prune colour expect_no_error(ggplot2::autoplot(x, color_pruned = "pink")) }) test_that(".drop_pruned_nodes() bridges fully-pruned levels on pairs='adjacent' objects (M42/M1)", { skip_if_not_installed("psych") d <- na.omit(ackwards::bfi25) # Default pairs = "adjacent": the stored tidy edges hold no skip-level rows. x <- cached(ackwards(d, k_max = 4)) xp <- prune(x, manual = c("m2f1", "m2f2")) # level 2 fully pruned lay <- ba_layout(xp) dp <- ackwards:::.drop_pruned_nodes(xp, lay$nodes) # Pre-M42 regression: kept level-3 nodes had no candidate ancestor edges # (their only stored parents were the pruned level-2 nodes; no 1:3 skip # edges existed in the adjacent-only tidy table). Every kept node below the # apex must now have exactly one incoming edge, bridging the pruned level. kept_below_apex <- dp$nodes$id[dp$nodes$level > 1L] expect_setequal(dp$edges$to, kept_below_apex) # The level-3 bridges must come from level 1 (level 2 is gone). lvl3_edges <- dp$edges[dp$edges$level_to == 3L, , drop = FALSE] expect_true(nrow(lvl3_edges) == 3L && all(lvl3_edges$level_from == 1L)) # And the reduced edge set must be identical whether the object was fit # with pairs = "adjacent" or pairs = "all" (edges are recomputed fresh). x_all <- cached(ackwards(d, k_max = 4, pairs = "all")) xp_all <- prune(x_all, manual = c("m2f1", "m2f2")) dp_all <- ackwards:::.drop_pruned_nodes(xp_all, ba_layout(xp_all)$nodes) cols <- c("from", "to", "level_from", "level_to", "r") expect_equal(dp$edges[, cols], dp_all$edges[, cols], tolerance = 1e-12) }) test_that("autoplot.ackwards() handles objects with prune=NULL (no pruning)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_null(x$prune) p <- expect_no_error(ggplot2::autoplot(x)) expect_s3_class(p, "ggplot") }) # --- Wave 1 (M8): show_r, mono, show_level_labels, node_labels, primary_only --- test_that("autoplot.ackwards() show_r=TRUE labels edges without error", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, show_r = TRUE)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() show_r=TRUE respects r_digits", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, show_r = TRUE, r_digits = 3L)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() show_r=TRUE works with pairs='all'", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) p <- expect_no_error(ggplot2::autoplot(x, show_r = TRUE)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() mono=TRUE returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, mono = TRUE)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() mono=TRUE + show_r=TRUE composes without error", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, mono = TRUE, show_r = TRUE)) expect_s3_class(p, "ggplot") }) # --- M35: configurable encodings (sign_by / magnitude_by / colour aliases) ------ .ba_has_scale <- function(p, aesthetic) { any(vapply( p$scales$scales, function(s) aesthetic %in% s$aesthetics, logical(1) )) } .ba_get_scale <- function(p, aesthetic) { for (s in p$scales$scales) if (aesthetic %in% s$aesthetics) { return(s) } NULL } test_that("sign_by selects which aesthetic encodes edge sign", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) # default "color": colour encodes sign, linetype does not p <- ggplot2::autoplot(x) expect_true(.ba_has_scale(p, "colour")) expect_false(.ba_has_scale(p, "linetype")) # "linetype": linetype encodes sign, colour does not p <- ggplot2::autoplot(x, sign_by = "linetype") expect_true(.ba_has_scale(p, "linetype")) expect_false(.ba_has_scale(p, "colour")) # "both": colour AND linetype, merged into one legend. ggplot2 merges guides # that share a scale name, so both scales must be titled "Direction". p <- ggplot2::autoplot(x, sign_by = "both") expect_true(.ba_has_scale(p, "colour")) expect_true(.ba_has_scale(p, "linetype")) expect_identical(.ba_get_scale(p, "colour")$name, "Direction") expect_identical(.ba_get_scale(p, "linetype")$name, "Direction") # "none": neither encodes sign p <- ggplot2::autoplot(x, sign_by = "none") expect_false(.ba_has_scale(p, "colour")) expect_false(.ba_has_scale(p, "linetype")) }) test_that("magnitude_by / edge_linewidth control the |r| linewidth scale", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_true(.ba_has_scale(ggplot2::autoplot(x), "linewidth")) expect_false(.ba_has_scale(ggplot2::autoplot(x, magnitude_by = "none"), "linewidth")) # a numeric edge_linewidth also forces constant width (no scale) expect_false(.ba_has_scale(ggplot2::autoplot(x, edge_linewidth = 0.6), "linewidth")) }) test_that("colour_* aliases override the color_* arguments", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) # colour_pos / colour_neg feed the Direction colour scale (break order # positive, negative) -- readable even when no negative edge is drawn. p <- ggplot2::autoplot(x, colour_pos = "darkgreen", colour_neg = "darkorange") expect_equal( unname(.ba_get_scale(p, "colour")$palette(2L)), c("darkgreen", "darkorange") ) # colour_edge sets the single edge colour when sign is not colour-encoded. pe <- ggplot2::autoplot(x, sign_by = "linetype", colour_edge = "darkgreen") expect_true(all(ggplot2::ggplot_build(pe)$data[[1]]$colour == "darkgreen")) # colour_pruned sets the pruned-node fill (use manual pruning for determinism). xp <- prune(x, manual = "m4f4") pp <- ggplot2::autoplot(xp, colour_pruned = "pink") tile_fill <- unlist(lapply( ggplot2::ggplot_build(pp)$data, function(l) if ("fill" %in% names(l)) l$fill )) expect_true("pink" %in% tile_fill) }) test_that("sign_by='none' + magnitude_by='none' renders with no encoding scales", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, sign_by = "none", magnitude_by = "none") expect_s3_class(p, "ggplot") expect_false(.ba_has_scale(p, "colour")) expect_false(.ba_has_scale(p, "linetype")) expect_false(.ba_has_scale(p, "linewidth")) expect_s3_class(ggplot2::ggplot_build(p), "ggplot_built") }) test_that("mono=TRUE is equivalent to sign_by='linetype' with black edges", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, mono = TRUE) expect_true(.ba_has_scale(p, "linetype")) expect_false(.ba_has_scale(p, "colour")) edge_colours <- ggplot2::ggplot_build(p)$data[[1]]$colour expect_true(all(edge_colours == "black")) }) test_that("direction='horizontal' transposes the level axis to x", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4)) tile_layer <- function(p) { d <- ggplot2::ggplot_build(p)$data idx <- which(vapply( d, function(l) all(c("fill", "width") %in% names(l)), logical(1) ))[[1L]] d[[idx]] } v <- tile_layer(ggplot2::autoplot(x, direction = "vertical")) h <- tile_layer(ggplot2::autoplot(x, direction = "horizontal")) # Vertical: levels run down the y-axis (level 1 at top, y = -1 is the max). expect_equal(max(v$y), -1) # Horizontal: levels run along the x-axis (level 1 at left, x = 1 is the min). expect_equal(min(h$x), 1) # The two layouts are transposes of one another. expect_equal(sort(range(v$x)), sort(range(h$y))) }) test_that("direction='horizontal' composes with skip, mono, and drop_pruned", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") xa <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) expect_s3_class(ggplot2::autoplot(xa, direction = "horizontal", show_skip = TRUE), "ggplot") expect_s3_class(ggplot2::autoplot(xa, direction = "horizontal", mono = TRUE), "ggplot") # show_r places perpendicular-offset labels; the offset math is orientation- # agnostic, so it must compose with the transposed layout. expect_s3_class(ggplot2::autoplot(xa, direction = "horizontal", show_r = TRUE), "ggplot") xp <- prune(xa, "redundant") expect_s3_class( suppressWarnings(ggplot2::autoplot(xp, direction = "horizontal", drop_pruned = TRUE)), "ggplot" ) }) test_that("autoplot.ackwards() show_level_labels=TRUE (default) returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, show_level_labels = TRUE)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() show_level_labels=FALSE omits labels without error", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, show_level_labels = FALSE)) expect_s3_class(p, "ggplot") }) # --- M40: fully-pruned level axis labels rendered in italic ------------------- # Locate the level-axis-label GeomText layer (labels like "3 factors"), as # opposed to the node-label GeomText layer (labels like "m3f1"). .level_label_data <- function(p) { gt_idx <- which(vapply( p$layers, function(l) inherits(l$geom, "GeomText"), logical(1L) )) for (i in gt_idx) { ld <- ggplot2::layer_data(p, i) if (any(grepl("factor", ld$label))) { return(ld) } } NULL } test_that(".fully_pruned_levels() detects a wholly-pruned level, not partial ones", { skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4)) # No pruning annotations -> integer(0) expect_identical(.fully_pruned_levels(x), integer(0)) # Prune every factor at level 4 -> level 4 fully pruned xp <- prune(x, manual = c("m4f1", "m4f2", "m4f3", "m4f4")) expect_identical(.fully_pruned_levels(xp), 4L) # Prune only some of level 4 -> not fully pruned xpart <- prune(x, manual = c("m4f1", "m4f2")) expect_identical(.fully_pruned_levels(xpart), integer(0)) }) test_that("autoplot() italicises a fully-pruned level's axis label (both directions)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4)) xp <- prune(x, manual = c("m4f1", "m4f2", "m4f3", "m4f4")) for (dir in c("vertical", "horizontal")) { p <- ggplot2::autoplot(xp, direction = dir) ld <- .level_label_data(p) expect_false(is.null(ld)) italic <- ld$label[ld$fontface == "italic"] plain <- ld$label[ld$fontface == "plain"] expect_identical(italic, "4 factors") expect_true(all(c("1 factor", "2 factors", "3 factors") %in% plain)) } }) test_that("autoplot() renders all level labels plain when nothing is fully pruned", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") # Un-pruned object x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4)) ld <- .level_label_data(ggplot2::autoplot(x)) expect_false(is.null(ld)) expect_true(all(ld$fontface == "plain")) # Partially-pruned level stays plain xpart <- prune(x, manual = c("m4f1", "m4f2")) ld2 <- .level_label_data(ggplot2::autoplot(xpart)) expect_true(all(ld2$fontface == "plain")) }) test_that("autoplot() italicises levels fully pruned by the auto 'redundant' rule", { skip_if_not_installed("ggplot2") # sim16's built-in redundant chains (M33) fully prune levels 3 and 4 at # k_max = 5 with the |r| >= 0.9 threshold -- an *auto*-rule full prune (not # manual), and two fully-pruned levels at once. Deterministic for this dataset. suppressWarnings(suppressMessages( xr <- cached(ackwards(sim16, k_max = 5) |> prune("redundant", redundancy_r = 0.9)) )) expect_identical(.fully_pruned_levels(xr), c(3L, 4L)) ld <- .level_label_data(ggplot2::autoplot(xr)) expect_false(is.null(ld)) expect_setequal(ld$label[ld$fontface == "italic"], c("3 factors", "4 factors")) expect_setequal(ld$label[ld$fontface == "plain"], c("1 factor", "2 factors", "5 factors")) }) test_that("autoplot.ackwards() node_labels applies custom labels", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, node_labels = c(m3f1 = "Alpha"))) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() node_labels warns for unknown factor IDs", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_warning( ggplot2::autoplot(x, node_labels = c(m99f1 = "Ghost")), "match no factor ID" ) }) test_that("autoplot.ackwards() primary_only=TRUE returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, primary_only = TRUE)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() primary_only=TRUE hides skip arcs", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) # primary_only filters to is_primary==TRUE; skip edges are never primary p <- expect_no_error(ggplot2::autoplot(x, primary_only = TRUE)) expect_s3_class(p, "ggplot") }) test_that("autoplot.ackwards() all Wave-1 args compose without error", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) p <- expect_no_error(ggplot2::autoplot( x, show_r = TRUE, r_digits = 2L, mono = TRUE, show_level_labels = TRUE, level_label_size = 3, node_labels = c(m4f1 = "General"), primary_only = FALSE )) expect_s3_class(p, "ggplot") }) # --- Wave 2 (M8): drop_pruned + compress_levels + .drop_pruned_nodes() ------ test_that("drop_pruned=TRUE errors without pruning annotations", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_null(x$prune) expect_error(ggplot2::autoplot(x, drop_pruned = TRUE), "prune") }) test_that("drop_pruned=TRUE returns a ggplot for a pruned object", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) p <- expect_no_error(ggplot2::autoplot(x, drop_pruned = TRUE)) expect_s3_class(p, "ggplot") }) test_that("drop_pruned=TRUE: show_r defaults to FALSE (decoupled from drop_pruned)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) # show_r defaults FALSE; no GeomLabel layers should appear p <- expect_no_error(ggplot2::autoplot(x, drop_pruned = TRUE)) expect_s3_class(p, "ggplot") label_layers <- Filter(function(l) inherits(l$geom, "GeomLabel"), p$layers) expect_equal(length(label_layers), 0L) }) test_that("show_r=TRUE produces GeomLabel layers", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, show_r = TRUE)) label_layers <- Filter(function(l) inherits(l$geom, "GeomLabel"), p$layers) expect_true(length(label_layers) > 0L) }) test_that("drop_pruned=TRUE + show_r=FALSE produces no GeomLabel layers", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) p <- expect_no_error(ggplot2::autoplot(x, drop_pruned = TRUE, show_r = FALSE)) expect_s3_class(p, "ggplot") label_layers <- Filter(function(l) inherits(l$geom, "GeomLabel"), p$layers) expect_equal(length(label_layers), 0L) }) test_that("show_r=TRUE label text is APA-formatted (no leading zero, padded decimals)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, show_r = TRUE, r_digits = 2L) idx <- which(vapply(p$layers, function(l) inherits(l$geom, "GeomLabel"), logical(1L))) ld <- ggplot2::layer_data(p, idx) # APA convention: no label starts with "0." or "-0." expect_false(any(grepl("^0\\.", ld$label))) expect_false(any(grepl("^-0\\.", ld$label))) # Labels that contain a decimal point have exactly r_digits digits after it has_dot <- grepl("\\.", ld$label) if (any(has_dot)) { decimal_parts <- sub("^[^.]*\\.", "", ld$label[has_dot]) expect_true(all(nchar(decimal_parts) == 2L)) } }) test_that("show_r=TRUE places labels offset from the edge midpoint", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, show_r = TRUE) ld <- ggplot2::layer_data(p, which(vapply(p$layers, function(l) { inherits(l$geom, "GeomLabel") }, logical(1L)))) # Recover the segment layers for midpoint comparison seg_layers <- which(vapply(p$layers, function(l) inherits(l$geom, "GeomSegment"), logical(1L))) sd <- ggplot2::layer_data(p, seg_layers[[1L]]) mid_x <- (sd$x + sd$xend) / 2 mid_y <- (sd$y + sd$yend) / 2 # Labels must not coincide with the raw midpoints — perpendicular nudge moved them expect_false(all(abs(ld$x - mid_x) < 1e-9 & abs(ld$y - mid_y) < 1e-9)) }) test_that("r_label_size arg changes the geom_label size", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p_small <- ggplot2::autoplot(x, show_r = TRUE, r_label_size = 1.5) p_large <- ggplot2::autoplot(x, show_r = TRUE, r_label_size = 4.0) get_label_size <- function(p) { idx <- which(vapply(p$layers, function(l) inherits(l$geom, "GeomLabel"), logical(1L))) p$layers[[idx]]$aes_params$size } expect_equal(get_label_size(p_small), 1.5) expect_equal(get_label_size(p_large), 4.0) }) test_that("drop_pruned=TRUE + compress_levels=TRUE returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) p <- expect_no_error(ggplot2::autoplot(x, drop_pruned = TRUE, compress_levels = TRUE )) expect_s3_class(p, "ggplot") }) test_that("drop_pruned=TRUE + mono=TRUE returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) p <- expect_no_error(ggplot2::autoplot(x, drop_pruned = TRUE, mono = TRUE)) expect_s3_class(p, "ggplot") }) test_that("drop_pruned=TRUE + node_labels applies labels", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) p <- expect_no_error(ggplot2::autoplot(x, drop_pruned = TRUE, node_labels = c(m5f1 = "Neuroticism") )) expect_s3_class(p, "ggplot") }) test_that("drop_pruned degenerate case warns and returns node-only ggplot", { skip_if_not_installed("ggplot2") # k=2 with high-g data: m1f1 is redundant with m2f1 (chain reaches k=2), # leaving only level-2 nodes — n_kept_levels = 1 -> degenerate set.seed(42) n <- 500 g <- rnorm(n) d <- data.frame( x1 = 0.9 * g + rnorm(n, sd = 0.05), x2 = 0.9 * g + rnorm(n, sd = 0.05), x3 = 0.9 * g + rnorm(n, sd = 0.05), x4 = 0.9 * g + rnorm(n, sd = 0.05), x5 = 0.9 * g + rnorm(n, sd = 0.05), x6 = 0.9 * g + rnorm(n, sd = 0.05) ) x <- suppressMessages(ackwards(d, k_max = 2) |> prune("redundant", redundancy_r = 0.7)) # Verify the test fixture: m1f1 should be pruned, only level 2 keeps nodes expect_equal( unique(x$prune$nodes$level[!x$prune$nodes$pruned]), 2L ) expect_warning(ggplot2::autoplot(x, drop_pruned = TRUE), "node-only") p <- suppressWarnings(ggplot2::autoplot(x, drop_pruned = TRUE)) expect_s3_class(p, "ggplot") }) test_that(".drop_pruned_nodes() returns kept-only nodes and reduced edges", { suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) lay <- ba_layout(x) dp <- ackwards:::.drop_pruned_nodes(x, lay$nodes) kept <- x$prune$nodes$id[!x$prune$nodes$pruned] # All returned nodes are kept expect_true(all(dp$nodes$id %in% kept)) expect_equal(nrow(dp$nodes), length(kept)) # Each edge connects two kept nodes if (nrow(dp$edges) > 0L) { expect_true(all(dp$edges$from %in% kept)) expect_true(all(dp$edges$to %in% kept)) # Each "to" node appears at most once (one primary parent per node) expect_equal(length(unique(dp$edges$to)), nrow(dp$edges)) # Parent is always shallower than child expect_true(all(dp$edges$level_from < dp$edges$level_to)) } }) test_that(".drop_pruned_nodes() compress_levels re-indexes y", { suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) lay <- ba_layout(x) dp_gap <- ackwards:::.drop_pruned_nodes(x, lay$nodes, compress_levels = FALSE) dp_comp <- ackwards:::.drop_pruned_nodes(x, lay$nodes, compress_levels = TRUE) # Gap-preserved: y == -level for all kept nodes expect_equal(dp_gap$nodes$y, -dp_gap$nodes$level) # Compressed: y values are consecutive integers starting at -1 kept_levels <- sort(unique(dp_comp$nodes$level)) if (length(kept_levels) > 1L) { expected_y <- -match(dp_comp$nodes$level, kept_levels) expect_equal(dp_comp$nodes$y, expected_y) } }) test_that("drop_pruned=TRUE warns when no nodes are pruned (artifact-only)", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3) |> prune("artifact")) )) expect_true(!any(x$prune$nodes$pruned)) expect_warning( ggplot2::autoplot(x, drop_pruned = TRUE), "no nodes are flagged" ) }) test_that("drop_pruned=TRUE warns when cut_show removes all reduced edges", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) # cut_show = 1 is the legal maximum since M42/m8 validation; no reduced # edge in these data reaches exactly 1.0, so all are hidden expect_warning( ggplot2::autoplot(x, drop_pruned = TRUE, cut_show = 1), "No edges" ) }) test_that("node_labels as unnamed vector silently does nothing", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) # Unnamed character: names() is NULL; no warning, no crash p <- expect_no_error(ggplot2::autoplot(x, node_labels = c("Alpha", "Beta"))) expect_s3_class(p, "ggplot") }) test_that("compress_levels=TRUE without drop_pruned is silently ignored", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, compress_levels = TRUE)) expect_s3_class(p, "ggplot") }) test_that("drop_pruned=TRUE ignores primary_only and show_skip", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95) )) # These flags should be silently ignored — no error p <- expect_no_error(ggplot2::autoplot( x, drop_pruned = TRUE, primary_only = TRUE, show_skip = TRUE )) expect_s3_class(p, "ggplot") }) # --- Wave 1 (M9): show_arrows, edge_linewidth, legend ------------------------- test_that("show_arrows=FALSE returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, show_arrows = FALSE)) expect_s3_class(p, "ggplot") }) test_that("show_arrows=FALSE sets arrow=NULL on segment layers", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, show_arrows = FALSE) seg_layers <- Filter(function(l) inherits(l$geom, "GeomSegment"), p$layers) expect_true(length(seg_layers) > 0L) for (l in seg_layers) expect_null(l$geom_params$arrow) }) test_that("show_arrows=TRUE (default) retains arrowheads on segment layers", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, show_arrows = TRUE) seg_layers <- Filter(function(l) inherits(l$geom, "GeomSegment"), p$layers) for (l in seg_layers) expect_s3_class(l$geom_params$arrow, "arrow") }) test_that("show_arrows=FALSE removes arrowheads from curved arcs too", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) p <- ggplot2::autoplot(x, show_arrows = FALSE) expect_s3_class(p, "ggplot") cur_layers <- Filter(function(l) inherits(l$geom, "GeomCurve"), p$layers) for (l in cur_layers) expect_null(l$geom_params$arrow) }) test_that("edge_linewidth numeric returns a ggplot", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, edge_linewidth = 0.6)) expect_s3_class(p, "ggplot") }) test_that("edge_linewidth numeric drops the linewidth scale", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) has_lw_scale <- function(p) { any(vapply(p$scales$scales, function(s) "linewidth" %in% s$aesthetics, logical(1L))) } expect_true(has_lw_scale(ggplot2::autoplot(x))) expect_false(has_lw_scale(ggplot2::autoplot(x, edge_linewidth = 0.6))) }) test_that("edge_linewidth=NULL (default) retains the linewidth scale", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) has_lw_scale <- function(p) { any(vapply(p$scales$scales, function(s) "linewidth" %in% s$aesthetics, logical(1L))) } expect_true(has_lw_scale(ggplot2::autoplot(x, edge_linewidth = NULL))) }) test_that("legend=FALSE returns a ggplot with legend.position='none'", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot(x, legend = FALSE)) expect_s3_class(p, "ggplot") expect_equal(p$theme$legend.position, "none") }) test_that("legend=TRUE (default) does not suppress the legend", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, legend = TRUE) expect_false(identical(p$theme$legend.position, "none")) }) test_that("Forbes-style composition: drop_pruned+black+fixed lw+no arrows+no legend", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") suppressWarnings(suppressMessages( x <- cached(ackwards(psych::bfi[, 1:25], k_max = 5) |> prune("redundant", redundancy_r = 0.95)) )) p <- expect_no_error(ggplot2::autoplot( x, drop_pruned = TRUE, color_pos = "black", color_neg = "black", edge_linewidth = 0.6, show_arrows = FALSE, legend = FALSE )) expect_s3_class(p, "ggplot") expect_equal(p$theme$legend.position, "none") }) test_that("M9 args compose with mono=TRUE without error", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- expect_no_error(ggplot2::autoplot( x, mono = TRUE, show_arrows = FALSE, edge_linewidth = 0.5, legend = FALSE )) expect_s3_class(p, "ggplot") }) test_that("all M9 args compose with all M8 args without error", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 4, pairs = "all")) p <- expect_no_error(ggplot2::autoplot( x, show_r = TRUE, r_digits = 2L, show_level_labels = TRUE, node_labels = c(m4f1 = "General"), primary_only = FALSE, show_arrows = FALSE, edge_linewidth = 0.5, legend = FALSE )) expect_s3_class(p, "ggplot") }) test_that("edge_linewidth numeric stores constant linewidth on segment layers", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, edge_linewidth = 0.6) seg_layers <- Filter(function(l) inherits(l$geom, "GeomSegment"), p$layers) expect_true(length(seg_layers) > 0L) # linewidth is a ggplot2 aesthetic so constant values land in $aes_params for (l in seg_layers) expect_equal(l$aes_params$linewidth, 0.6) }) test_that("edge_linewidth invalid values error clearly", { skip_if_not_installed("psych") skip_if_not_installed("ggplot2") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) expect_error(ggplot2::autoplot(x, edge_linewidth = "thick"), "edge_linewidth") expect_error(ggplot2::autoplot(x, edge_linewidth = -0.5), "edge_linewidth") expect_error(ggplot2::autoplot(x, edge_linewidth = c(0.5, 0.6)), "edge_linewidth") }) test_that("legend=FALSE is honoured on the degenerate drop_pruned plot", { skip_if_not_installed("ggplot2") set.seed(42) n <- 500 g <- rnorm(n) d <- data.frame( x1 = 0.9 * g + rnorm(n, sd = 0.05), x2 = 0.9 * g + rnorm(n, sd = 0.05), x3 = 0.9 * g + rnorm(n, sd = 0.05), x4 = 0.9 * g + rnorm(n, sd = 0.05), x5 = 0.9 * g + rnorm(n, sd = 0.05), x6 = 0.9 * g + rnorm(n, sd = 0.05) ) x <- suppressMessages(ackwards(d, k_max = 2) |> prune("redundant", redundancy_r = 0.7)) p <- suppressWarnings(ggplot2::autoplot(x, drop_pruned = TRUE, legend = FALSE)) expect_s3_class(p, "ggplot") expect_equal(p$theme$legend.position, "none") }) # ── M27: autoplot(x, what = "fit") ──────────────────────────────────────────── test_that("autoplot(x, what='fit') returns ggplot for EFA object", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3, engine = "efa")) p <- ggplot2::autoplot(x, what = "fit") expect_s3_class(p, "ggplot") }) test_that("autoplot(x, what='fit') draws Hu & Bentler threshold reference lines", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3, engine = "efa")) p <- ggplot2::autoplot(x, what = "fit") # The cutoff reference lines are a geom_hline layer (retained .fit_cutoffs()). has_hline <- vapply( p$layers, function(l) inherits(l$geom, "GeomHline"), logical(1L) ) expect_true(any(has_hline)) # The reference y-intercepts are the EFA-charted thresholds (TLI .95, RMSEA .06). hline_layer <- p$layers[[which(has_hline)[1L]]] expect_setequal(hline_layer$data$yintercept, c(0.95, 0.06)) }) test_that("autoplot(x, what='fit') returns ggplot for ESEM object", { skip_if_not_installed("ggplot2") skip_if_not_installed("lavaan") d <- data.frame(matrix(rnorm(300 * 6), 300, 6)) x <- cached(ackwards(d, k_max = 3, engine = "esem")) p <- ggplot2::autoplot(x, what = "fit") expect_s3_class(p, "ggplot") }) test_that("fit-plot caption names only the plotted indices (M42/m10)", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") # EFA panels show TLI/RMSEA only; the caption must not list CFI/SRMR cutoffs. suppressWarnings( x_efa <- cached(ackwards(psych::bfi[, 1:25], k_max = 3, engine = "efa")) ) cap_efa <- ggplot2::autoplot(x_efa, what = "fit")$labels$caption expect_true(grepl("TLI", cap_efa) && grepl("RMSEA", cap_efa)) expect_false(grepl("CFI", cap_efa) || grepl("SRMR", cap_efa)) }) test_that("autoplot(x, what='fit') returns ggplot with informative message for PCA", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p <- ggplot2::autoplot(x, what = "fit") expect_s3_class(p, "ggplot") }) test_that("autoplot(x, what='hierarchy') is unchanged from default", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3)) p_default <- ggplot2::autoplot(x) p_explicit <- ggplot2::autoplot(x, what = "hierarchy") # Both should be ggplots; data-level equality is already tested elsewhere expect_s3_class(p_default, "ggplot") expect_s3_class(p_explicit, "ggplot") }) test_that("autoplot(what='fit') returns empty plot when no kept indices present", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3, engine = "efa")) # Strip the EFA fit down to indices the plot does not chart (chi/dof only), # forcing the "No fit indices available" branch. for (ki in names(x$levels)) { x$levels[[ki]]$fit <- c(chi = 1, dof = 1) } p <- ggplot2::autoplot(x, what = "fit") expect_s3_class(p, "ggplot") }) test_that("autoplot(what='fit') panel titles are engine-aware (EFA: no CFI/SRMR)", { skip_if_not_installed("ggplot2") skip_if_not_installed("psych") x <- cached(ackwards(psych::bfi[, 1:25], k_max = 3, engine = "efa")) p <- ggplot2::autoplot(x, what = "fit") panels <- as.character(unique(p$data$panel)) # EFA charts TLI and RMSEA only; titles must not advertise CFI or SRMR. expect_false(any(grepl("CFI", panels))) expect_false(any(grepl("SRMR", panels))) expect_true(any(grepl("TLI", panels))) expect_true(any(grepl("RMSEA", panels))) })