tests/testthat/test-igraph-fallback.R

In dm: Relational Data Models

# Fallback vs igraph parity tests -----------------------------------------------
# Require igraph to compare results. Build a dm_graph directly to feed fallbacks.

# Helper: simple directed graph a->b->c, b->d
make_graph_abc <- function(directed = TRUE) {
  graph_from_data_frame(
    tibble::tibble(
      from = c("a", "b", "b"),
      to = c("b", "c", "d")
    ),
    directed = directed,
    vertices = c("a", "b", "c", "d")
  )
}

# Helper: directed cycle a->b->c->a
make_graph_cycle <- function() {
  graph_from_data_frame(
    tibble::tibble(
      from = c("a", "b", "c"),
      to = c("b", "c", "a")
    ),
    directed = TRUE,
    vertices = c("a", "b", "c")
  )
}

make_dm_graph_abc <- function(directed = TRUE) {
  new_dm_graph(
    directed = directed,
    vnames = c("a", "b", "c", "d"),
    from = c(1L, 2L, 2L),
    to = c(2L, 3L, 4L)
  )
}

make_dm_graph_cycle <- function() {
  new_dm_graph(
    directed = TRUE,
    vnames = c("a", "b", "c"),
    from = c(1L, 2L, 3L),
    to = c(2L, 3L, 1L)
  )
}

test_that("fallback graph_vertices matches igraph graph_vertices", {
  skip_if_not_installed("igraph")
  fb <- graph_vertices_fallback(make_dm_graph_abc())
  ig <- graph_vertices(make_graph_abc())
  expect_setequal(names(fb), names(ig))
})

test_that("fallback graph_edges matches igraph graph_edges", {
  skip_if_not_installed("igraph")
  fb <- graph_edges_fallback(make_dm_graph_abc())
  ig <- graph_edges(make_graph_abc())
  expect_equal(length(fb), length(ig))
  expect_setequal(attr(fb, "vnames"), attr(ig, "vnames"))
})

test_that("fallback graph_vcount matches igraph graph_vcount", {
  skip_if_not_installed("igraph")
  expect_equal(
    graph_vcount_fallback(make_dm_graph_abc()),
    graph_vcount(make_graph_abc())
  )
})

test_that("fallback graph_dfs matches igraph graph_dfs: visited vertices", {
  skip_if_not_installed("igraph")
  fb <- graph_dfs_fallback(make_dm_graph_abc(), "a", unreachable = FALSE, dist = TRUE)
  ig <- graph_dfs(make_graph_abc(), "a", unreachable = FALSE, dist = TRUE)
  fb_visited <- names(fb$order)[!is.na(names(fb$order))]
  ig_visited <- names(ig$order)[!is.na(names(ig$order))]
  expect_setequal(fb_visited, ig_visited)
  expect_equal(fb$dist[["a"]], ig$dist[["a"]])
  expect_equal(fb$dist[["b"]], ig$dist[["b"]])
})

test_that("fallback graph_topo_sort matches igraph graph_topo_sort: ordering constraint", {
  skip_if_not_installed("igraph")
  g_fb <- new_dm_graph(
    directed = TRUE,
    vnames = c("parent", "child"),
    from = 2L,
    to = 1L
  )
  g_ig <- graph_from_data_frame(
    tibble::tibble(from = "child", to = "parent"),
    directed = TRUE,
    vertices = c("parent", "child")
  )
  topo_fb <- names(graph_topo_sort_fallback(g_fb, mode = "in"))
  topo_ig <- names(graph_topo_sort(g_ig, mode = "in"))
  expect_lt(which(topo_fb == "parent"), which(topo_fb == "child"))
  expect_lt(which(topo_ig == "parent"), which(topo_ig == "child"))
})

test_that("fallback graph_distances matches igraph graph_distances", {
  skip_if_not_installed("igraph")
  g_fb <- make_dm_graph_abc(directed = FALSE)
  g_ig <- make_graph_abc(directed = FALSE)
  fb <- graph_distances_fallback(g_fb, "a")
  ig <- graph_distances(g_ig, "a")
  expect_equal(fb[1, "a"], ig[1, "a"])
  expect_equal(fb[1, "b"], ig[1, "b"])
})

test_that("fallback graph_induced_subgraph matches igraph: correct vertices and edges", {
  skip_if_not_installed("igraph")
  g_fb <- make_dm_graph_abc()
  g_ig <- make_graph_abc()
  sub_fb <- graph_induced_subgraph_fallback(g_fb, c("a", "b", "c"))
  sub_ig <- graph_induced_subgraph(g_ig, c("a", "b", "c"))
  expect_setequal(names(graph_vertices_fallback(sub_fb)), names(graph_vertices(sub_ig)))
  expect_equal(length(graph_edges_fallback(sub_fb)), length(graph_edges(sub_ig)))
})

test_that("fallback graph_delete_vertices matches igraph: correct vertices remain", {
  skip_if_not_installed("igraph")
  g_fb <- make_dm_graph_abc()
  g_ig <- make_graph_abc()
  r_fb <- graph_delete_vertices_fallback(g_fb, "b")
  r_ig <- graph_delete_vertices(g_ig, "b")
  expect_setequal(names(graph_vertices_fallback(r_fb)), names(graph_vertices(r_ig)))
  expect_equal(length(graph_edges_fallback(r_fb)), length(graph_edges(r_ig)))
})

test_that("fallback graph_neighbors matches igraph: mode='out'", {
  skip_if_not_installed("igraph")
  g_fb <- make_dm_graph_abc()
  g_ig <- make_graph_abc()
  fb <- graph_neighbors_fallback(g_fb, "b", mode = "out")
  ig <- graph_neighbors(g_ig, "b", mode = "out")
  expect_setequal(names(fb), names(ig))
})

test_that("fallback graph_neighbors matches igraph: mode='in'", {
  skip_if_not_installed("igraph")
  g_fb <- make_dm_graph_abc()
  g_ig <- make_graph_abc()
  fb <- graph_neighbors_fallback(g_fb, "b", mode = "in")
  ig <- graph_neighbors(g_ig, "b", mode = "in")
  expect_setequal(names(fb), names(ig))
})

test_that("fallback graph_girth: acyclic graph returns Inf", {
  skip_if_not_installed("igraph")
  fb <- graph_girth_fallback(make_dm_graph_abc())
  ig <- graph_girth(make_graph_abc())
  expect_true(is.infinite(fb$girth))
  expect_true(is.infinite(ig$girth))
  expect_equal(length(fb$circle), length(ig$circle))
})

test_that("fallback graph_girth: cycle detected matches igraph cycle length", {
  skip_if_not_installed("igraph")
  fb <- graph_girth_fallback(make_dm_graph_cycle())
  ig <- graph_girth(make_graph_cycle())
  expect_equal(fb$girth, ig$girth)
  expect_equal(length(fb$circle), length(ig$circle))
})

test_that("fallback graph_shortest_paths: predecessors count matches igraph", {
  skip_if_not_installed("igraph")
  g_fb <- make_dm_graph_abc(directed = FALSE)
  g_ig <- make_graph_abc(directed = FALSE)
  all_v <- c("a", "b", "c", "d")
  fb <- graph_shortest_paths_fallback(g_fb, "a", all_v, predecessors = TRUE)
  ig <- graph_shortest_paths(g_ig, "a", all_v, predecessors = TRUE)
  expect_equal(length(fb$predecessors), length(ig$predecessors))
  # source vertex predecessor is NA in both
  a_idx_fb <- which(names(graph_vertices_fallback(g_fb)) == "a")
  a_idx_ig <- which(names(graph_vertices(g_ig)) == "a")
  expect_true(is.na(names(fb$predecessors)[[a_idx_fb]]))
  expect_true(is.na(names(ig$predecessors)[[a_idx_ig]]))
})