tests/testthat/test-flow.R

In igraph/rigraph: Network Analysis and Visualization

test_that("min_cut() works -- value.only=FALSE", {
  g_twosquares <- make_graph(c(1, 2, 2, 3, 3, 4, 1, 6, 6, 5, 5, 4, 4, 1))
  E(g_twosquares)$capacity <- c(3, 1, 2, 10, 1, 3, 2)
  mc <- min_cut(g_twosquares, value.only = FALSE)

  expect_equal(mc$value, 1)
  expect_equal(as.vector(mc$cut), 2)
  expect_equal(as.vector(mc$partition1), 2)
  expect_equal(as.vector(mc$partition2), c(1, 3:6))
})

test_that("min_cut() works -- value.only=TRUE", {
  g_twosquares <- make_graph(c(1, 2, 2, 3, 3, 4, 1, 6, 6, 5, 5, 4, 4, 1))
  E(g_twosquares)$capacity <- c(3, 1, 2, 10, 1, 3, 2)
  mc <- min_cut(g_twosquares, value.only = TRUE)

  expect_equal(mc, 1)
})

test_that("min_cut() works -- value.only=FALSE source/target", {
  g_twosquares <- make_graph(c(1, 2, 2, 3, 3, 4, 1, 6, 6, 5, 5, 4, 4, 1))
  E(g_twosquares)$capacity <- c(3, 1, 2, 10, 1, 3, 2)
  mc <- min_cut(g_twosquares, source = 1, target = 4, value.only = FALSE)

  expect_equal(mc$value, 2)
  expect_equal(as.vector(mc$cut), c(2, 5))
  expect_equal(as.vector(mc$partition1), c(1, 2, 6))
  expect_equal(as.vector(mc$partition2), c(3, 4, 5))
})

test_that("min_cut() works -- value.only=TRUE", {
  g_twosquares <- make_graph(c(1, 2, 2, 3, 3, 4, 1, 6, 6, 5, 5, 4, 4, 1))
  E(g_twosquares)$capacity <- c(3, 1, 2, 10, 1, 3, 2)
  mc <- min_cut(g_twosquares, source = 1, target = 4, value.only = TRUE)

  expect_equal(mc, 2)
})


test_that("min_cut() errors work", {
  g_ring <- make_ring(5, directed = TRUE, circular = TRUE)
  E(g_ring)$capacity <- c(1, 2, 3, 4, 5)
  expect_error(min_cut(g_ring, source = 1))
  expect_error(min_cut(g_ring, target = 1))
})

test_that("st_cuts() works", {
  g_path <- graph_from_literal(a -+ b -+ c -+ d -+ e)
  all_cuts_path <- st_cuts(g_path, source = "a", target = "e")
  expect_equal(unvs(all_cuts_path$cuts), list(1, 2, 3, 4))
  expect_equal(unvs(all_cuts_path$partition1s), list(1, 1:2, 1:3, 1:4))

  g_star_v7 <- graph_from_literal(s -+ a:b -+ t, a -+ 1:2:3 -+ b)
  all_cuts_star_v7 <- st_cuts(g_star_v7, source = "s", target = "t")
  expect_equal(
    unvs(all_cuts_star_v7$cuts),
    list(
      c(1, 2),
      c(1, 7),
      c(2, 3, 4, 5, 6),
      c(2, 3, 4, 5, 10),
      c(2, 3, 4, 6, 9),
      c(2, 3, 4, 9, 10),
      c(2, 3, 5, 6, 8),
      c(2, 3, 5, 8, 10),
      c(2, 3, 6, 8, 9),
      c(2, 3, 8, 9, 10),
      c(3, 7)
    )
  )
  expect_equal(
    unvs(all_cuts_star_v7$partition1s),
    list(
      1,
      c(1, 3),
      c(1, 2),
      c(1, 2, 7),
      c(1, 2, 6),
      c(1, 2, 6, 7),
      c(1, 2, 5),
      c(1, 2, 5, 7),
      c(1, 2, 5, 6),
      c(1, 2, 5, 6, 7),
      c(1, 2, 5, 6, 7, 3)
    )
  )

  g_star_v9 <- graph_from_literal(s -+ a:b -+ t, a -+ 1:2:3:4:5 -+ b)
  all_cuts_star_v9 <- st_min_cuts(g_star_v9, source = "s", target = "t")
  expect_equal(all_cuts_star_v9$value, 2)
  expect_equal(unvs(all_cuts_star_v9$cuts), list(c(1, 2), c(1, 9), c(3, 9)))
  expect_equal(
    unvs(all_cuts_star_v9$partition1s),
    list(1, c(1, 3), c(1, 3, 2, 9, 8, 7, 6, 5))
  )
})

test_that("st_cuts errors work", {
  g_path <- graph_from_literal(a -+ b -+ c -+ d -+ e)

  expect_snapshot(st_cuts(g_path, source = "a", target = NULL), error = TRUE)
  expect_snapshot(st_cuts(g_path, source = NULL, target = "a"), error = TRUE)
  expect_snapshot(
    st_min_cuts(g_path, source = "a", target = NULL),
    error = TRUE
  )
  expect_snapshot(
    st_min_cuts(g_path, source = NULL, target = "a"),
    error = TRUE
  )
})

test_that("max_flow works", {
  edge_mat <- rbind(
    c(1, 3, 3),
    c(3, 4, 1),
    c(4, 2, 2),
    c(1, 5, 1),
    c(5, 6, 2),
    c(6, 2, 10)
  )
  colnames(edge_mat) <- c("from", "to", "capacity")
  g_ring_acyc <- graph_from_data_frame(as.data.frame(edge_mat))
  flow <- max_flow(g_ring_acyc, source = "1", target = "2")
  expect_equal(flow$value, 2)
  expect_equal(as.vector(flow$flow), rep(1, 6))
  expect_setequal(as.vector(flow$cut), c(2, 4))
  expect_setequal(as.vector(flow$partition1), 1:2)
  expect_setequal(as.vector(flow$partition2), 3:6)
})

test_that("vertex_connectivity() works", {
  g_path <- make_ring(5, circular = FALSE)
  expect_equal(vertex_connectivity(g_path), 1)

  g_disconnect <- make_graph(edges = c(1, 2, 3, 4), directed = FALSE)
  expect_equal(vertex_connectivity(g_disconnect), 0)

  g_ring <- make_ring(5, circular = TRUE)
  expect_equal(vertex_connectivity(g_ring, source = 1, target = 4), 2)
})

test_that("vertex_connectivity error works", {
  g_path <- make_ring(5, circular = FALSE)
  expect_snapshot(vertex_connectivity(g_path, source = 1), error = TRUE)
})

test_that("edge_connectivity works", {
  g_full <- make_full_graph(5)
  expect_equal(edge_connectivity(g_full), 4)
  expect_equal(edge_connectivity(g_full, source = 1, target = 2), 4)

  g_path <- make_ring(5, directed = TRUE, circular = FALSE)
  expect_equal(edge_connectivity(g_path), 0)
  expect_equal(edge_connectivity(g_path, source = 1, target = 3), 1)
})

test_that("edge_connectivity works -- names", {
  g_kite <- graph_from_literal(
    Andre - Beverly:Carol:Diane:Fernando,
    Beverly - Andre:Diane:Ed:Garth,
    Carol - Andre:Diane:Fernando,
    Diane - Andre:Beverly:Carol:Ed:Fernando:Garth,
    Ed - Beverly:Diane:Garth,
    Fernando - Andre:Carol:Diane:Garth:Heather,
    Garth - Beverly:Diane:Ed:Fernando:Heather,
    Heather - Fernando:Garth:Ike,
    Ike - Heather:Jane,
    Jane - Ike
  )

  ec1 <- edge_connectivity(g_kite, source = "Heather", target = "Andre")
  expect_equal(ec1, 2)
  ec2 <- edge_connectivity(g_kite, source = "Garth", target = "Andre")
  expect_equal(ec2, 4)
  ec3 <- edge_connectivity(g_kite, source = "Garth", target = "Ike")
  expect_equal(ec3, 1)
})

test_that("edge_connectivity error works", {
  g_path <- make_ring(5, circular = FALSE)
  expect_snapshot(edge_connectivity(g_path, source = 1), error = TRUE)
})

test_that("edge_disjoint_paths works", {
  g_full <- make_full_graph(5)
  expect_equal(edge_disjoint_paths(g_full, source = 1, target = 2), 4)

  g_path <- make_ring(5, directed = TRUE, circular = FALSE)
  expect_equal(edge_disjoint_paths(g_path, source = 1, target = 3), 1)
})

test_that("edge_disjoint_paths error works", {
  g_path <- make_ring(5, circular = FALSE)
  expect_snapshot(
    edge_disjoint_paths(g_path, source = 1, target = NULL),
    error = TRUE
  )
  expect_snapshot(
    edge_disjoint_paths(g_path, source = NULL, target = 1),
    error = TRUE
  )
})

test_that("vertex_disjoint_paths works", {
  g_full <- make_full_graph(5)
  expect_equal(vertex_disjoint_paths(g_full, source = 1, target = 2), 4)

  g_path <- make_ring(5, directed = TRUE, circular = FALSE)
  expect_equal(vertex_disjoint_paths(g_path, source = 1, target = 3), 1)
})

test_that("vertex_disjoint_paths error works", {
  g_path <- make_ring(5, circular = FALSE)
  expect_snapshot(vertex_disjoint_paths(g_path, source = 1), error = TRUE)
})

test_that("adhesion works", {
  g_full <- make_full_graph(5)
  expect_equal(adhesion(g_full), 4)

  g_path <- make_ring(5, directed = TRUE, circular = FALSE)
  expect_equal(adhesion(g_path), 0)
})

test_that("vertex_disjoint_paths error works", {
  g_path <- make_ring(5, circular = FALSE)
  expect_snapshot(vertex_disjoint_paths(g_path, source = 1), error = TRUE)
})


test_that("dominator_tree works", {
  g_tree <- graph_from_edgelist(
    matrix(c(1, 2, 2, 3, 3, 4, 2, 5, 5, 6), byrow = TRUE, ncol = 2),
    directed = TRUE
  )
  dom_tree_tree <- dominator_tree(g_tree, 1)

  expect_equal(dom_tree_tree$dom[2], 1)
  expect_equal(dom_tree_tree$dom[3], 2)
  expect_equal(dom_tree_tree$dom[5], 2)
  expect_equal(dom_tree_tree$dom[6], 5)

  g_one_vertex <- make_empty_graph(n = 1, directed = TRUE)
  dom_tree_one <- dominator_tree(g_one_vertex, 1)

  expect_equal(dom_tree_one$dom[1], -1)
})

test_that("dominator_tree errors work", {
  g_tree <- graph_from_edgelist(
    matrix(c(1, 2, 2, 3, 3, 4, 2, 5, 5, 6), byrow = TRUE, ncol = 2),
    directed = TRUE
  )
  expect_snapshot(dominator_tree(g_tree), error = TRUE)
  expect_snapshot(dominator_tree(g_tree, root = NULL), error = TRUE)
})

test_that("dominator_tree works -- legacy", {
  g <- graph_from_literal(
    R -+ A:B:C, A -+ D, B -+ A:D:E, C -+ F:G, D -+ L,
    E -+ H, F -+ I, G -+ I:J, H -+ E:K, I -+ K, J -+ I,
    K -+ I:R, L -+ H
  )
  dtree <- dominator_tree(g, root = "R")
  names <- c("$root", V(g)$name)
  dtree$dom <- names[ifelse(dtree$dom < 0, 1, dtree$dom + 1)]
  dtree$leftout <- V(g)$name[dtree$leftout]
  expect_equal(
    dtree$dom,
    c("$root", "R", "R", "R", "R", "R", "C", "C", "D", "R", "R", "G", "R")
  )
  expect_equal(dtree$leftout, character())
  expect_equal(
    as_edgelist(dtree$domtree),
    structure(
      c("R", "R", "R", "R", "R", "C", "C", "D", "R", "R", "G", "R", "A", "B", "C", "D", "E", "F", "G", "L", "H", "I", "J", "K"),
      .Dim = c(12L, 2L)
    )
  )
})

test_that("min_st_separators works", {
  g_zachary <- make_graph("Zachary")
  msts <- min_st_separators(g_zachary)
  is <- sapply(msts, is_separator, graph = g_zachary)
  expect_equal(unique(is), TRUE)

  ## TODO: check that it is minimal
})

test_that("min_st_separators() works for the note case", {
  g_note <- make_graph(~ 0 - 1 - 2 - 3 - 4 - 1)
  expect_snapshot(
    min_st_separators(g_note),
    transform = function(x) gsub("from.*", "from something", x)
  )
})

test_that("Minimal s-t separators work", {
  # bug 1033045
  g <- graph_from_literal(a - -1:3 - -5 - -2:4 - -b, 1 - -2, 3 - -4)
  stsep <- min_st_separators(g)
  ims <- sapply(stsep, is_min_separator, graph = g)
  expect_equal(ims, rep(TRUE, 9))
})

test_that("min_separators works", {
  camp <- graph_from_literal(
    Harry:Steve:Don:Bert - Harry:Steve:Don:Bert,
    Pam:Brazey:Carol:Pat - Pam:Brazey:Carol:Pat,
    Holly - Carol:Pat:Pam:Jennie:Bill,
    Bill - Pauline:Michael:Lee:Holly,
    Pauline - Bill:Jennie:Ann,
    Jennie - Holly:Michael:Lee:Ann:Pauline,
    Michael - Bill:Jennie:Ann:Lee:John,
    Ann - Michael:Jennie:Pauline,
    Lee - Michael:Bill:Jennie,
    Gery - Pat:Steve:Russ:John,
    Russ - Steve:Bert:Gery:John,
    John - Gery:Russ:Michael
  )
  camp <- simplify(camp)
  sep <- min_separators(camp)
  expect_true(all(sapply(sep, is_min_separator, graph = camp)))
})

test_that("adhesion works", {
  karate <- make_graph("Zachary")
  expect_equal(adhesion(karate), 1)
  expect_equal(cohesion(karate), 1)

  kite <- graph_from_literal(
    Andre - Beverly:Carol:Diane:Fernando,
    Beverly - Andre:Diane:Ed:Garth,
    Carol - Andre:Diane:Fernando,
    Diane - Andre:Beverly:Carol:Ed:Fernando:Garth,
    Ed - Beverly:Diane:Garth,
    Fernando - Andre:Carol:Diane:Garth:Heather,
    Garth - Beverly:Diane:Ed:Fernando:Heather,
    Heather - Fernando:Garth:Ike,
    Ike - Heather:Jane,
    Jane - Ike
  )

  expect_equal(adhesion(kite), 1)
  expect_equal(cohesion(kite), 1)

  camp <- graph_from_literal(
    Harry:Steve:Don:Bert - Harry:Steve:Don:Bert,
    Pam:Brazey:Carol:Pat - Pam:Brazey:Carol:Pat,
    Holly - Carol:Pat:Pam:Jennie:Bill,
    Bill - Pauline:Michael:Lee:Holly,
    Pauline - Bill:Jennie:Ann,
    Jennie - Holly:Michael:Lee:Ann:Pauline,
    Michael - Bill:Jennie:Ann:Lee:John,
    Ann - Michael:Jennie:Pauline,
    Lee - Michael:Bill:Jennie,
    Gery - Pat:Steve:Russ:John,
    Russ - Steve:Bert:Gery:John,
    John - Gery:Russ:Michael
  )

  expect_equal(adhesion(camp), 2)
  expect_equal(cohesion(camp), 2)
})