Skip to content

test: Move the last file-local test fixtures into helpers, with self-describing names #2858

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
krlmlr wants to merge 2 commits into
base: main
Choose a base branch
from
Open

test: Move the last file-local test fixtures into helpers, with self-describing names #2858

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
bc635a3
test: Move the last file-local test fixtures into helpers
claude Aug 17, 2026
c5f510c
test: Give the shared test helpers self-describing names
claude Aug 17, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion tests/testthat/_snaps/other.md
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -26,7 +26,7 @@
# VS/ES require explicit conversion

Code
V(karate_oldstyle)
V(karate_oldstyle_graph())
Condition
Error in `warn_version()`:
! This graph was created by a now unsupported old igraph version.
Expand Down
303 changes: 198 additions & 105 deletions tests/testthat/helper-test-functions.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -17,51 +17,88 @@ standardize_eigen_signs <- function(x) {
})
}

order_by_magnitude <- function(x) {
order_eigenvalues_by_magnitude <- function(x) {
order(abs(x), sign(x), decreasing = TRUE)
}

sort_by_magnitude <- function(x) {
x[order_by_magnitude(x)]
sort_eigenvalues_by_magnitude <- function(x) {
x[order_eigenvalues_by_magnitude(x)]
}

# ---- test-operators.R -------------------------------------------------------

order_by_two_first_columns <- function(x) x[order(x[, 1], x[, 2]), ]
sort_edgelist_rows <- function(x) x[order(x[, 1], x[, 2]), ]

rn <- function(D) {
name_rows_by_edge_endpoints <- function(D) {
rownames(D) <- paste(D[, 1], D[, 2], sep = "-")
D
}

# Input/expected pairs for the unique()-on-vertex-sequence tests.
unique_tests <- list(
list(1:5, 1:5),
list(c(1, 1, 2:5), 1:5),
list(c(1, 1, 1, 1), 1),
list(c(1, 2, 2, 2), 1:2),
list(c(2, 2, 1, 1), 2:1),
list(c(1, 2, 1, 2), 1:2),
list(c(), c())
)
# Input/expected vertex-index pairs for the unique()-on-vertex-sequence tests:
# each element is `list(<indices to select>, <indices left after unique()>)`.
unique_vertex_seq_cases <- function() {
list(
list(1:5, 1:5),
list(c(1, 1, 2:5), 1:5),
list(c(1, 1, 1, 1), 1),
list(c(1, 2, 2, 2), 1:2),
list(c(2, 2, 1, 1), 2:1),
list(c(1, 2, 1, 2), 1:2),
list(c(), c())
)
}

# A fresh already-simple graph with two edge attributes, one of which the
# default combination list keeps and one of which it drops. Each caller needs
# its own: the C core's property cache lives in the graph object, and merely
# asking whether the graph is simple changes what simplifying it does.
simple_graph_with_edge_attrs <- function() {
g <- make_graph(c(1, 2, 2, 3), directed = FALSE)
E(g)$weight <- c(1, 2)
E(g)$foo <- c("a", "b")
g
}

# ---- test-glet.R ------------------------------------------------------------

sortgl <- function(x) {
# Shared fixture: the weighted overlapping-groups graph from the examples.
# Its `weight` edge attribute has four distinct threshold levels.
make_weighted_graphlet_graph <- function() {
D1 <- matrix(0, 5, 5)
D2 <- matrix(0, 5, 5)
D3 <- matrix(0, 5, 5)
D1[1:3, 1:3] <- 2
D2[3:5, 3:5] <- 3
D3[2:5, 2:5] <- 1
simplify(graph_from_adjacency_matrix(
D1 + D2 + D3,
mode = "undirected",
weighted = TRUE
))
}

# Canonicalise a graphlet_basis() result for comparison: sort the vertices
# within each clique, then the cliques by size (carrying their thresholds).
sort_graphlets_by_size <- function(x) {
cl <- lapply(x$cliques, sort)
n <- lengths(cl)
list(cliques = cl[order(n)], thresholds = x$thresholds[order(n)])
}

threshold.net <- function(graph, level) {
# The maximal cliques of the subgraph left after dropping every edge whose
# weight is below `level`, largest first. One thresholding step of
# graphlet_basis_reference() below.
max_cliques_above_weight <- function(graph, level) {
graph.t <- delete_edges(graph, which(E(graph)$weight < level))

clqt <- unvs(max_cliques(graph.t))
clqt <- lapply(clqt, sort)
clqt[order(lengths(clqt), decreasing = TRUE)]
}

graphlets.old <- function(graph) {
# Pure-R reference implementations of graphlet_basis() and graphlet_proj(),
# kept to cross-check the C results.
graphlet_basis_reference <- function(graph) {
if (!is_weighted(graph)) {
cli::cli_abort("Graph not weighted")
}
Expand All @@ -71,7 +108,7 @@ graphlets.old <- function(graph) {

## Do all thresholds
cl <- lapply(sort(unique(E(graph)$weight)), function(w) {
threshold.net(graph, w)
max_cliques_above_weight(graph, w)
})

## Put the cliques in one long list
Expand All @@ -89,7 +126,7 @@ graphlets.old <- function(graph) {
clf
}

graphlets.project.old <- function(graph, cliques, iter, Mu = NULL) {
graphlet_proj_reference <- function(graph, cliques, iter, Mu = NULL) {
if (!is_weighted(graph)) {
cli::cli_abort("Graph not weighted")
}
Expand Down Expand Up @@ -161,94 +198,150 @@ graphlets.project.old <- function(graph, cliques, iter, Mu = NULL) {
# that VS/ES require (and survive) an explicit upgrade. Renamed from the
# file-local `names`/`karate` to avoid shadowing base `names()` once sourced
# into the shared testthat environment.
karate_oldstyle_names <- c(
"Mr Hi", "Actor 2", "Actor 3", "Actor 4",
"Actor 5", "Actor 6", "Actor 7", "Actor 8", "Actor 9", "Actor 10",
"Actor 11", "Actor 12", "Actor 13", "Actor 14", "Actor 15", "Actor 16",
"Actor 17", "Actor 18", "Actor 19", "Actor 20", "Actor 21", "Actor 22",
"Actor 23", "Actor 24", "Actor 25", "Actor 26", "Actor 27", "Actor 28",
"Actor 29", "Actor 30", "Actor 31", "Actor 32", "Actor 33", "John A"
)

karate_oldstyle <- structure(
list(
34,
FALSE,
c(
1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 12,
13, 17, 19, 21, 31, 2, 3, 7, 13, 17, 19, 21, 30, 3, 7, 8, 9,
13, 27, 28, 32, 7, 12, 13, 6, 10, 6, 10, 16, 16, 30, 32, 33,
33, 33, 32, 33, 32, 33, 32, 33, 33, 32, 33, 32, 33, 25, 27, 29,
32, 33, 25, 27, 31, 31, 29, 33, 33, 31, 33, 32, 33, 32, 33, 32,
33, 33
),
c(
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,
1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 5,
5, 5, 6, 8, 8, 8, 9, 13, 14, 14, 15, 15, 18, 18, 19, 20, 20,
22, 22, 23, 23, 23, 23, 23, 24, 24, 24, 25, 26, 26, 27, 28, 28,
29, 29, 30, 30, 31, 31, 32
),
c(
0, 1, 16, 2, 17, 24, 3, 4, 5,
35, 37, 6, 18, 25, 32, 7, 26, 27, 8, 36, 38, 9, 10, 33, 11, 19,
28, 34, 39, 40, 12, 20, 13, 21, 14, 22, 57, 62, 29, 58, 63, 30,
59, 66, 23, 41, 15, 64, 65, 69, 31, 42, 46, 48, 50, 53, 55, 60,
71, 73, 75, 43, 44, 45, 47, 49, 51, 52, 54, 56, 61, 67, 68, 70,
72, 74, 76, 77
),
c(
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28,
29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44,
45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76,
77
),
c(
0, 0, 1, 3, 6, 7, 8, 11, 15, 17, 18, 21, 22, 24, 28, 28,
28, 30, 32, 32, 34, 34, 36, 36, 36, 36, 38, 38, 41, 42, 44, 46,
50, 61, 78
),
c(
0, 16, 24, 32, 35, 37, 40, 41, 41, 44, 45, 45,
45, 45, 46, 48, 50, 50, 50, 52, 53, 55, 55, 57, 62, 65, 66, 68,
69, 71, 73, 75, 77, 78, 78
),
karate_oldstyle_vertex_names <- function() {
c(
"Mr Hi", "Actor 2", "Actor 3", "Actor 4",
"Actor 5", "Actor 6", "Actor 7", "Actor 8", "Actor 9", "Actor 10",
"Actor 11", "Actor 12", "Actor 13", "Actor 14", "Actor 15", "Actor 16",
"Actor 17", "Actor 18", "Actor 19", "Actor 20", "Actor 21", "Actor 22",
"Actor 23", "Actor 24", "Actor 25", "Actor 26", "Actor 27", "Actor 28",
"Actor 29", "Actor 30", "Actor 31", "Actor 32", "Actor 33", "John A"
)
}

karate_oldstyle_graph <- function() {
structure(
list(
c(1, 0, 1),
structure(
list(
name = "Zachary's karate club network",
Citation = "Wayne W. Zachary. An Information Flow Model for Conflict and Fission in Small Groups. Journal of Anthropological Research Vol. 33, No. 4 452-473",
Author = "Wayne W. Zachary"
),
names = c("name", "Citation", "Author")
34,
FALSE,
c(
1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 12,
13, 17, 19, 21, 31, 2, 3, 7, 13, 17, 19, 21, 30, 3, 7, 8, 9,
13, 27, 28, 32, 7, 12, 13, 6, 10, 6, 10, 16, 16, 30, 32, 33,
33, 33, 32, 33, 32, 33, 32, 33, 33, 32, 33, 32, 33, 25, 27, 29,
32, 33, 25, 27, 31, 31, 29, 33, 33, 31, 33, 32, 33, 32, 33, 32,
33, 33
),
c(
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1,
1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 4, 4, 5,
5, 5, 6, 8, 8, 8, 9, 13, 14, 14, 15, 15, 18, 18, 19, 20, 20,
22, 22, 23, 23, 23, 23, 23, 24, 24, 24, 25, 26, 26, 27, 28, 28,
29, 29, 30, 30, 31, 31, 32
),
c(
0, 1, 16, 2, 17, 24, 3, 4, 5,
35, 37, 6, 18, 25, 32, 7, 26, 27, 8, 36, 38, 9, 10, 33, 11, 19,
28, 34, 39, 40, 12, 20, 13, 21, 14, 22, 57, 62, 29, 58, 63, 30,
59, 66, 23, 41, 15, 64, 65, 69, 31, 42, 46, 48, 50, 53, 55, 60,
71, 73, 75, 43, 44, 45, 47, 49, 51, 52, 54, 56, 61, 67, 68, 70,
72, 74, 76, 77
),
c(
0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12,
13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28,
29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44,
45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76,
77
),
c(
0, 0, 1, 3, 6, 7, 8, 11, 15, 17, 18, 21, 22, 24, 28, 28,
28, 30, 32, 32, 34, 34, 36, 36, 36, 36, 38, 38, 41, 42, 44, 46,
50, 61, 78
),
structure(
list(
Faction = c(
1, 1, 1, 1, 1, 1, 1, 1,
2, 2, 1, 1, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2
c(
0, 16, 24, 32, 35, 37, 40, 41, 41, 44, 45, 45,
45, 45, 46, 48, 50, 50, 50, 52, 53, 55, 55, 57, 62, 65, 66, 68,
69, 71, 73, 75, 77, 78, 78
),
list(
c(1, 0, 1),
structure(
list(
name = "Zachary's karate club network",
Citation = "Wayne W. Zachary. An Information Flow Model for Conflict and Fission in Small Groups. Journal of Anthropological Research Vol. 33, No. 4 452-473",
Author = "Wayne W. Zachary"
),
name = karate_oldstyle_names
names = c("name", "Citation", "Author")
),
names = c("Faction", "name")
),
structure(
list(
weight = c(
4,
5, 3, 3, 3, 3, 2, 2, 2, 3, 1, 3, 2, 2, 2, 2, 6, 3, 4, 5, 1, 2,
2, 2, 3, 4, 5, 1, 3, 2, 2, 2, 3, 3, 3, 2, 3, 5, 3, 3, 3, 3, 3,
4, 2, 3, 3, 2, 3, 4, 1, 2, 1, 3, 1, 2, 3, 5, 4, 3, 5, 4, 2, 3,
2, 7, 4, 2, 4, 2, 2, 4, 2, 3, 3, 4, 4, 5
)
structure(
list(
Faction = c(
1, 1, 1, 1, 1, 1, 1, 1,
2, 2, 1, 1, 1, 1, 2, 2, 1, 1, 2, 1, 2, 1, 2, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2
),
name = karate_oldstyle_vertex_names()
),
names = c("Faction", "name")
),
names = "weight"
structure(
list(
weight = c(
4,
5, 3, 3, 3, 3, 2, 2, 2, 3, 1, 3, 2, 2, 2, 2, 6, 3, 4, 5, 1, 2,
2, 2, 3, 4, 5, 1, 3, 2, 2, 2, 3, 3, 3, 2, 3, 5, 3, 3, 3, 3, 3,
4, 2, 3, 3, 2, 3, 4, 1, 2, 1, 3, 1, 2, 3, 5, 4, 3, 5, 4, 2, 3,
2, 7, 4, 2, 4, 2, 2, 4, 2, 3, 3, 4, 4, 5
)
),
names = "weight"
)
)
)
),
class = "igraph"
)
),
class = "igraph"
)
}

# ---- test-cliques.R ---------------------------------------------------------

# Shared fixture: a triangle plus a disjoint edge.
# The `weight` vertex attribute favors the edge,
# an explicit weight vector can flip the result to the triangle.
make_weighted_clique_graph <- function() {
g <- make_full_graph(3) %du% make_full_graph(2)
V(g)$weight <- c(1, 1, 1, 4, 4)
g
}

# ---- test-decomposition.R ---------------------------------------------------

# The first example graph from the Tarjan-Yannakakis paper.
tarjan_yannakakis_graph <- function() {
graph_from_literal(
A - B:C:I, B - A:C:D, C - A:B:E:H, D - B:E:F,
E - C:D:F:H, F - D:E:G, G - F:H, H - C:E:G:I,
I - A:H
)
}

# ---- test-generate-migrations.R ---------------------------------------------

# Source the ellipsis-migration generator into a fresh environment and return
# it. The generator only exists in a source checkout (tools/ is
# .Rbuildignore'd), so the caller is skipped when it is missing.
load_migration_generator <- function() {
generator <- testthat::test_path("..", "..", "tools", "generate-migrations.R")
skip_if_not(file.exists(generator), "tools/generate-migrations.R not found")
gen_env <- new.env()
sys.source(generator, envir = gen_env)
gen_env
}

# Write a throw-away registry file and return its path.
write_migration_registry <- function(dir, name, code) {
path <- file.path(dir, name)
writeLines(code, path)
path
}

# ---- test-hrg.R -------------------------------------------------------------

# A compact shared fixture: a tiny two-clique graph and one HRG fitted to it,
# reused by the consensus_tree() and predict_edges() blocks.
# Fitting a real HRG is the awkward part of constructing valid inputs there.
hrg_graph_and_fit <- function() {
g <- make_full_graph(4) + make_full_graph(4)
igraph_with_seed(1, list(graph = g, hrg = fit_hrg(g)))
}
10 changes: 2 additions & 8 deletions tests/testthat/test-cliques.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -462,14 +462,8 @@ test_that("max_cliques handles errors in callback", {

# ---- ellipsis migration: argument coverage ----------------------------

# Shared fixture: a triangle plus a disjoint edge.
# The `weight` vertex attribute favors the edge,
# an explicit weight vector can flip the result to the triangle.
make_weighted_clique_graph <- function() {
g <- make_full_graph(3) %du% make_full_graph(2)
V(g)$weight <- c(1, 1, 1, 4, 4)
g
}
# The `make_weighted_clique_graph()` fixture used below lives in
# helper-test-functions.R.

test_that("clique_size_counts() recovers legacy positional arguments", {
# `min`, `max` and `maximal` are exercised by name above.
Expand Down
Loading
Loading