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))
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.