Nothing
# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────── Queries tests ─────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
# ───────────────────────────── caugi type check ───────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("is_caugi works", {
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "PDAG")
expect_true(is_caugi(cg))
not_cg <- list(a = 1, b = 2)
expect_false(is_caugi(not_cg))
expect_error(is_caugi(not_cg, throw_error = TRUE))
})
# ──────────────────────────────────────────────────────────────────────────────
# ──────────────────────────────── Acyclicity ──────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("acyclicity check works", {
cg <- caugi(A %-->% B, B %-->% C, C %-->% A)
expect_false(is_acyclic(cg))
cg <- cg |> set_edges(C %---% A)
expect_true(is_acyclic(cg))
})
test_that("is_acyclic forces check when requested", {
cg <- caugi(A %-->% B, B %-->% C, C %-->% D, class = "DAG")
expect_true(is_acyclic(cg))
expect_true(is_acyclic(cg, force_check = TRUE))
})
test_that("is_acyclic fast path handles MPDAG class", {
cg <- caugi(
A %---% B,
A %-->% C,
B %-->% C,
class = "MPDAG"
)
expect_true(is_acyclic(cg))
expect_true(is_acyclic(cg, force_check = TRUE))
})
test_that("is_simple reflects declared state and force_check path", {
cg_simple <- caugi(A %-->% B, class = "DAG")
expect_true(is_simple(cg_simple))
expect_true(is_simple(cg_simple, force_check = TRUE))
cg_nonsimple <- caugi(
A %-->% B,
A %<->% B,
class = "UNKNOWN",
simple = FALSE
)
expect_false(is_simple(cg_nonsimple))
expect_false(is_simple(cg_nonsimple, force_check = TRUE))
})
test_that("query builds", {
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "PDAG")
expect_true(!is.null(cg@session))
cg <- cg |> add_edges(D %-->% E)
expect_true(!is.null(cg@session))
expect_true(is_acyclic(cg))
# now it should be build
expect_true(!is.null(cg@session))
})
test_that("build initializes session without querying", {
cg <- caugi(A %-->% B, B %-->% C, class = "DAG")
state_before <- rs_is_valid(cg@session)
expect_true(state_before$core_valid)
expect_false(state_before$view_valid)
expect_invisible(build(cg))
state_after <- rs_is_valid(cg@session)
expect_true(state_after$core_valid)
expect_true(state_after$view_valid)
# Build should not change graph content
expect_setequal(nodes(cg)$name, c("A", "B", "C"))
expect_equal(nrow(edges(cg)), 2L)
})
test_that("build is idempotent and survives updates", {
cg <- caugi(A %-->% B, class = "DAG")
build(cg)
state_built <- rs_is_valid(cg@session)
expect_true(state_built$core_valid)
expect_true(state_built$view_valid)
# idempotent
build(cg)
state_built2 <- rs_is_valid(cg@session)
expect_true(state_built2$core_valid)
expect_true(state_built2$view_valid)
# updating invalidates session; build again should restore
cg <- add_edges(cg, B %-->% C)
state_after_update <- rs_is_valid(cg@session)
expect_true(state_after_update$core_valid)
expect_false(state_after_update$view_valid)
build(cg)
state_rebuilt <- rs_is_valid(cg@session)
expect_true(state_rebuilt$core_valid)
expect_true(state_rebuilt$view_valid)
})
# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────── Is it <type>? ─────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("is_dag works", {
cg <- caugi(A %-->% B, B %-->% C, C %-->% D, class = "DAG")
expect_true(is_dag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "PDAG")
expect_false(is_dag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %-->% D, class = "PDAG")
expect_true(is_dag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "Unknown")
expect_false(is_dag(cg))
cg <- cg |> set_edges(C %-->% D)
expect_true(is_dag(cg))
})
test_that("is_pdag works", {
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "PDAG")
expect_true(is_pdag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %-->% D, class = "DAG")
expect_true(is_pdag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "Unknown")
expect_true(is_pdag(cg))
cg <- cg |> set_edges(C %o->% D)
expect_false(is_pdag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %o->% D, class = "Unknown")
expect_false(is_pdag(cg))
})
test_that("is_cpdag works", {
# Triangle with A--B undirected and A->C, B->C directed.
# Since A and B are adjacent, there's NO v-structure at C.
# Directed edges are not protected, so NOT a valid CPDAG.
cg <- caugi(A %-->% C, B %-->% C, A %---% B, class = "PDAG")
expect_false(is_cpdag(cg))
# Regression test: A->B, C->B with A--C undirected (triangle).
# Same reasoning: A and C are adjacent, so no v-structure at B.
# The directed edges A->B and C->B are not protected.
cg <- caugi(A %-->% B, C %-->% B, C %---% A, class = "PDAG")
expect_false(is_cpdag(cg))
# A pure directed chain is NOT a valid CPDAG (edges not protected)
cg <- caugi(A %-->% B, B %-->% C, C %-->% D, class = "DAG")
expect_false(is_cpdag(cg))
# V-structure 0 -> 2 <- 1 IS a valid CPDAG
cg <- caugi(A %-->% C, B %-->% C, class = "PDAG")
expect_true(is_cpdag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %o->% D, class = "Unknown")
expect_false(is_cpdag(cg))
cg <- caugi(A %-->% B, B %-->% C, C %---% D + E %o->% F, class = "Unknown")
expect_false(is_cpdag(cg))
cg <- caugi(A %-->% B, class = "PDAG")
expect_false(is_cpdag(cg))
cg <- caugi(A, B, class = "PDAG")
expect_true(is_cpdag(cg))
cg <- caugi(A %-->% B, A %---% C, class = "PDAG")
expect_false(is_cpdag(cg))
cg <- caugi(
B %---% A,
B %---% D,
C %-->% E,
B %-->% E,
D %-->% F,
E %-->% F,
class = "PDAG"
)
expect_true(is_cpdag(cg))
})
test_that("is_mpdag works", {
cg_closed <- caugi(
A %-->% C,
B %-->% C,
class = "PDAG"
)
expect_true(is_mpdag(cg_closed))
# R1 applies: A -> B, C -> B, B -- D, and C not adjacent to D.
cg_r1 <- caugi(
A %-->% B,
C %-->% B,
B %---% D,
A %---% D,
class = "PDAG"
)
expect_false(is_mpdag(cg_r1))
# R2 applies: A -- B and A -> C -> B.
cg_r2 <- caugi(
A %---% B,
A %-->% C,
C %-->% B,
class = "PDAG"
)
expect_false(is_mpdag(cg_r2))
# R3 applies: A -- B, C -> B, D -> B, C !~ D, and A -- C, A -- D.
cg_r3 <- caugi(
A %---% B,
C %-->% B,
D %-->% B,
A %---% C,
A %---% D,
class = "PDAG"
)
expect_false(is_mpdag(cg_r3))
# R4 applies: A -- B and A => B through A -> C -> D -> B.
cg_r4 <- caugi(
A %---% B,
A %-->% C,
C %-->% D,
A %---% D,
D %-->% B,
class = "PDAG"
)
expect_false(is_mpdag(cg_r4))
cg_partial <- caugi(A %o->% B, class = "UNKNOWN")
expect_false(is_mpdag(cg_partial))
})
test_that("is_mpdag tracks causal-learn style multi-rule progression", {
# Same fixture as the operations regression test:
# A-B-C, A->D<-C, B-D, D-E, C-E
g <- caugi(
A %---% B,
B %---% C,
A %-->% D,
C %-->% D,
B %---% D,
D %---% E,
C %---% E,
class = "PDAG"
)
expect_false(is_mpdag(g))
g_closed <- meek_closure(g)
expect_true(is_mpdag(g_closed))
# Expected closure leaves only chain edges A---B---C undirected.
und_A <- neighbors(g_closed, "A", mode = "undirected")
und_B <- neighbors(g_closed, "B", mode = "undirected")
und_C <- neighbors(g_closed, "C", mode = "undirected")
expect_setequal(und_A, "B")
expect_setequal(und_B, c("A", "C"))
expect_setequal(und_C, "B")
})
test_that("is_pdag fast path handles MPDAG class", {
cg <- caugi(
A %---% B,
A %-->% C,
B %-->% C,
class = "MPDAG"
)
expect_true(is_pdag(cg))
expect_true(is_mpdag(cg))
})
test_that("is_cpdag rejects graphs where Meek R1 would fire", {
# R1: a->b, b--c, a not adj c => b->c
# If b--c is still undirected when R1 should have oriented it, it's not a CPDAG.
# a->b with b--c undirected, a not adjacent to c
cg <- caugi(A %-->% B, B %---% C, class = "PDAG")
expect_false(is_cpdag(cg))
# Cascading R1: a->b, b--c, c--d with a not adj c, b not adj d
cg <- caugi(A %-->% B, B %---% C, C %---% D, class = "PDAG")
expect_false(is_cpdag(cg))
})
test_that("is_cpdag rejects graphs where Meek R2 would fire", {
# R2: a--b and ∃ w: a->w->b => a->b
# a->w->b with a--b undirected
cg <- caugi(A %---% B, A %-->% C, C %-->% B, class = "PDAG")
expect_false(is_cpdag(cg))
})
test_that("is_cpdag rejects graphs where Meek R3 would fire", {
# R3: a--b with c->b, d->b, c not adj d, a--c, a--d => a->b
cg <- caugi(
A %---% B,
C %-->% B,
D %-->% B,
A %---% C,
A %---% D,
class = "PDAG"
)
expect_false(is_cpdag(cg))
})
test_that("is_cpdag rejects graphs where Meek R4 would fire", {
# R4: a--b and directed path a => b => orient a->b
# a--b with directed path a->c->d->b
cg <- caugi(
A %---% B,
A %-->% C,
C %-->% D,
D %-->% B,
class = "PDAG"
)
expect_false(is_cpdag(cg))
})
test_that("is_cpdag accepts valid CPDAGs from pgmpy test cases", {
# pgmpy case 3: A->B, D->C with B--C stays undirected (no rule fires)
# This is a valid CPDAG: B and C have parents from opposite sides,
# but B and C are adjacent, so no additional orientation is needed.
# Actually A->B, D->C, B--C: R1 check: A->B, B--C, A adj C? No.
# So R1 WOULD fire. This means this is NOT a valid CPDAG.
# pgmpy represents it differently. Let me use properly valid CPDAGs.
# V-structure A->C<-B is a valid CPDAG
cg <- caugi(A %-->% C, B %-->% C, class = "PDAG")
expect_true(is_cpdag(cg))
# V-structure with R1 result: A->C<-B, C->D is valid
cg <- caugi(A %-->% C, B %-->% C, C %-->% D, class = "PDAG")
expect_true(is_cpdag(cg))
# Fully undirected triangle (complete graph, no v-structures)
cg <- caugi(A %---% B, B %---% C, A %---% C, class = "PDAG")
expect_true(is_cpdag(cg))
# Single undirected edge
cg <- caugi(A %---% B, class = "PDAG")
expect_true(is_cpdag(cg))
# Undirected chain
cg <- caugi(A %---% B, B %---% C, class = "PDAG")
expect_true(is_cpdag(cg))
# V-structure + R1 cascade + undirected component:
# B--A, B--D, C->E<-B, D->F<-E
cg <- caugi(
B %---% A,
B %---% D,
C %-->% E,
B %-->% E,
D %-->% F,
E %-->% F,
class = "PDAG"
)
expect_true(is_cpdag(cg))
})
test_that("is_cpdag accepts graphs with isolated nodes", {
cg <- caugi(A %-->% C, B %-->% C, D, E, class = "PDAG")
expect_true(is_cpdag(cg))
cg <- caugi(A, B, C, class = "PDAG")
expect_true(is_cpdag(cg))
})
test_that("is_cpdag: pcalg addBgKnowledge-style chain test", {
# pcalg example: 3-node undirected chain a--b--c
# This is a valid CPDAG (no v-structures, Markov equivalent to a->b->c etc.)
cg <- caugi(A %---% B, B %---% C, class = "PDAG")
expect_true(is_cpdag(cg))
# After orienting b->c, Meek R1 should orient b->a too.
# So b->c with a--b (a not adj c) is NOT a valid CPDAG (R1 would fire).
cg <- caugi(A %---% B, B %-->% C, class = "PDAG")
expect_false(is_cpdag(cg))
# Fully oriented b->a, b->c IS a valid CPDAG (a<-b->c v-structure,
# but a and c are non-adjacent so it's a valid v-structure CPDAG).
# Wait: a<-b->c with a not adj c: is b a collider? No, b is a parent of both.
# It's a "fork" not a collider. The directed edges are not protected.
# Actually in b->a, b->c: these are only protected if there's a v-structure.
# b->a is protected if ∃ v-structure witness. There's none. So NOT a CPDAG.
cg <- caugi(B %-->% A, B %-->% C, class = "PDAG")
expect_false(is_cpdag(cg))
})
test_that("to_cpdag via generate_graph produces valid CPDAGs", {
# Exhaustive check: generate random DAGs and verify CPDAGs
for (i in 1:20) {
cpdag <- generate_graph(n = 8, m = sample(5:12, 1), class = "CPDAG")
expect_true(is_cpdag(cpdag))
}
})
test_that("same_nodes works", {
cg1 <- caugi(A %-->% B, B %-->% C, class = "DAG")
cg2 <- caugi(B %-->% C, A %-->% B, class = "DAG")
cg3 <- caugi(A %-->% B, C %-->% D, class = "DAG")
expect_true(same_nodes(cg1, cg2))
expect_false(same_nodes(cg1, cg3))
expect_error(same_nodes(cg1, cg3, throw_error = TRUE))
})
test_that("is_ug works", {
cg <- caugi(A %---% B, B %---% C, C %---% D, class = "UG")
expect_true(is_ug(cg))
expect_true(is_ug(cg, force_check = TRUE))
cg <- caugi(A %-->% B, B %---% C, C %---% D, class = "PDAG")
expect_false(is_ug(cg))
cg <- caugi(A %---% B, B %---% C, C %o->% D, class = "Unknown")
expect_false(is_ug(cg))
})
# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────── Getter queries ────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("parents returns expected nodes for names, indices, and expr", {
cg <- caugi(A %-->% B, B %-->% C, A %---% D, D %-->% B, class = "PDAG")
expect_identical(parents(cg, "B"), c("A", "D"))
expect_identical(parents(cg, "B"), c("A", "D"))
pa_AB <- parents(cg, c("A", "B"))
expect_null(pa_AB[["A"]])
expect_setequal(pa_AB[["B"]], c("A", "D"))
expect_identical(parents(cg, index = 2), c("A", "D"))
pa_BC <- parents(cg, c("B", "C"))
expect_setequal(pa_BC[["B"]], c("A", "D"))
expect_setequal(pa_BC[["C"]], "B")
})
test_that("children returns expected nodes", {
cg <- caugi(A %-->% B, B %-->% C, C %---% D, D %-->% E, class = "PDAG")
expect_identical(children(cg, "A")[[1]], "B")
expect_identical(children(cg, c("B", "D"))[[1]], "C")
expect_identical(children(cg, c("C", "D"))[[2]], "E")
# indices
expect_identical(children(cg, index = 1)[[1]], "B")
})
test_that("neighbors returns undirected and directed adjacency", {
cg <- caugi(A %-->% B, B %-->% C, B %---% D, C %---% E, class = "PDAG")
# B has neighbors A (incoming), C (outgoing), D (undirected)
expect_setequal(neighbors(cg, "B"), c("A", "C", "D"))
# C has neighbors B and E
expect_setequal(neighbors(cg, "C"), c("B", "E"))
})
test_that("queries match with nodes and indexes", {
cg <- caugi(A %-->% B, B %-->% C, B %---% D, C %---% E, class = "PDAG")
expect_identical(children(cg, "A"), children(cg, index = 1))
expect_identical(parents(cg, "B"), parents(cg, index = 2))
expect_identical(neighbors(cg, "C"), neighbors(cg, index = 3))
})
test_that("queries fail with bad input", {
cg <- caugi(A %-->% B, B %-->% C, B %---% D, C %---% E, class = "PDAG")
expect_error(children(cg, "A", index = 1), "Supply either `nodes` or `index`")
expect_error(children(cg), "Must supply either `nodes` or `index`.")
expect_error(parents(cg, "A", index = 1), "Supply either `nodes` or `index`")
expect_error(parents(cg), "Must supply either `nodes` or `index`.")
expect_error(
neighbors(cg, "A", index = 1),
"Supply either `nodes` or `index`"
)
expect_error(neighbors(cg), "Must supply either `nodes` or `index`.")
expect_error(ancestors(cg, "Z"), "Non-existent node name: Z")
expect_error(
ancestors(cg, "A", index = 1),
"Supply either `nodes` or `index`, not both."
)
expect_error(
ancestors(cg),
"Must supply either `nodes` or `index`."
)
expect_error(descendants(cg, index = 0), "must be >= 0")
expect_error(
descendants(cg, "A", index = 1),
"Supply either `nodes` or `index`, not both."
)
expect_error(
descendants(cg),
"Must supply either `nodes` or `index`."
)
})
test_that("getter queries handle missing relations and duplicates", {
cg <- caugi(A %-->% B, B %-->% C, class = "DAG")
# node with no parents
expect_identical(length(parents(cg, "A")[[1]]), 0L)
# node with no children
expect_identical(length(children(cg, "C")[[1]]), 0L)
# duplicate targets collapse to the same combined set
res <- parents(cg, c("B", "B"))
expect_identical(sort(res[[1]]), sort(parents(cg, "B")[[1]]))
})
test_that("getter queries error on bad nodes or indices", {
cg <- caugi(A %-->% B, B %-->% C, class = "DAG")
expect_error(parents(cg, "Z"), "Non-existent node name: Z")
expect_error(children(cg, index = 0), "must be >= 0")
expect_error(children(cg, index = 100), "out of bounds")
})
test_that("aliases route correctly", {
cg <- caugi(A %-->% B, B %---% C, class = "PDAG")
expect_identical(neighbours(cg, "B")[[1]], neighbors(cg, "B")[[1]])
})
test_that("public getters trigger lazy build", {
cg <- caugi(A %-->% B, B %-->% C, class = "PDAG")
cg <- cg |> add_edges(C %---% D)
expect_true(!is.null(cg@session))
parents(cg, "B")
expect_true(!is.null(cg@session))
})
test_that("nodes and edges getters work", {
cg <- caugi(A %-->% B, B %-->% C, class = "PDAG")
nodes_out <- cg@nodes
edges_out <- cg@edges
expect_identical(nodes_out, nodes(cg))
expect_identical(edges_out, edges(cg))
expect_identical(nodes_out, vertices(cg))
expect_identical(nodes_out, V(cg))
expect_identical(edges_out, E(cg))
expect_equal(nrow(nodes(cg)), 3L)
expect_equal(nrow(edges(cg)), 2L)
cg <- caugi()
expect_equal(nrow(nodes(cg)), 0L)
expect_equal(nrow(edges(cg)), 0L)
})
test_that("an and de works", {
cg <- caugi(A %-->% B, B %-->% C, C %---% D, class = "PDAG")
expect_identical(ancestors(cg, "C"), c("A", "B"))
expect_identical(descendants(cg, "A"), c("B", "C"))
expect_identical(sort(ancestors(cg, c("C", "D"))[[1]]), c("A", "B"))
expect_identical(sort(descendants(cg, c("A", "D"))[[1]]), c("B", "C"))
# test index
expect_identical(ancestors(cg, index = 3), c("A", "B"))
expect_identical(descendants(cg, index = 1), c("B", "C"))
expect_identical(sort(ancestors(cg, index = c(3, 4))[[1]]), c("A", "B"))
expect_identical(sort(descendants(cg, index = c(1, 4))[[1]]), c("B", "C"))
cg <- caugi(A, B, class = "DAG")
expect_equal(length(ancestors(cg, "A")), 0L)
expect_equal(length(descendants(cg, "A")), 0L)
})
test_that("markov_blanket works on DAGs (parents, children, spouses)", {
cg <- caugi(
A %-->% B + C,
D %-->% B,
B %-->% E,
F %-->% E,
class = "DAG"
)
mb_A <- markov_blanket(cg, "A")
expect_setequal(mb_A, c("B", "C", "D"))
mb_B <- markov_blanket(cg, "B")
expect_setequal(mb_B, c("A", "D", "E", "F"))
# unquoted and vector inputs
mb_AC <- markov_blanket(cg, c("A", "C"))
expect_setequal(mb_AC[[1]], c("B", "C", "D"))
expect_setequal(mb_AC[[2]], c("A"))
# index input
mb_idx <- markov_blanket(cg, index = 1)
expect_setequal(mb_idx, c("B", "C", "D"))
})
test_that("markov_blanket includes undirected neighbors in PDAGs", {
cg <- caugi(
A %-->% B,
B %---% C,
D %-->% B,
class = "PDAG"
)
mb_B <- markov_blanket(cg, "B")
expect_setequal(mb_B, c("A", "C", "D"))
})
test_that("markov_blanket matches a multi-parent fixture on DAGs", {
cg <- caugi(
W %-->% Y,
X %-->% W,
Z1 %-->% X + Z3,
Z2 %-->% Y + Z3,
Z3 %-->% X + Y,
class = "DAG"
)
expect_setequal(markov_blanket(cg, "Z1"), c("X", "Z2", "Z3"))
expect_setequal(markov_blanket(cg, "Y"), c("W", "Z2", "Z3"))
})
test_that("markov_blanket argument validation", {
cg <- caugi(A %-->% B)
expect_error(
markov_blanket(cg),
"Must supply either `nodes` or `index`."
)
expect_error(
markov_blanket(cg, nodes = "A", index = 1),
"Supply either `nodes` or `index`, not both."
)
})
test_that("exogenous works", {
cg <- caugi(
A %-->% B + C,
D %-->% B,
B %-->% E,
F %-->% E,
class = "DAG"
)
e <- exogenous(cg)
expect_setequal(e, c("A", "D", "F"))
cg <- caugi(A %---% B, C %-->% A, class = "PDAG")
e <- exogenous(cg)
expect_setequal(e, c("B", "C"))
expect_error(exogenous("not a graph"), "Input must be a caugi")
})
test_that("exogenous works on PDAGs", {
cg <- caugi(A %---% B, C %-->% D, class = "PDAG")
e <- exogenous(cg)
expect_setequal(e, c("A", "B", "C"))
e <- exogenous(cg, undirected_as_parents = TRUE)
expect_setequal(e, c("C"))
})
test_that("getter queries errors on non-character input", {
cg <- caugi(A %-->% B, B %-->% C, class = "DAG")
expect_error(parents(cg, 1), "must be a character vector")
expect_error(children(cg, 2), "must be a character vector")
expect_error(neighbors(cg, 3), "must be a character vector")
expect_error(ancestors(cg, 4), "must be a character vector")
expect_error(descendants(cg, 5), "must be a character vector")
expect_error(markov_blanket(cg, 6), "must be a character vector")
})
test_that("getter queries builds", {
getter_queries <- c(
parents,
children,
neighbors,
ancestors,
descendants,
markov_blanket
)
for (getter in getter_queries) {
cg <- caugi(A %-->% B, B %-->% C, class = "DAG")
getter(cg, "B")
expect_true(!is.null(cg@session))
}
})
# ──────────────────────────────────────────────────────────────────────────────
# ───────────────────────────────── Subgraph ───────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("subgraph selects nodes and errors with none", {
cg <- caugi()
cg <- add_nodes(cg, name = c("A", "B", "C"))
cg <- add_edges(
cg,
from = c("A", "B"),
edge = c("-->", "-->"),
to = c("B", "C")
)
expect_error(subgraph(cg), "Must supply either `nodes` or `index`.")
sg <- subgraph(cg, nodes = c("A", "B"))
expect_setequal(sg@nodes$name, c("A", "B"))
expect_equal(
sg@edges,
data.table::data.table(from = "A", edge = "-->", to = "B")
)
})
test_that("subgraph errors on invalid arg combos", {
g <- caugi(
from = character(),
edge = character(),
to = character(),
nodes = c("A", "B"),
class = "UNKNOWN"
)
expect_error(subgraph(g), "Must supply either `nodes` or `index`.")
expect_error(subgraph(g, nodes = "A", index = 1), "not both")
})
test_that("subgraph validates index", {
g <- caugi(
from = character(),
edge = character(),
to = character(),
nodes = c("A", "B"),
class = "UNKNOWN"
)
expect_error(subgraph(g, index = "a"), "`index` must be numeric")
expect_error(
subgraph(g, index = c(1, NA_integer_)),
"`index` cannot contain NA values"
)
expect_error(subgraph(g, index = 0), "out of range")
expect_error(subgraph(g, index = 3), "out of range")
})
test_that("subgraph validates nodes", {
skip_if_not_installed("data.table")
g <- caugi(
from = character(),
edge = character(),
to = character(),
nodes = c("A", "B"),
class = "UNKNOWN"
)
expect_error(subgraph(g, nodes = 1), "character vector")
expect_error(
subgraph(g, nodes = c("A", NA_character_)),
"`nodes` cannot contain NA values"
)
expect_error(subgraph(g, nodes = c("A", "Z")), "Unknown node\\(s\\): Z")
})
test_that("subgraph catches duplicates (nodes and index)", {
g <- caugi(
from = c("A", "B"),
edge = c("-->", "-->"),
to = c("C", "D"),
nodes = c("A", "B", "C", "D"),
class = "DAG"
)
expect_error(subgraph(g, nodes = c("A", "A")), "contains duplicates")
expect_error(subgraph(g, index = c(1L, 1L)), "contains duplicates")
})
test_that("subgraph on graph without edges keeps nodes and empty edges", {
g <- caugi(
from = character(),
edge = character(),
to = character(),
nodes = c("A", "B", "C"),
class = "UNKNOWN"
)
s <- subgraph(g, nodes = c("C", "A"))
expect_identical(s@nodes$name, c("C", "A"))
expect_equal(nrow(s@edges), 0L)
expect_true(!is.null(s@session))
expect_identical(s@graph_class, g@graph_class)
expect_identical(s@simple, g@simple)
})
test_that("subgraph filters edges to kept names and sorts", {
g <- caugi(
from = c("A", "B", "C", "A"),
edge = c("-->", "-->", "---", "<->"),
to = c("B", "C", "A", "C"),
nodes = c("A", "B", "C", "D"),
class = "UNKNOWN",
simple = FALSE
)
# Keep C, A => should keep (A <-> C) and (C --- A), sorted by from,to,edge
s <- subgraph(g, nodes = c("C", "A"))
expect_identical(s@nodes$name, c("C", "A"))
expect_equal(nrow(s@edges), 2L)
expect_identical(s@edges$from, c("A", "C"))
expect_identical(s@edges$to, c("C", "A"))
expect_identical(s@edges$edge, c("<->", "---"))
})
test_that("subgraph with index matches nodes variant", {
g <- caugi(
from = c("A", "B", "C", "A"),
edge = c("-->", "-->", "---", "-->"),
to = c("D", "E", "G", "F"),
nodes = c("A", "B", "C", "D", "E", "F", "G"),
class = "PDAG"
)
s1 <- subgraph(g, nodes = c("B", "A", "C"))
s2 <- subgraph(g, index = c(2L, 1L, 3L))
expect_identical(s1@nodes$name, s2@nodes$name)
expect_identical(s1@edges, s2@edges)
expect_true(!is.null(s1@session) && !is.null(s2@session))
})
test_that("districts supports all, nodes, and index modes", {
cg <- caugi(
A %<->% B,
B %<->% C,
C %-->% D,
class = "ADMG"
)
all_d <- districts(cg)
expect_equal(length(all_d), 2L)
expect_true(any(vapply(
all_d,
function(x) setequal(x, c("A", "B", "C")),
logical(1)
)))
expect_true(any(vapply(all_d, function(x) identical(x, "D"), logical(1))))
expect_setequal(districts(cg, nodes = "A"), c("A", "B", "C"))
by_nodes <- districts(cg, nodes = c("A", "D"))
expect_named(by_nodes, c("A", "D"))
expect_setequal(by_nodes$A, c("A", "B", "C"))
expect_identical(by_nodes$D, "D")
by_index <- districts(cg, index = c(1L, 4L))
expect_named(by_index, c("A", "D"))
expect_setequal(by_index$A, c("A", "B", "C"))
expect_identical(by_index$D, "D")
})
test_that("districts validates argument combinations", {
cg <- caugi(A %<->% B, class = "ADMG")
expect_error(
districts(cg, nodes = "A", index = 1L),
"either `nodes` or `index`"
)
expect_error(districts(cg, index = 0), "out of range")
expect_error(districts(cg, nodes = c("A", NA_character_)), "without NA")
})
# ──────────────────────────────────────────────────────────────────────────────
# ─────────────────────── UNKNOWN graph neighbor queries ──────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("neighbors mode 'all' works for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %---% C,
C %<->% D,
class = "UNKNOWN"
)
# All neighbors
expect_setequal(neighbors(cg, "B", mode = "all"), c("A", "C"))
expect_setequal(neighbors(cg, "C", mode = "all"), c("B", "D"))
})
test_that("neighbors mode 'in' and 'out' work for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "UNKNOWN"
)
# In mode (parents)
expect_null(neighbors(cg, "A", mode = "in"))
expect_identical(neighbors(cg, "B", mode = "in"), "A")
expect_identical(neighbors(cg, "C", mode = "in"), "B")
# Out mode (children)
expect_identical(neighbors(cg, "A", mode = "out"), "B")
expect_identical(neighbors(cg, "B", mode = "out"), "C")
expect_null(neighbors(cg, "C", mode = "out"))
})
test_that("neighbors mode 'undirected' works for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %---% C,
C %---% D,
class = "UNKNOWN"
)
# Undirected mode (--- only, not <->)
expect_null(neighbors(cg, "A", mode = "undirected"))
expect_identical(neighbors(cg, "B", mode = "undirected"), "C")
expect_setequal(neighbors(cg, "C", mode = "undirected"), c("B", "D"))
expect_identical(neighbors(cg, "D", mode = "undirected"), "C")
})
test_that("neighbors mode 'bidirected' works for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %<->% C,
C %<->% D,
class = "UNKNOWN"
)
# Bidirected mode (<-> only)
expect_null(neighbors(cg, "A", mode = "bidirected"))
expect_identical(neighbors(cg, "B", mode = "bidirected"), "C")
expect_setequal(neighbors(cg, "C", mode = "bidirected"), c("B", "D"))
expect_identical(neighbors(cg, "D", mode = "bidirected"), "C")
})
test_that("neighbors mode 'partial' works for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %o->% C,
C %o-o% D,
D %--o% E,
class = "UNKNOWN"
)
# Partial mode returns neighbors where the CURRENT node has a Circle mark.
# Edge marks:
# A --> B: A has Tail, B has Arrow
# B o-> C: B has Circle, C has Arrow
# C o-o D: both have Circle
# D --o E: D has Tail, E has Circle (head position has Circle)
expect_null(neighbors(cg, "A", mode = "partial")) # A has Tail (no Circle)
expect_identical(neighbors(cg, "B", mode = "partial"), "C") # B has Circle in B o-> C
expect_identical(neighbors(cg, "C", mode = "partial"), "D") # C has Circle in C o-o D (but Arrow in B o-> C)
expect_identical(neighbors(cg, "D", mode = "partial"), "C") # D has Circle in C o-o D (but Tail in D --o E)
expect_identical(neighbors(cg, "E", mode = "partial"), "D") # E has Circle in D --o E
})
test_that("parents and children error for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %-->% C,
B %---% D,
class = "UNKNOWN"
)
# parents, children, and spouses should error for UNKNOWN graphs
# because only the structural neighbors() query should work
expect_error(parents(cg, "B"), "not defined for UNKNOWN")
expect_error(children(cg, "A"), "not defined for UNKNOWN")
expect_error(spouses(cg, "A"), "not defined for UNKNOWN")
# Use neighbors() with explicit mode instead
expect_identical(neighbors(cg, "B", mode = "in"), "A")
expect_identical(neighbors(cg, "A", mode = "out"), "B")
})
test_that("neighbors mode with index works for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "UNKNOWN"
)
# Using index parameter
expect_identical(neighbors(cg, index = 2, mode = "in"), "A")
expect_identical(neighbors(cg, index = 2, mode = "out"), "C")
})
test_that("neighbors mode works with multiple nodes for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %-->% C,
C %-->% D,
class = "UNKNOWN"
)
result <- neighbors(cg, c("B", "C"), mode = "in")
expect_identical(names(result), c("B", "C"))
expect_identical(result$B, "A")
expect_identical(result$C, "B")
})
test_that("neighbors mode 'all' is default for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %---% C,
class = "UNKNOWN"
)
# Default should be "all"
expect_identical(
neighbors(cg, "B"),
neighbors(cg, "B", mode = "all")
)
})
test_that("neighbors mode validation for DAG", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "DAG"
)
# Valid modes for DAG: in, out, all
expect_identical(neighbors(cg, "B", mode = "in"), "A")
expect_identical(neighbors(cg, "B", mode = "out"), "C")
expect_setequal(neighbors(cg, "B", mode = "all"), c("A", "C"))
# Invalid modes for DAG: undirected, bidirected, partial
expect_error(neighbors(cg, "B", mode = "undirected"), "not valid for DAG")
expect_error(neighbors(cg, "B", mode = "bidirected"), "not valid for DAG")
expect_error(neighbors(cg, "B", mode = "partial"), "not valid for DAG")
})
test_that("neighbors mode validation for PDAG", {
cg <- caugi(
A %-->% B,
B %---% C,
class = "PDAG"
)
# Valid modes for PDAG: in, out, undirected, all
expect_identical(neighbors(cg, "B", mode = "in"), "A")
expect_null(neighbors(cg, "B", mode = "out"))
expect_identical(neighbors(cg, "B", mode = "undirected"), "C")
expect_setequal(neighbors(cg, "B", mode = "all"), c("A", "C"))
# Invalid modes for PDAG: bidirected, partial
expect_error(neighbors(cg, "B", mode = "bidirected"), "not valid for PDAG")
expect_error(neighbors(cg, "B", mode = "partial"), "not valid for PDAG")
})
test_that("neighbors mode validation for UG", {
cg <- caugi(
A %---% B,
B %---% C,
class = "UG"
)
# Valid modes for UG: undirected, all
expect_setequal(neighbors(cg, "B", mode = "undirected"), c("A", "C"))
expect_setequal(neighbors(cg, "B", mode = "all"), c("A", "C"))
# Invalid modes for UG: in, out, bidirected, partial
expect_error(neighbors(cg, "B", mode = "in"), "not defined for UG")
expect_error(neighbors(cg, "B", mode = "out"), "not defined for UG")
expect_error(neighbors(cg, "B", mode = "bidirected"), "not valid for UG")
expect_error(neighbors(cg, "B", mode = "partial"), "not valid for UG")
})
test_that("neighbors mode validation for ADMG", {
cg <- caugi(
A %-->% B,
B %<->% C,
class = "ADMG"
)
# Valid modes for ADMG: in, out, bidirected (spouses), all
expect_identical(neighbors(cg, "B", mode = "in"), "A")
expect_null(neighbors(cg, "B", mode = "out"))
expect_identical(neighbors(cg, "B", mode = "bidirected"), "C")
expect_setequal(neighbors(cg, "B", mode = "all"), c("A", "C"))
# Invalid modes for ADMG: undirected, partial
expect_error(neighbors(cg, "B", mode = "undirected"), "not valid for ADMG")
expect_error(neighbors(cg, "B", mode = "partial"), "not valid for ADMG")
})
test_that("spouses errors for UNKNOWN graphs", {
cg <- caugi(
A %-->% B,
B %<->% C,
C %---% D,
class = "UNKNOWN"
)
# spouses should error for UNKNOWN graphs
expect_error(spouses(cg, "B"), "not defined for UNKNOWN")
# Use neighbors with mode = "bidirected" instead
expect_identical(neighbors(cg, "B", mode = "bidirected"), "C")
expect_identical(neighbors(cg, "C", mode = "bidirected"), "B")
expect_null(neighbors(cg, "A", mode = "bidirected"))
expect_null(neighbors(cg, "D", mode = "bidirected"))
})
test_that("spouses works for ADMG graphs", {
cg <- caugi(
A %-->% B,
B %<->% C,
class = "ADMG"
)
# spouses returns bidirected neighbors (same as neighbors mode="bidirected")
expect_null(spouses(cg, "A"))
expect_identical(spouses(cg, "B"), "C")
expect_identical(spouses(cg, "C"), "B")
# spouses is equivalent to neighbors with mode = "bidirected"
expect_identical(spouses(cg, "B"), neighbors(cg, "B", mode = "bidirected"))
})
test_that("spouses errors for graph types without bidirected edges", {
cg_dag <- caugi(A %-->% B, class = "DAG")
cg_pdag <- caugi(A %-->% B, B %---% C, class = "PDAG")
cg_ug <- caugi(A %---% B, class = "UG")
expect_error(spouses(cg_dag, "A"), "not valid for DAG")
expect_error(spouses(cg_pdag, "A"), "not valid for PDAG")
expect_error(spouses(cg_ug, "A"), "not valid for UG")
})
# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────── Anteriors tests ───────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("anteriors works for DAG (equals ancestors)", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "DAG"
)
expect_null(anteriors(cg, "A"))
expect_equal(anteriors(cg, "B"), "A")
expect_equal(sort(anteriors(cg, "C")), c("A", "B"))
})
test_that("anteriors works for PDAG with mixed edges", {
# PDAG: A -> B --- C, B -> D
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
# A has no anteriors
expect_null(anteriors(cg, "A"))
# B's anteriors: A (parent) and C (undirected)
expect_equal(sort(anteriors(cg, "B")), c("A", "C"))
# C's anteriors: B (undirected) -> A (parent of B)
expect_equal(sort(anteriors(cg, "C")), c("A", "B"))
# D's anteriors: B (parent) -> A (parent of B), C (undirected of B)
expect_equal(sort(anteriors(cg, "D")), c("A", "B", "C"))
})
test_that("anteriors works for PDAG with undirected cycle", {
# PDAG: A --- B --- C --- A (triangle)
cg <- caugi(
A %---% B,
B %---% C,
C %---% A,
class = "PDAG"
)
# All nodes can reach all others via undirected edges
expect_equal(sort(anteriors(cg, "A")), c("B", "C"))
expect_equal(sort(anteriors(cg, "B")), c("A", "C"))
expect_equal(sort(anteriors(cg, "C")), c("A", "B"))
})
test_that("anteriors not defined for UG", {
cg <- caugi(
A %---% B,
B %---% C,
class = "UG"
)
expect_error(anteriors(cg, "B"), "not defined for UG")
})
test_that("anteriors not defined for ADMG", {
cg <- caugi(
A %-->% B,
A %<->% C,
class = "ADMG"
)
expect_error(anteriors(cg, "B"), "not defined for ADMG")
})
test_that("anteriors returns list for multiple nodes", {
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
result <- anteriors(cg, c("A", "D"))
expect_type(result, "list")
expect_named(result, c("A", "D"))
expect_null(result$A)
expect_equal(sort(result$D), c("A", "B", "C"))
})
# ────────────────────────────── Posteriors tests ──────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("posteriors works for DAG (equals descendants)", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "DAG"
)
expect_equal(sort(posteriors(cg, "A")), c("B", "C"))
expect_equal(posteriors(cg, "B"), "C")
expect_null(posteriors(cg, "C"))
})
test_that("posteriors works for PDAG with mixed edges", {
# PDAG: A -> B --- C, B -> D
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
# A's posteriors: B (child) -> C (undirected of B), D (child of B)
expect_equal(sort(posteriors(cg, "A")), c("B", "C", "D"))
# B's posteriors: D (child) and C (undirected)
expect_equal(sort(posteriors(cg, "B")), c("C", "D"))
# C's posteriors: B (undirected) -> D (child of B)
expect_equal(sort(posteriors(cg, "C")), c("B", "D"))
# D has no posteriors
expect_null(posteriors(cg, "D"))
})
test_that("posteriors works for PDAG with undirected cycle", {
# PDAG: A --- B --- C --- A (triangle)
cg <- caugi(
A %---% B,
B %---% C,
C %---% A,
class = "PDAG"
)
# All nodes can reach all others via undirected edges
# For undirected-only graphs, posteriors == anteriors
expect_equal(sort(posteriors(cg, "A")), c("B", "C"))
expect_equal(sort(posteriors(cg, "B")), c("A", "C"))
expect_equal(sort(posteriors(cg, "C")), c("A", "B"))
})
test_that("posteriors not defined for UG", {
cg <- caugi(
A %---% B,
B %---% C,
class = "UG"
)
expect_error(posteriors(cg, "B"), "not defined for UG")
})
test_that("posteriors not defined for ADMG", {
cg <- caugi(
A %-->% B,
A %<->% C,
class = "ADMG"
)
expect_error(posteriors(cg, "B"), "not defined for ADMG")
})
test_that("posteriors returns list for multiple nodes", {
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
result <- posteriors(cg, c("A", "D"))
expect_type(result, "list")
expect_named(result, c("A", "D"))
expect_equal(sort(result$A), c("B", "C", "D"))
expect_null(result$D)
})
test_that("posteriors works with index parameter", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "DAG"
)
# Index 1 is A (0-indexed becomes 1-indexed in R)
expect_equal(sort(posteriors(cg, index = 1)), c("B", "C"))
expect_equal(posteriors(cg, index = 2), "C")
})
test_that("posteriors excludes the node itself", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "DAG"
)
res <- posteriors(cg, "A")
expect_false("A" %in% res)
})
test_that("posteriors handles multi-step mixed reachability (PDAG)", {
# A -> B --- C --- D -> E
cg <- caugi(
A %-->% B,
B %---% C,
C %---% D,
D %-->% E,
class = "PDAG"
)
# From A: B, C, D, E should all be reachable
expect_equal(sort(posteriors(cg, "A")), c("B", "C", "D", "E"))
})
test_that("posteriors does not return duplicates in undirected cycles", {
# A --- B --- C --- A
cg <- caugi(
A %---% B,
B %---% C,
C %---% A,
class = "PDAG"
)
res <- posteriors(cg, "A")
expect_equal(length(res), length(unique(res)))
})
test_that("posteriors handles branching mixed structure correctly", {
# B --- C
# /
# A ->
# \
# D -> E
cg <- caugi(
A %-->% B,
B %---% C,
A %-->% D,
D %-->% E,
class = "PDAG"
)
expect_equal(sort(posteriors(cg, "A")), c("B", "C", "D", "E"))
})
test_that("posteriors works for multiple starting nodes (set semantics)", {
cg <- caugi(
A %-->% B,
B %-->% C,
D %-->% E,
class = "DAG"
)
res <- posteriors(cg, c("A", "D"))
expect_type(res, "list")
expect_named(res, c("A", "D"))
expect_equal(sort(res$A), c("B", "C"))
expect_equal(res$D, "E")
})
test_that("posteriors returns empty (NULL) when no reachable nodes exist", {
cg <- caugi(
A %-->% B,
class = "DAG"
)
expect_null(posteriors(cg, "B"))
})
test_that("posteriors respects disconnected components", {
cg <- caugi(
A %-->% B,
C %-->% D,
class = "DAG"
)
expect_equal(posteriors(cg, "A"), "B")
expect_equal(posteriors(cg, "C")[posteriors(cg, "C") == "A"], character(0))
})
test_that("posteriors index parameter matches name-based query", {
cg <- caugi(
A %-->% B,
B %-->% C,
class = "DAG"
)
nodes_vec <- nodes(cg)
idx_A <- which(nodes_vec == "A")
expect_equal(
sort(posteriors(cg, index = idx_A)),
sort(posteriors(cg, "A"))
)
})
# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────── Closed graph definition tests ─────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("ancestors, anteriors, descendants, posteriors errors on not boolean open argument", {
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
expect_error(
ancestors(cg, "A", open = "hi"),
"`open` must be a single TRUE or FALSE."
)
expect_error(
anteriors(cg, "A", open = "hi"),
"`open` must be a single TRUE or FALSE."
)
expect_error(
descendants(cg, "A", open = "hi"),
"`open` must be a single TRUE or FALSE."
)
expect_error(
posteriors(cg, "A", open = c(TRUE, FALSE)),
"`open` must be a single TRUE or FALSE."
)
})
test_that("ancestors, anteriors, descendants, posteriors handles closed graph definition", {
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
expect_equal(ancestors(cg, "A", open = FALSE), "A")
expect_equal(ancestors(cg, "B", open = FALSE), c("B", "A"))
expect_equal(anteriors(cg, "A", open = FALSE), "A")
expect_equal(
anteriors(cg, "C", open = FALSE),
c("C", "A", "B")
)
expect_equal(
descendants(cg, "A", open = FALSE),
c("A", "B", "D")
)
expect_equal(descendants(cg, "B", open = FALSE), c("B", "D"))
expect_equal(posteriors(cg, "A", open = FALSE), c("A", "B", "C", "D"))
expect_equal(posteriors(cg, "B", open = FALSE), c("B", "C", "D"))
})
test_that("Setting use_open_graph_definition via caugi_options works", {
caugi_options(use_open_graph_definition = FALSE)
cg <- caugi(
A %-->% B %---% C,
B %-->% D,
class = "PDAG"
)
expect_equal(ancestors(cg, "A"), "A")
expect_equal(ancestors(cg, "B"), c("B", "A"))
expect_equal(anteriors(cg, "A"), "A")
expect_equal(anteriors(cg, "C"), c("C", "A", "B"))
expect_equal(descendants(cg, "A"), c("A", "B", "D"))
expect_equal(descendants(cg, "B"), c("B", "D"))
expect_equal(posteriors(cg, "A"), c("A", "B", "C", "D"))
# Can still override with explicit argument
expect_equal(ancestors(cg, "A", open = TRUE), NULL)
expect_equal(anteriors(cg, "A", open = TRUE), NULL)
expect_equal(descendants(cg, "A", open = TRUE), c("B", "D"))
expect_equal(posteriors(cg, "A", open = TRUE), c("B", "C", "D"))
# Reset to defaults
caugi_options(caugi_default_options())
})
# ──────────────────────────────────────────────────────────────────────────────
# ──────────────────── open_graph_def fast-access env var ──────────────────────
# ──────────────────────────────────────────────────────────────────────────────
test_that("open_graph_def is TRUE by default", {
expect_true(.caugi_env$open_graph_def)
})
test_that("open_graph_def syncs to FALSE when use_open_graph_definition is set FALSE", {
on.exit(caugi_options(caugi_default_options()), add = TRUE)
caugi_options(use_open_graph_definition = FALSE)
expect_false(.caugi_env$open_graph_def)
})
test_that("open_graph_def syncs back to TRUE when use_open_graph_definition is set TRUE", {
on.exit(caugi_options(caugi_default_options()), add = TRUE)
caugi_options(use_open_graph_definition = FALSE)
caugi_options(use_open_graph_definition = TRUE)
expect_true(.caugi_env$open_graph_def)
})
test_that("open_graph_def is restored to TRUE by caugi_default_options()", {
on.exit(caugi_options(caugi_default_options()), add = TRUE)
caugi_options(use_open_graph_definition = FALSE)
expect_false(.caugi_env$open_graph_def)
caugi_options(caugi_default_options())
expect_true(.caugi_env$open_graph_def)
})
test_that("open_graph_def is unaffected by unrelated option updates", {
on.exit(caugi_options(caugi_default_options()), add = TRUE)
caugi_options(plot = list(spacing = grid::unit(2, "lines")))
expect_true(.caugi_env$open_graph_def)
})
test_that("missing(open) uses global option; explicit open overrides it", {
on.exit(caugi_options(caugi_default_options()), add = TRUE)
cg <- caugi(A %-->% B %-->% C, class = "DAG")
# With default option (open = TRUE): node excluded
expect_equal(ancestors(cg, "B"), "A")
# Switch global option to closed; missing open now means closed
caugi_options(use_open_graph_definition = FALSE)
expect_equal(ancestors(cg, "B"), c("B", "A"))
# Explicit open = TRUE overrides the closed global option
expect_equal(ancestors(cg, "B", open = TRUE), "A")
# Explicit open = FALSE overrides the open global option after reset
caugi_options(use_open_graph_definition = TRUE)
expect_equal(ancestors(cg, "B", open = FALSE), c("B", "A"))
})
test_that("getter and districts branches are covered", {
cg <- caugi(
A %-->% B,
B %-->% C,
B %---% D,
class = "PDAG"
)
expect_true("B" %in% ancestors(cg, index = 2, open = FALSE))
expect_true("A" %in% descendants(cg, index = 1, open = FALSE))
expect_true("D" %in% anteriors(cg, index = 4, open = FALSE))
expect_error(
posteriors(cg, nodes = "A", index = 1),
"Supply either `nodes` or `index`, not both."
)
expect_error(
posteriors(cg),
"Supply one of `nodes` or `index`."
)
expect_error(
posteriors(cg, nodes = 1),
"`nodes` must be a character vector of node names."
)
expect_true("B" %in% posteriors(cg, index = 2, open = FALSE))
cg_admg <- caugi(
A %<->% B,
B %<->% C,
C %-->% D,
class = "ADMG"
)
expect_setequal(spouses(cg_admg, index = 2), c("A", "C"))
# Test that deprecated 'all' parameter shows warning
expect_warning(
districts(cg_admg, all = TRUE),
"deprecated"
)
# Test error for invalid index
expect_error(
districts(cg_admg, index = c(1, NA)),
"`index` must be numeric without NA."
)
# Test getting all districts (new API - no parameters)
all_districts <- districts(cg_admg)
expect_true(is.list(all_districts))
expect_true(length(all_districts) >= 1L)
})
test_that("is_mag class short-circuit branch is covered", {
cg <- caugi(A %-->% B, class = "DAG")
out <- testthat::with_mocked_bindings(
is_mag(cg),
rs_class = function(session) "MAG",
.package = "caugi"
)
expect_true(out)
})
test_that("nodes_to_indices errors when session is missing", {
cg <- caugi(A %-->% B, class = "DAG")
bad <- cg
attr(bad, "session") <- NULL
expect_error(
caugi:::.nodes_to_indices(bad, "A"),
"Cannot look up indices for empty graph."
)
})
################# NetworkX tests ##############
# topological sort tests:
# https://github.com/networkx/networkx/blob/main/networkx/algorithms/tests/test_dag.py
# All the other ones are just raising errors, etc, and thus only the below are ported.
test_that("topological sort NetworkX 1 test", {
cg <- caugi(A %-->% B + C, B %-->% C, class = "DAG")
ts_cg <- topological_sort(cg)
expect_equal(ts_cg, c("A", "B", "C"))
cg <- caugi(A %-->% B + C, C %-->% B, class = "DAG")
ts_cg <- topological_sort(cg)
expect_equal(ts_cg, c("A", "C", "B"))
})
test_that("topological sort NetworkX 2 test", {
cg <- caugi(A %-->% B, B %-->% C, C %-->% D, D %-->% E, class = "DAG")
ts_cg <- topological_sort(cg)
expect_equal(ts_cg, c("A", "B", "C", "D", "E"))
cg <- caugi(A %-->% B + C, C %-->% B, class = "DAG")
ts_cg <- topological_sort(cg)
expect_equal(ts_cg, c("A", "C", "B"))
})
# ancestors and descendants tests:
# https://github.com/networkx/networkx/blob/main/networkx/algorithms/tests/test_dag.py
test_that("ancestors NetworkX 1 test", {
cg <- caugi(
A %-->% B + C,
D %-->% B + E,
D %-->% C,
B %-->% F,
E %-->% F,
class = "DAG"
)
ancestors_cg_f <- ancestors(cg, nodes = "F")
expect_setequal(ancestors_cg_f, c("A", "B", "D", "E"))
ancestors_cg_c <- ancestors(cg, nodes = "C")
expect_setequal(ancestors_cg_c, c("A", "D"))
ancestors_cg_a <- ancestors(cg, nodes = "A")
expect_null(ancestors_cg_a)
})
test_that("descendants NetworkX 1 test", {
cg <- caugi(
A %-->% B + C,
D %-->% B + E,
D %-->% C,
B %-->% F,
E %-->% F,
class = "DAG"
)
descendants_cg_a <- descendants(cg, nodes = "A")
expect_setequal(descendants_cg_a, c("B", "C", "F"))
descendants_cg_d <- descendants(cg, nodes = "D")
expect_setequal(descendants_cg_d, c("B", "C", "E", "F"))
descendants_cg_c <- descendants(cg, nodes = "C")
expect_null(descendants_cg_c)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.