tests/testthat/test-tools.R

In robertness/bninfo: Queries and information theoritic operations on Bayesian networks.

context("Tools")
data(gaussian.test)
# Confirm these results against the
test_that("edges are named correctly", {
  gaussian.test %>%
    hc %>%
    name_edges %>%
    expect_identical(c("B->D", "B->C", "A->C", "G->F", "E->F", "A->F", "D->F"))
  gaussian.test %>%
    hc %>%
    moral %>%
    name_edges %>%
    expect_identical(c("A--C", "A--F", "B--C", "B--D", "A--B",
                       "D--F", "E--F", "F--G", "A--D", "A--E",
                       "A--G", "D--E", "D--G", "E--G"))
  gaussian.test %>%
    hc %>%
    cpdag(moral = FALSE) %>%
    name_edges %>%
    expect_identical(c("A->C", "A->F", "B->C", "D->F", "E->F", "G->F", "B--D"))

  learning.test %>%
    hc %>%
    moral %>%
    name_edges %>%
    expect_identical(c("A--B", "A--D", "B--E", "C--D", "A--C", "E--F", "B--F"))

  matrix(c("ALG",  "ANL", "ALG",  "STAT", "VECT",
           "ALG", "MECH", "ALG", "ANL", "STAT"),
         ncol = 2, byrow = T, dimnames = list(NULL, c("from", "to"))) %>%
    construct_bn %>%
    cpdag(moral = FALSE) %>%
    name_edges %>%
    expect_identical(c("ALG->ANL", "ALG->STAT", "VECT->ALG", "MECH->ALG", "ANL->STAT"))
})

test_that("break_edges breaks a simple cycle", {
  matrix(c("A", "B",
           "B", "C",
           "C", "A"), ncol = 2, byrow = T) %>%
    break_cycles %>%
    graph.edgelist %>%
    is_dag %>%
    expect_true

})

test_that("break_edges breaks the cycle on the edge with lowest prob", {
  matrix(c("A", "B",
           "B", "C",
           "C", "A"), ncol = 2, byrow = T) %>%
    break_cycles(probabilities = c(.9, .4, .2)) %>%
    expect_identical(matrix(c("A", "B",
                              "B", "C",
                              "A", "C"), ncol = 2, byrow = T))
})


test_that("break_edges breaks the cycle on the edge with lowest prob", {
  mat1 <- matrix(c("B", "A",
                   "C", "B",
                   "D", "C",
                   "A", "D",
                   "D", "E",
                   "E", "F",
                   "F", "G",
                   "G", "A",
                   "C", "K",
                   "K", "B"), ncol = 2, byrow = T)
  mat2 <- matrix(c("A", "B",
                   "C", "B",
                   "D", "C",
                   "A", "D",
                   "E", "D",
                   "E", "F",
                   "F", "G",
                   "G", "A",
                   "C", "K",
                   "K", "B"), ncol = 2, byrow = T)
  mat1 %>%
    break_cycles(probabilities = c(.01, .4, .2, .4, .02, .3, .1, .2, .1, .9)) %>%
    expect_identical(mat2)
})

test_that("break_edges does not break edges with probability one. ", {
  wl <- matrix(c("B", "A",
                 "D", "C",
                 "D", "E",
                 "E", "F",
                 "F", "G"), ncol = 2, byrow = T)
  mat <- matrix(c("A", "D", #introduce A -> D -> E - > B -> A
                  "E", "B",
                  "G", "H", # introduce A -> G -> H -> J -> A
                  "H", "J",
                  "J", "A"), ncol = 2, byrow = T)
  probs <- c(rep(1, nrow(wl)), runif(nrow(mat)))
  break_cycles(rbind(wl, mat), probabilities = probs)[1:nrow(wl), ] %>%
    expect_identical(wl[1:nrow(wl), ])
})

test_that("break_cycles error out gracefully if all edges have prob 1 ", {
  mat <- matrix(c("B", "A",
                  "D", "C",
                  "D", "E",
                  "E", "F",
                  "F", "G",
                  "A", "D", #introduce A -> D -> E - > B -> A
                  "E", "B",
                  "G", "H", # introduce A -> G -> H -> J -> A
                  "H", "J", "J", "A"), ncol = 2, byrow = T)
  probs <- c(rep(1, nrow(mat)))
  e <- "There are no edges eligible for reversal. Try adjusting probabilities."
  expect_error(break_cycles(mat, probabilities = probs), e)
})

test_that("ba_whitelist passes the m argument to the preferencial attachment algo.",{
  whitelist <- as.matrix(data.frame(from = c("A", "B", "C"), to = c("B", "C", "D")))
  expect_true(narcs(ba_whitelist(LETTERS[1:10], whitelist, m = 1)) <
                narcs(ba_whitelist(LETTERS[1:10], whitelist, m = 3)))
})

test_that("ba_whitelist can be run in parallel.", {
  whitelist <- data.frame(from = c("A", "B", "C"), to = c("B", "C", "D")) %>%
    as.matrix
  lapply(1:8, ba_whitelist, nodes = LETTERS[1:10], whitelist = whitelist)
  cl <- makeCluster(4)
  parLapply(cl, 1:8, ba_whitelist, nodes = LETTERS[1:10], whitelist = whitelist)
})

test_that("random_graph passes arguments to random.graph without a whitelist,
          and passes arguments to ba_whitelist when there is a whitelist", {
            nets <- random_graph(LETTERS[1:10], num = 3, method = "ic-dag", every = 100)
            expect_true(nets[[1]]$learning$algo == "ic-dag")
            whitelist <- as.matrix(data.frame(from = c("A", "B", "C"), to = c("B", "C", "D")))
            nets <- random_graph(LETTERS[1:10], whitelist = whitelist, num = 3, m = 3)
            expect_true(nets[[1]]$learning$algo == "preferential attachment")
          })

test_that("random_graph can be run in parallel.", {
  lapply(1:8, random_graph, nodes = LETTERS[1:10], whitelist = whitelist, num = 2)
  cl <- makeCluster(4)
  parLapply(cl, 1:8, random_graph, nodes = LETTERS[1:10], whitelist = whitelist, num = 2)
})

test_that("'infer_from_start_net' works in non-intervention case.", {
  data(learning.test)
  net <- random.graph(names(learning.test), 1)
  algorithm = "hc"
  whitelist <- as.matrix(data.frame(from = c("A", "B"), to = c("B", "C")))
  algorithm.args <- list(x = learning.test, score = "bde", whitelist = whitelist)
  net <- infer_from_start_net(net, algorithm, algorithm.args)
})

test_that("'infer_from_start_net' works in intervention case", {
  data(learning.test)
  int_data <- empty.graph(names(learning.test)) %>%
    `modelstring<-`(value = "[A][C][F][B|A][D|A:C][E|B:F]") %>%
    bn.fit(learning.test, method = "bayes") %>%
    rbn_inhibition(10)
  int_array <- attr(int_data, "target")
  whitelist <- as.matrix(data.frame(from = c("A", "B"), to = c("B", "C")))
  net <- random_graph(names(learning.test), whitelist, 1)
  algorithm = "hc"
  exp <- lapply(names(int_data), function(item) which(int_array == item))
  names(exp) <- names(int_data)
  algorithm.args <- list(x = int_data, score = "mbde",
                         exp = exp, whitelist = whitelist)
  net_out <- infer_from_start_net(net[[1]], algorithm, algorithm.args)
})

test_that("'infer_from_start_net' works in parallel case", {
  data(learning.test)
  int_data <- empty.graph(names(learning.test)) %>%
    `modelstring<-`(value = "[A][C][F][B|A][D|A:C][E|B:F]") %>%
    bn.fit(learning.test, method = "bayes") %>%
    rbn_inhibition(10)
  int_array <- attr(int_data, "target")
  whitelist <- as.matrix(data.frame(from = c("A", "B"), to = c("B", "C")))
  nets <- random_graph(names(learning.test), whitelist, 10)
  algorithm = "hc"
  exp <- lapply(names(int_data), function(item) which(int_array == item))
  names(exp) <- names(int_data)
  algorithm.args <- list(x = int_data, score = "mbde",
                         exp = exp, whitelist = whitelist)
  lapply(nets, infer_from_start_net, algorithm = algorithm, algorithm.args = algorithm.args, int_array = int_array)
  cl <- makeCluster(4)
  parLapply(cl, nets, infer_from_start_net, algorithm = algorithm, algorithm.args = algorithm.args, int_array = int_array)
})

test_that("'boot_dags' works in parallel case", {
  data(learning.test)
  int_data <- empty.graph(names(learning.test)) %>%
    `modelstring<-`(value = "[A][C][F][B|A][D|A:C][E|B:F]") %>%
    bn.fit(learning.test, method = "bayes") %>%
    rbn_inhibition(10)
  int_array <- attr(int_data, "target")
  whitelist <- as.matrix(data.frame(from = c("A", "B"), to = c("B", "C")))
  exp <- lapply(names(int_data), function(item) which(int_array == item))
  names(exp) <- names(int_data)
  algorithm.args <- list(x = int_data, score = "mbde",
                         exp = exp, whitelist = whitelist)
  boot_dags(int_data, algorithm = "hc",
            algorithm.args = algorithm.args, m = 20, random.graph.args = list(m = 3))
  cl <- makeCluster(4)
  boot_dags(int_data, cluster = cl, algorithm = "hc",
            algorithm.args = algorithm.args, m = 20, random.graph.args = list(m = 3))
})