tests/testthat/test-verbs.R

In caugi: Causal Graph Interface

# ──────────────────────────────────────────────────────────────────────────────
# ─────────────────────────────── Verbs tests ──────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

# ──────────────────────────────────────────────────────────────────────────────
# ───────────────────────────── Session management ────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that("caugi objects have session after construction", {
  cg <- caugi()
  cg <- add_nodes(cg, name = c("A", "B"))
  expect_true(!is.null(cg@session))

  cg <- add_edges(cg, from = "A", edge = "-->", to = "B")
  expect_true(!is.null(cg@session))
  expect_equal(cg@nodes$name, c("A", "B"))
  expect_equal(
    cg@edges,
    data.table::data.table(from = "A", edge = "-->", to = "B")
  )
})

test_that("verbs error when breaking simple graph assumptions", {
  cg <- caugi()
  # Error now thrown at add_edges time (eager validation)
  expect_error(
    add_edges(
      cg,
      from = c("A", "A"),
      edge = c("o->", "-->"),
      to = c("B", "B")
    ),
    "Parallel edges not allowed"
  )

  cg <- caugi()
  expect_error(
    add_edges(
      cg,
      from = c("A", "A"),
      edge = c("-->", "<->"),
      to = c("B", "A")
    ),
    "Self-loops not allowed"
  )
})

# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────────── Edges ─────────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that("add_edges validates inputs and updates graph", {
  cg <- caugi()
  expect_identical(add_edges(cg), cg)

  expect_error(
    add_edges(cg, A %-->% B, from = "A", edge = "-->", to = "B"),
    "Provide expressions"
  )
  expect_error(
    add_edges(cg, from = "A"),
    "`from`, `edge`, `to` must all be supplied"
  )
  expect_error(
    add_edges(cg, from = c("A", "B"), edge = "-->", to = "B"),
    "equal length"
  )

  cg1 <- add_edges(cg, from = "A", edge = "-->", to = "B")
  # After verbs, session is synced automatically
  expect_true(!is.null(cg1@session))
  expect_setequal(cg1@nodes$name, c("A", "B"))
  expect_equal(
    cg1@edges,
    data.table::data.table(from = "A", edge = "-->", to = "B")
  )

  cg2 <- add_edges(
    cg1,
    from = c("A", "A"),
    edge = c("-->", "-->"),
    to = c("B", "B")
  )
  expect_equal(nrow(cg2@edges), 1L)
})

test_that("add_edges keeps session synced", {
  cg <- caugi()

  cg1 <- add_edges(cg, from = "A", edge = "-->", to = "B")
  # After verbs, session is synced automatically
  expect_true(!is.null(cg1@session))

  cg2 <- add_edges(
    cg1,
    from = c("A", "A"),
    edge = c("-->", "-->"),
    to = c("B", "B")
  )
  expect_true(!is.null(cg2@session))
})

test_that("add_edges expression path works", {
  cg <- caugi()
  cg <- add_edges(
    cg,
    A %-->% B,
    B %---% C,
    C %<->% D,
    D %--o% E,
    E %o->% F,
    F %o-o% A
  )
  expect_true(!is.null(cg@session))
  expect_setequal(cg@nodes$name, c("A", "B", "C", "D", "E", "F"))
  expect_equal(nrow(cg@edges), 6L)
  expect_true(all(c("from", "edge", "to") %in% names(cg@edges)))
  expect_equal(sort(cg@nodes$name), sort(LETTERS[1:6]))
  expect_equal(
    sort(cg@edges$edge),
    sort(c("o->", "--o", "o-o", "-->", "<->", "---"))
  )
})

test_that("add_edges expression path (DSL) works (also some + notation)", {
  cg <- caugi()
  cg <- add_nodes(cg, A + B)
  cg <- add_edges(cg, A %-->% B + C)
  expect_setequal(cg@nodes$name, c("A", "B", "C"))
  expect_equal(
    cg@edges,
    data.table::data.table(
      from = "A",
      edge = c("-->", "-->"),
      to = c("B", "C")
    )
  )
})

test_that("remove_edges works and keeps other edges", {
  cg <- caugi()
  cg <- add_edges(
    cg,
    from = c("A", "A"),
    edge = c("-->", "-->"),
    to = c("B", "C")
  )
  expect_identical(remove_edges(cg), cg) # no-op
  expect_error(
    remove_edges(cg, A %-->% B, from = "A", edge = "-->", to = "B"),
    "Provide expressions"
  )

  cg1 <- remove_edges(cg, from = "A", edge = "-->", to = "B")
  # After verbs, session is synced automatically
  expect_true(!is.null(cg1@session))
  expect_equal(
    cg1@edges,
    data.table::data.table(from = "A", edge = "-->", to = "C")
  )
})

test_that("edge removal preserves bows, directions, nodes, and its input", {
  for (built in c(FALSE, TRUE)) {
    cg <- caugi(
      from = c("B", "A", "B"),
      edge = c("<->", "-->", "-->"),
      to = c("A", "B", "A"),
      nodes = c("isolated", "B", "A"),
      simple = FALSE,
      class = "UNKNOWN"
    )
    if (built) {
      cg <- build(cg)
    }
    original <- edges(cg)
    out <- remove_edges(cg, B %<->% A)
    expect_identical(nodes(out)$name, c("isolated", "B", "A"))
    expect_equal(edges(out), original[which(original$edge == "-->")])
    expect_equal(edges(cg), original)
    expect_equal(out@graph_class, "UNKNOWN")
    expect_false(out@simple)

    out <- remove_edges(cg, from = "A", edge = "-->", to = "B")
    expect_equal(
      edges(out),
      original[which(!(original$from == "A" & original$edge == "-->"))]
    )
    expect_equal(edges(remove_edges(cg, A %<->% B)), original)
  }
})

test_that("edge removal ignores unknown requests and accepts duplicate requests", {
  cg <- caugi(A %-->% B, B %-->% C, class = "DAG")
  out <- remove_edges(
    cg,
    from = c("missing", NA_character_, "A", "A", "A"),
    edge = c("-->", "-->", "missing", "-->", "-->"),
    to = rep("B", 5)
  )
  expect_equal(edges(out), edges(caugi(B %-->% C, class = "DAG")))
  expect_identical(nodes(out)$name, nodes(cg)$name)
  expect_equal(nrow(edges(cg)), 2)

  empty <- remove_edges(cg, from = c("B", "C"), to = c("A", "B"))
  expect_equal(nrow(edges(empty)), 0)
  expect_equal(empty@graph_class, "DAG")
  expect_identical(nodes(empty)$name, nodes(cg)$name)
  expect_equal(
    nrow(edges(remove_edges(
      cg,
      from = character(),
      edge = character(),
      to = character()
    ))),
    2
  )
  expect_equal(
    nrow(edges(remove_edges(caugi(nodes = "A", class = "DAG"), A %-->% B))),
    0
  )
})

test_that("edge removal validates CPDAG invariants after deletion", {
  cg <- caugi(A %-->% C, B %-->% C, C %-->% D, class = "CPDAG")
  expect_error(remove_edges(cg, A %-->% C), "CPDAG|protected")
  expect_equal(nrow(edges(cg)), 3)
})

test_that("edge removal uses the graph's registered edge types", {
  reset_caugi_registry()
  on.exit(reset_caugi_registry())
  register_caugi_edge("===>", "tail", "arrow", "directed", FALSE)
  cg <- caugi(from = "A", edge = "===>", to = "B", class = "DAG")
  expect_equal(
    nrow(edges(remove_edges(cg, from = "A", edge = "===>", to = "B"))),
    0
  )
  expect_equal(nrow(edges(cg)), 1)
})

test_that("set_edges replaces any existing edges for pairs", {
  # Use simple=FALSE to allow parallel edges for this test
  cg <- caugi(simple = FALSE, class = "UNKNOWN")
  cg <- add_edges(
    cg,
    from = c("A", "A"),
    edge = c("o->", "-->"),
    to = c("B", "B")
  )
  cg1 <- set_edges(cg, from = "A", edge = "<->", to = "B")
  # After verbs, session is synced automatically
  expect_true(!is.null(cg1@session))
  expect_equal(
    cg1@edges,
    data.table::data.table(from = "A", edge = "<->", to = "B")
  )
})

test_that("set_edges removes both directions in simple graphs", {
  cg <- caugi(A %-->% B, class = "DAG")
  cg1 <- set_edges(cg, B %-->% A)

  expect_equal(
    cg1@edges,
    data.table::data.table(from = "B", edge = "-->", to = "A")
  )
})

test_that("set_edges errors whwn both vector and expr paths are given", {
  # Use simple=FALSE to allow parallel edges for this test
  cg <- caugi(simple = FALSE, class = "UNKNOWN")
  cg <- add_edges(
    cg,
    from = c("A", "A"),
    edge = c("o->", "-->"),
    to = c("B", "B")
  )
  expect_error(
    set_edges(cg, A %-->% B, from = "A", edge = "<->", to = "B"),
    "Provide expressions"
  )
})

test_that("set_edges returns cg if nothing given", {
  cg <- caugi(A %-->% B, B %-->% C)
  cg2 <- set_edges(cg)

  expect_equal(cg, cg2)
})

# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────────────── Nodes ─────────────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that("add_nodes, remove_nodes cover vector and expr paths", {
  cg <- caugi()
  expect_identical(add_nodes(cg), cg)

  cg1 <- add_nodes(cg, name = c("A", "B"))
  # After verbs, session is synced automatically
  expect_true(!is.null(cg1@session))
  expect_setequal(cg1@nodes$name, c("A", "B"))

  cg2 <- add_nodes(caugi(), A + B + C)
  expect_setequal(cg2@nodes$name, c("A", "B", "C"))

  cg3 <- add_edges(cg1, from = "A", edge = "-->", to = "B")
  cg4 <- remove_nodes(cg3, name = "A")
  expect_true(!is.null(cg4@session))
  expect_equal(cg4@nodes$name, "B")
  expect_equal(nrow(cg4@edges), 0L)

  cg5 <- add_edges(cg2, A %-->% B, B %-->% C)
  cg6 <- remove_nodes(cg5)
  expect_equal(cg5, cg6) # no-op if no nodes given
})

test_that("verbs do not modify object for remove_nodes", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  nodes_before <- cg@nodes
  edges_before <- cg@edges
  new_cg <- remove_nodes(cg, "U")
  nodes_after <- cg@nodes
  edges_after <- cg@edges
  expect_equal(nodes_after, nodes_before)
  expect_equal(edges_after, edges_before)

  nodes_new_object <- new_cg@nodes
  edges_new_object <- new_cg@edges
  expect_equal(
    nodes_new_object,
    data.table::data.table(name = c("Z", "X", "Y"))
  )
  expect_equal(nrow(edges_new_object), 2L)
})

test_that("inplace parameter issues deprecation warning for remove_nodes", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  expect_warning(
    result <- remove_nodes(cg, "U", inplace = TRUE),
    "The `inplace` argument is deprecated"
  )
  # Verify it returns a new object despite inplace = TRUE
  expect_false(identical(result@session, cg@session))
})

test_that("verbs do not modify object for add_nodes", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  nodes_before <- cg@nodes
  edges_before <- cg@edges
  new_cg <- add_nodes(cg, "W")
  nodes_after <- cg@nodes
  edges_after <- cg@edges
  expect_equal(nodes_after, nodes_before)
  expect_equal(edges_after, edges_before)

  nodes_new_object <- new_cg@nodes
  edges_new_object <- new_cg@edges
  expect_equal(
    nodes_new_object,
    data.table::data.table(name = c("Z", "X", "U", "Y", "W"))
  )
  expect_equal(edges_new_object, edges_before)
})

test_that("inplace parameter issues deprecation warning for add_nodes", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  expect_warning(
    result <- add_nodes(cg, "W", inplace = TRUE),
    "The `inplace` argument is deprecated"
  )
  # Verify it returns a new object despite inplace = TRUE
  expect_false(identical(result@session, cg@session))
})

test_that("verbs do not modify object for remove_edges", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  nodes_before <- cg@nodes
  edges_before <- cg@edges
  new_cg <- remove_edges(cg, from = "U", to = "X")
  nodes_after <- cg@nodes
  edges_after <- cg@edges
  expect_equal(nodes_after, nodes_before)
  expect_equal(edges_after, edges_before)

  edges_new_object <- new_cg@edges
  expect_equal(nrow(edges_new_object), 3L)
})

test_that("inplace parameter issues deprecation warning for remove_edges", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  expect_warning(
    result <- remove_edges(cg, from = "U", to = "X", inplace = TRUE),
    "The `inplace` argument is deprecated"
  )
  # Verify it returns a new object despite inplace = TRUE
  expect_false(identical(result@session, cg@session))
})

test_that("verbs do not modify object for add_edges", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  nodes_before <- cg@nodes
  edges_before <- cg@edges
  new_cg <- add_edges(cg, Z %-->% U)
  nodes_after <- cg@nodes
  edges_after <- cg@edges
  expect_equal(nodes_after, nodes_before)
  expect_equal(edges_after, edges_before)

  edges_new_object <- new_cg@edges
  expect_equal(nrow(edges_new_object), 5L)
})

test_that("inplace parameter issues deprecation warning for add_edges", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y)
  expect_warning(
    result <- add_edges(cg, Z %-->% U, inplace = TRUE),
    "The `inplace` argument is deprecated"
  )
  # Verify it returns a new object despite inplace = TRUE
  expect_false(identical(result@session, cg@session))
})

test_that("verbs do not modify object for set_edges", {
  # Use PDAG since we want to set some edges to undirected
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y, class = "PDAG")
  nodes_before <- cg@nodes
  edges_before <- cg@edges
  new_cg <- set_edges(cg, U %---% X)
  nodes_after <- cg@nodes
  edges_after <- cg@edges
  expect_equal(nodes_after, nodes_before)
  expect_equal(edges_after, edges_before)

  edges_new_object <- new_cg@edges
  expect_true("---" %in% edges_new_object$edge)
})

test_that("inplace parameter issues deprecation warning for set_edges", {
  cg <- caugi(Z %-->% X %-->% Y, U %-->% X + Y, class = "PDAG")
  expect_warning(
    result <- set_edges(cg, U %---% X, inplace = TRUE),
    "The `inplace` argument is deprecated"
  )
  # Verify it returns a new object despite inplace = TRUE
  expect_false(identical(result@session, cg@session))
})

test_that("copy-on-write semantics isolate references", {
  cg <- caugi(A %-->% B, class = "DAG")
  alias <- cg

  # Without inplace, should create new session
  out <- add_nodes(cg, C)
  expect_false(identical(cg@session, out@session))
  expect_false("C" %in% cg@nodes$name)
  expect_true("C" %in% out@nodes$name)
})

test_that("updates clone session and isolate aliases", {
  cg <- caugi(A %-->% B, class = "DAG")
  alias <- cg

  out <- add_nodes(cg, C)

  expect_false(identical(cg@session, out@session))
  expect_false("C" %in% alias@nodes$name)
  expect_true("C" %in% out@nodes$name)
})

# ──────────────────────────────────────────────────────────────────────────────
# ───────────────────────────── Internal getters ───────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that(".get_nodes branches", {
  expect_equal(
    caugi:::.get_nodes(NULL, list()),
    data.table::data.table(name = character())
  )
  expect_error(
    caugi:::.get_nodes(
      name = "A",
      calls = list(quote(A))
    ),
    "or `name`, not both"
  )
  res <- caugi:::.get_nodes(name = c("A", "A", "B"), calls = list())
  expect_setequal(res$name, c("A", "B"))
})

test_that(".get_edges vector path and error branches", {
  expect_error(caugi:::.get_edges(
    from = "A",
    edge = NULL,
    to = "B",
    calls = list()
  ))
  expect_error(caugi:::.get_edges(
    from = c("A", "B"),
    edge = c("-->"),
    to = c("B"),
    calls = list()
  ))

  res <- caugi:::.get_edges(
    from = c("A", "A"),
    edge = c("-->", "-->"),
    to = c("B", "B"),
    calls = list()
  )
  expect_equal(nrow(res), 2L)
})

test_that(".get_edges expression path branch", {
  res <- caugi:::.get_edges(
    from = NULL,
    edge = NULL,
    to = NULL,
    calls = list(
      quote(A %-->% B),
      quote(B %---% C)
    )
  )
  expect_equal(nrow(res), 2L)
  expect_equal(res$from, c("A", "B"))
  expect_equal(res$edge, c("-->", "---"))
  expect_equal(res$to, c("B", "C"))
})

test_that(".get_edges works with empty input", {
  res <- caugi:::.get_edges(
    from = NULL,
    edge = NULL,
    to = NULL,
    calls = list()
  )
  expect_equal(nrow(res), 0L)
})

# ──────────────────────────────────────────────────────────────────────────────
# ────────────────────────── Internal build marker ─────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that(".sync_session keeps session synced", {
  cg <- caugi()
  cg <- add_nodes(cg, name = "A")
  # Session is automatically synced by .update_caugi
  expect_true(!is.null(cg@session))
})

# ──────────────────────────────────────────────────────────────────────────────
# ───────────────────────────── Internal updater ───────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that(".update_caugi add/remove paths and validations", {
  cg <- caugi()
  cg1 <- caugi:::.update_caugi(
    cg,
    nodes = data.table::data.table(
      name = c("A", "B", "B")
    ),
    action = "add"
  )
  # After verbs, session is synced automatically
  expect_true(!is.null(cg1@session))
  expect_setequal(cg1@nodes$name, c("A", "B"))

  cg2 <- caugi:::.update_caugi(
    cg1,
    edges = data.table::data.table(
      from = c("A", "A"),
      edge = c("-->", "-->"),
      to = c("B", "B")
    ),
    action = "add"
  )
  expect_equal(nrow(cg2@edges), 1L)
  expect_setequal(cg2@nodes$name, c("A", "B"))

  cg3 <- caugi()
  cg3 <- add_nodes(cg3, name = c("A", "B", "C"))
  cg3 <- add_edges(
    cg3,
    from = c("A", "B", "A"),
    edge = c("-->", "<->", "o->"),
    to = c("B", "C", "C")
  )
  cg4 <- caugi:::.update_caugi(
    cg3,
    edges = data.table::data.table(
      from = "A",
      to = "B"
    ),
    action = "remove"
  )
  expect_false(any(cg4@edges$from == "A" & cg4@edges$to == "B"))

  expect_error(
    caugi:::.update_caugi(
      cg4,
      edges = data.table::data.table(from = "B"),
      action = "remove"
    ),
    "include at least `from` and `to`."
  )
})

# ──────────────────────────────────────────────────────────────────────────────
# ─────────────────────────── Additional Coverage ──────────────────────────────
# ──────────────────────────────────────────────────────────────────────────────

test_that("remove_edges errors when cg is not simple and edge is NULL", {
  cg <- caugi(
    A %-->% B,
    A %<->% B,
    class = "ADMG",
    simple = FALSE
  )
  expect_error(
    remove_edges(cg, from = "A", to = "B"),
    "When removing edges without specifying `edge`, `cg` must be simple"
  )
})

test_that("remove_edges errors when from/to missing with NULL edge", {
  cg <- caugi(A %-->% B, class = "DAG")
  expect_error(
    remove_edges(cg, from = "A"),
    "`from` and `to` must be supplied when `edge` is omitted"
  )
  expect_error(
    remove_edges(cg, to = "B"),
    "`from` and `to` must be supplied when `edge` is omitted"
  )
})

test_that("remove_edges errors when from/to have different lengths", {
  cg <- caugi(A %-->% B + C, class = "DAG")
  expect_error(
    remove_edges(cg, from = c("A", "A"), to = "B"),
    "`from` and `to` must be equal length"
  )
})

test_that("AUTO class doesn't trigger after init", {
  cg <- caugi()
  expect_equal(cg@graph_class, "UNKNOWN")
  cg <- add_edges(cg, A %-->% B)
  expect_equal(cg@graph_class, "UNKNOWN")

  cg <- caugi(A %-->% B, class = "AUTO")
  expect_equal(cg@graph_class, "DAG")
})

test_that("node order does not matter when setting edges", {
  cg <- caugi(A %---% B, class = "PDAG")
  cg_new <- set_edges(cg, B %-->% A)

  cg_new

  expect_equal(edges(cg_new)$edge, "-->")
})

test_that("set_edges should not replace other edges when non-symmetric edge added", {
  cg <- caugi(A %-->% B, simple = FALSE, class = "UNKNOWN")
  cg_new <- set_edges(cg, B %-->% A)

  cg_correct <- caugi(A %-->% B, B %-->% A, simple = FALSE, class = "UNKNOWN")

  expect_equivalent(cg_new, cg_correct)
})

test_that("set_edges preserves opposite-direction edges in non-simple graphs", {
  cg <- caugi(A %-->% B, B %<->% A, simple = FALSE, class = "UNKNOWN")
  cg_new <- set_edges(cg, A %o->% B)

  cg_correct <- caugi(A %o->% B, B %<->% A, simple = FALSE, class = "UNKNOWN")

  expect_equivalent(cg_new, cg_correct)
})

test_that("replace-action branches in .update_caugi are covered", {
  cg <- caugi(A %-->% B, class = "DAG")
  expect_error(
    caugi:::.update_caugi(
      cg,
      nodes = data.table::data.table(name = "C"),
      edges = data.table::data.table(from = "A", edge = "-->", to = "B"),
      action = "replace"
    ),
    "nodes are not supported for `action = \"replace\"`."
  )

  expect_identical(
    caugi:::.update_caugi(
      cg,
      edges = data.table::data.table(
        from = character(),
        edge = character(),
        to = character()
      ),
      action = "replace"
    ),
    cg
  )

  # Trigger rs_set_n/rs_set_names and resolved-class update branch.
  cg_auto <- cg
  rs_set_class(cg_auto@session, "AUTO")
  out <- caugi:::.update_caugi(
    cg_auto,
    edges = data.table::data.table(from = "A", edge = "-->", to = "C"),
    action = "replace"
  )
  expect_true("C" %in% out@nodes$name)
  expect_equal(out@graph_class, "DAG")
})