tests/testthat/test-Graph.R

In rdecision: Decision Analytic Modelling in Health Economics

# tests of graph creation
test_that("incorrect node and edge types are rejected", {
  n1 <- Node$new()
  n2 <- Node$new()
  e1 <- Edge$new(n1, n2)
  #
  expect_error(Graph$new(n1, list(e1)), class = "non-list_vertices")
  expect_error(Graph$new(list(n1, n2), e1), class = "non-list_edges")
  expect_error(Graph$new(list(n1, 42L), list(e1)), class = "non-Node_vertex")
  expect_error(Graph$new(list(n1, n2), list(e1, 42L)), class = "non-Edge_edge")
  expect_error(
    Graph$new(V = list(n1, n1), E = list(e1)), class = "repeated_nodes"
  )
  expect_error(
    Graph$new(V = list(n1, n2), E = list(e1, e1)),
    class = "repeated_edges"
  )
  #
  n3 <- Node$new()
  e2 <- Edge$new(n1, n3)
  expect_error(
    Graph$new(V = list(n1, n2), E = list(e1, e2)), class = "not_in_graph"
  )
  #
  n1 <- Node$new("n1")
  n2 <- Node$new("n1")
  n3 <- Node$new()
  e1 <- Edge$new(n1, n2, "e1")
  expect_silent(Graph$new(V = list(n1, n2), E = list(e1)))
  expect_silent(Graph$new(V = list(n1, n2, n3), E = list(e1)))
  #
  n1 <- Node$new("n1")
  n2 <- Node$new("n2")
  e1 <- Edge$new(n1, n2, "e1")
  e2 <- Edge$new(n2, n1, "e1")
  e3 <- Edge$new(n1, n2)
  expect_silent(Graph$new(V = list(n1, n2), E = list(e1, e2)))
  expect_silent(Graph$new(V = list(n1, n2), E = list(e1, e2, e3)))
})

# tests of simple graph properties
test_that("basic graph properties are set and got", {
  #
  n1 <- Node$new()
  n2 <- Node$new()
  e1 <- Edge$new(n1, n2)
  # empty graph
  V <- list()
  E <- list()
  G <- Graph$new(V, E)
  expect_identical(G$order(), 0L)
  expect_identical(G$size(), 0L)
  expect_length(G$vertex_along(), 0L)
  expect_length(G$edge_along(), 0L)
  # a graph with 2 nodes and an edge
  V <- list(n1, n2)
  E <- list(e1)
  G <- Graph$new(V, E)
  expect_identical(G$order(), length(V))
  expect_identical(G$size(), length(E))
  expect_length(G$vertex_along(), 2L)
  expect_length(G$edge_along(), 1L)
  # a graph with one node
  V <- list(n1)
  E <- list()
  G <- Graph$new(V, E)
  expect_identical(G$order(), 1L)
  expect_identical(G$size(), 0L)
  expect_length(G$vertex_along(), 1L)
  expect_length(G$edge_along(), 0L)
})

# tests of vertex and edge properties
test_that("vertex and edge properties are set and got", {
  # create graph
  n1 <- Node$new()
  n2 <- Node$new()
  n3 <- Node$new()
  e1 <- Edge$new(n1, n2, label = "e1")
  e2 <- Edge$new(n1, n3)
  G <- Graph$new(V = list(n1, n2), E = list(e1))
  # check that valid vertices in the graph are identified
  expect_false(G$has_vertex(42L))
  expect_true(G$has_vertex(n1))
  expect_true(G$has_vertex(n2))
  expect_false(G$has_vertex(n3))
  # check that valid edges in the graph are identified
  expect_false(G$has_edge(42L))
  expect_true(G$has_edge(e1))
  # tests of vertex indices
  in1 <- G$vertex_index(n1)
  expect_identical(G$vertex_at(in1), n1)
  in2 <- G$vertex_index(n2)
  expect_identical(G$vertex_at(in2), n2)
  in3 <- G$vertex_index(n3)
  expect_true(is.na(in3))
  expect_error(G$vertex_at(in3), class = "invalid_index")
  expect_error(G$vertex_at(42L), class = "invalid_index")
  expect_error(G$vertex_at("42"), class = "invalid_index")
  expect_length(G$vertex_along(), 2L)
  # tests of edge indexes
  ie1 <- G$edge_index(e1)
  expect_identical(G$edge_at(ie1), e1)
  ie2 <- G$edge_index(e2)
  expect_true(is.na(ie2))
  ie3 <- G$edge_index(42L)
  expect_true(is.na(ie3))
  expect_length(G$edge_index(list()), 0L)
  # test of finding edges, given index
  expect_error(G$edge_at(42L), class = "invalid_index")
  expect_error(G$edge_at("42"), class = "invalid_index")
  expect_error(G$edge_at(ie2), class = "invalid_index")
  expect_error(G$edge_at(-1L, class = "invalid_index"))
  # tests of degree function
  expect_error(G$degree(42L), class = "invalid_vertex")
  expect_error(G$degree(n3), class = "invalid_vertex")
  expect_error(G$degree(e1), class = "invalid_vertex")
  expect_identical(G$degree(n1), 1L)
})

# tests of node and edge indexes in vector mode
test_that("vectorized node and edge indexes are as expected", {
  # create graph
  n1 <- Node$new()
  n2 <- Node$new()
  n3 <- Node$new()
  e1 <- Edge$new(n1, n2, label = "e1")
  e2 <- Edge$new(n1, n3)
  G <- Graph$new(V = list(n1, n2, n3), E = list(e1, e2))
  # vertexes
  v <- G$vertexes()
  expect_r6_setequal(v, list(n1, n2, n3))
  # vertex indexes
  in1 <- G$vertex_index(n1)
  in2 <- G$vertex_index(n2)
  in3 <- G$vertex_index(n3)
  expect_identical(G$vertex_index(list(n1, n2, n3)), c(in1, in2, in3))
  expect_identical(G$vertex_index(list(n1, 42L)), c(in1, NA_integer_))
  expect_identical(G$vertex_index(G$vertexes()), G$vertex_along())
  # vertexes at given indexes
  expect_length(G$vertex_at(vector(mode = "integer", length = 0L)), 0L)
  expect_identical(G$vertex_at(c(in1, in2)), c(n1, n2))
  expect_identical(G$vertex_at(c(in2, in1)), c(n2, n1))
  expect_identical(G$vertex_at(list(in1, in2)), c(n1, n2))
  expect_identical(G$vertex_at(list(in1, in1)), c(n1, n1))
  expect_r6_setequal(G$vertex_at(c(in1, in2, in3)), list(n1, n2, n3))
  expect_error(G$vertex_at(c(in1, NA_integer_)), class = "invalid_index")
  expect_error(G$vertex_at(c(in1, G$order() + 1L)), class = "invalid_index")
  # test vertex_at with single index forced to a list
  expect_false(is.list(G$vertex_at(in1)))
  expect_identical(G$vertex_at(in1), n1)
  expect_type(G$vertex_at(in1, as_list = TRUE), "list")
  expect_identical(G$vertex_at(in1, as_list = TRUE), list(n1))
  # vertex existence
  expect_identical(G$has_vertex(list(n1, n2)), c(TRUE, TRUE))
  expect_identical(G$has_vertex(list(n1, n1, n2)), c(TRUE, TRUE, TRUE))
  expect_identical(G$has_vertex(list(n1, n2, 42L)), c(TRUE, TRUE, FALSE))
  # edges
  e <- G$edges()
  expect_r6_setequal(e, list(e1, e2))
  # edge indexes
  ie1 <- G$edge_index(e1)
  ie2 <- G$edge_index(e2)
  expect_identical(G$edge_index(list(e1, e2)), c(ie1, ie2))
  expect_identical(G$edge_index(list(e1, 42L)), c(ie1, NA_integer_))
  expect_identical(G$edge_index(G$edges()), G$edge_along())
  # edges at given indexes
  expect_length(G$edge_at(vector(mode = "integer", length = 0L)), 0L)
  expect_identical(G$edge_at(c(ie1, ie2)), c(e1, e2))
  expect_identical(G$edge_at(c(ie2, ie1)), c(e2, e1))
  expect_identical(G$edge_at(list(ie1, ie2)), c(e1, e2))
  expect_identical(G$edge_at(list(ie1, ie1)), c(e1, e1))
  expect_error(G$edge_at(c(ie1, NA_integer_)), class = "invalid_index")
  expect_error(G$edge_at(c(ie1, G$size() + 1L)), class = "invalid_index")
  # test edge_at with single index forced to a list
  expect_false(is.list(G$edge_at(ie1)))
  expect_identical(G$edge_at(ie1), e1)
  expect_type(G$edge_at(ie1, as_list = TRUE), "list")
  expect_identical(G$edge_at(ie1, as_list = TRUE), list(e1))
  # edge existence
  expect_identical(G$has_edge(list(e1, e2)), c(TRUE, TRUE))
  expect_identical(G$has_edge(list(e1, e1, e2)), c(TRUE, TRUE, TRUE))
  expect_identical(G$has_edge(list(e1, e2, 42L)), c(TRUE, TRUE, FALSE))
})

# tests of node and edge labels
test_that("node and edge label indexes are as expected", {
  # create graph
  n1 <- Node$new()
  n2 <- Node$new(label = "n2")
  n3 <- Node$new(label = "n3")
  e1 <- Edge$new(n1, n2, label = "e1")
  e2 <- Edge$new(n1, n3)
  G <- Graph$new(V = list(n1, n2, n3), E = list(e1, e2))
  # indexes
  in1 <- G$vertex_index(n1)
  in2 <- G$vertex_index(n2)
  in3 <- G$vertex_index(n3)
  ie1 <- G$edge_index(e1)
  ie2 <- G$edge_index(e2)
  # tests of edge labels
  expect_identical(e1$label(), "e1")
  expect_identical(e2$label(), "")
  expect_identical(G$edge_label(ie1), "e1")
  expect_identical(G$edge_label(ie2), "")
  expect_error(G$edge_label(42L), class = "invalid_index")
  expect_identical(G$edge_label(c(ie1, ie2)), c("e1", ""))
  expect_error(G$edge_label(c(ie1, as.numeric(ie2))), class = "invalid_index")
  expect_identical(G$edge_label(list(ie1, ie2)), c("e1", ""))
  # tests of vertex labels
  expect_identical(n1$label(), "")
  expect_identical(n2$label(), "n2")
  expect_identical(n3$label(), "n3")
  expect_identical(G$vertex_label(in1), "")
  expect_identical(G$vertex_label(in2), "n2")
  expect_identical(G$vertex_label(in3), "n3")
  expect_error(G$vertex_label(42L), class = "invalid_index")
  expect_identical(G$vertex_label(c(in1, in2)), c("", "n2"))
  expect_error(G$vertex_label(c(in1, as.numeric(in2))), class = "invalid_index")
  expect_identical(G$vertex_label(list(in1, in2, in3)), c("", "n2", "n3"))
})

# tests of adjacency matrix
test_that("adjacency matrix has correct properties", {
  # empty graph
  G <- Graph$new(V = list(), E = list())
  expect_error(G$graph_adjacency_matrix(42L), class = "non-logical_boolean")
  A <- G$graph_adjacency_matrix()
  expect_true(is.matrix(A))
  expect_identical(nrow(A), 0L)
  expect_identical(ncol(A), 0L)
  # trivial graph
  n1 <- Node$new()
  G <- Graph$new(V = list(n1), E = list())
  A <- G$graph_adjacency_matrix()
  expect_true(is.matrix(A))
  expect_identical(nrow(A), 1L)
  expect_identical(ncol(A), 1L)
  expect_identical(A[[1L, 1L]], 0L)
  # graph with some labelled nodes should have indices as labels
  n1 <- Node$new("n1")
  n2 <- Node$new()
  e1 <- Edge$new(n1, n2)
  G <- Graph$new(V = list(n1, n2), E = list(e1))
  A <- G$graph_adjacency_matrix()
  dn <- dimnames(A)
  expect_setequal(names(dn), c("out.node", "in.node"))
  expect_setequal(dn$out.node, as.character(G$vertex_along()))
  expect_setequal(dn$in.node, as.character(G$vertex_along()))
  # graph with all nodes named should have node names as labels
  n1 <- Node$new("n1")
  n2 <- Node$new("n2")
  e1 <- Edge$new(n1, n2)
  G <- Graph$new(V = list(n1, n2), E = list(e1))
  A <- G$graph_adjacency_matrix()
  dn <- dimnames(A)
  expect_setequal(names(dn), c("out.node", "in.node"))
  expect_setequal(dn$out.node, c("n1", "n2"))
  expect_setequal(dn$in.node, c("n1", "n2"))
  expect_identical(sum(A - matrix(c(0L, 1L, 0L, 1L), nrow = 2L)), 0L)
  # binary
  n1 <- Node$new("n1")
  n2 <- Node$new("n2")
  e1 <- Edge$new(n1, n2)
  e2 <- Edge$new(n1, n1)
  G <- Graph$new(V = list(n1, n2), E = list(e1, e2))
  A <- G$graph_adjacency_matrix(boolean = FALSE)
  expect_identical(A[["n1", "n1"]], 2L)
  A <- G$graph_adjacency_matrix(boolean = TRUE)
  expect_true(A[["n1", "n1"]])
})

# tests of graph algorithms
test_that("simple and non-simple graphs are detected", {
  n1 <- Node$new()
  n2 <- Node$new()
  e1 <- Edge$new(n1, n2)
  #
  G <- Graph$new(V = list(n1, n2), E = list(e1))
  expect_true(G$is_simple())
  #
  e2 <- Edge$new(n1, n1)
  G <- Graph$new(V = list(n1, n2), E = list(e1, e2))
  expect_false(G$is_simple())
  #
  e2 <- Edge$new(n2, n1)
  G <- Graph$new(V = list(n1, n2), E = list(e1, e2))
  expect_false(G$is_simple())
})

test_that("connected and non-connected graphs are identified", {
  #
  G <- Graph$new(V = list(), E = list())
  expect_false(G$is_connected())
  #
  n1 <- Node$new()
  G <- Graph$new(V = list(n1), E = list())
  expect_true(G$is_connected())
  e1 <- Edge$new(n1, n1)
  G <- Graph$new(V = list(n1), E = list(e1))
  expect_true(G$is_connected())
  #
  n1 <- Node$new()
  n2 <- Node$new()
  n3 <- Node$new()
  e1 <- Edge$new(n1, n2)
  e2 <- Edge$new(n3, n3)
  G <- Graph$new(V = list(n1, n2, n3), E = list(e1, e2))
  expect_false(G$is_connected())
  #
  n1 <- Node$new()
  n2 <- Node$new()
  n3 <- Node$new()
  e1 <- Edge$new(n1, n2)
  e2 <- Edge$new(n1, n3)
  G <- Graph$new(V = list(n2, n3, n1), E = list(e1, e2))
  expect_true(G$is_connected())
})

test_that("cyclic and acyclic graphs are identified", {
  #
  G <- Graph$new(V = list(), E = list())
  expect_true(G$is_simple())
  expect_true(G$is_acyclic())
  #
  n1 <- Node$new()
  G <- Graph$new(V = list(n1), E = list())
  expect_true(G$is_acyclic())
  #
  n1 <- Node$new()
  e1 <- Edge$new(n1, n1)
  G <- Graph$new(V = list(n1), E = list(e1))
  expect_false(G$is_acyclic())
  #
  n0 <- Node$new("0")
  n1 <- Node$new("1")
  n2 <- Node$new("2")
  n3 <- Node$new("3")
  e1 <- Edge$new(n0, n1)
  e2 <- Edge$new(n1, n2)
  e3 <- Edge$new(n2, n3)
  #
  G <- Graph$new(V = list(n0, n1, n2, n3), E = list(e1, e2, e3))
  expect_true(G$is_acyclic())
  #
  e4 <- Edge$new(n0, n2)
  G <- Graph$new(V = list(n0, n1, n2, n3), E = list(e1, e2, e3, e4))
  expect_false(G$is_acyclic())
})

# Published examples
test_that("Fig 1.1.1 from Gross & Yellen (2013)", {
  # the graph
  u <- Node$new("u")
  v <- Node$new("v")
  w <- Node$new("w")
  x <- Node$new("x")
  a <- Edge$new(u, v, "a")
  b <- Edge$new(v, u, "b")
  c <- Edge$new(x, x, "c")
  d <- Edge$new(x, w, "d")
  e <- Edge$new(x, v, "e")
  f <- Edge$new(w, v, "f")
  G <- Graph$new(V = list(u, v, w, x), E = list(a, b, c, d, e, f))
  # counts
  expect_identical(G$order(), 4L)
  expect_identical(G$size(), 6L)
  expect_identical(G$degree(u), 2L)
  expect_identical(G$degree(v), 4L)
  expect_identical(G$degree(w), 2L)
  expect_identical(G$degree(x), 4L)
  # adjacency, noting that nodes may not be in the same order as supplied
  nodenames <- c("u", "v", "w", "x")
  EA <- matrix(
    data = c(
      0L, 2L, 0L, 0L,  2L, 0L, 1L, 1L,
      0L, 1L, 0L, 1L,  0L, 1L, 1L, 2L
    ),
    nrow = 4L, byrow = TRUE,
    dimnames = list(out.node = nodenames, in.node = nodenames)
  )
  A <- G$graph_adjacency_matrix()
  A <- A[nodenames, nodenames]
  expect_identical(A, EA)
  # neighbours
  XX <- Node$new("XX")
  expect_error(G$neighbours(XX), class = "invalid_argument")
  expect_r6_setequal(G$neighbours(u), list(v))
  expect_r6_setequal(G$neighbours(v), list(u, w, x))
  expect_r6_setequal(G$neighbours(w), list(v, x))
  expect_r6_setequal(G$neighbours(x), list(v, w))
  expect_error(G$neighbours(list(u, v)), class = "invalid_argument")
  # connected
  expect_true(G$is_connected())
  # cycle
  expect_false(G$is_acyclic())
  # tree
  expect_false(G$is_tree())
})

test_that("Fig 1.1.1 from Gross & Yellen (2013) is drawn correctly", {
  # the graph
  u <- Node$new("u")
  v <- Node$new("v")
  w <- Node$new("w")
  x <- Node$new("x")
  a <- Edge$new(u, v, "a")
  b <- Edge$new(v, u, "b")
  c <- Edge$new(x, x, "c")
  d <- Edge$new(x, w, "d")
  e <- Edge$new(x, v, "e")
  f <- Edge$new(w, v, "f")
  G <- Graph$new(V = list(u, v, w, x), E = list(a, b, c, d, e, f))
  # draw it
  expect_silent(G$as_DOT())
})