tests/testthat/test-transition_sequence.R

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

context("transition sequence")
base <- empty.graph(LETTERS[1:5])
net1 <- `modelstring<-`(base, value = "[A|C][B|C][D|C][E|D][C]")
net2 <- `modelstring<-`(base, value = "[A|C][B|C][C|D][E|D][D]")
net3 <- `modelstring<-`(base, value = "[A|C][B|C][C|D][D|E][E]")
net4 <- `modelstring<-`(base, value = "[A|C][C|B][D|C][E|D][B]")
net5 <- `modelstring<-`(base, value = "[C|A][B|C][D|C][E|D][A]")

test_that("These are each of the same equivalence class.", {
  expect_true(all.equal(cpdag(net1, F), cpdag(net2, F)))
  expect_true(all.equal(cpdag(net2, F), cpdag(net3, F)))
  expect_true(all.equal(cpdag(net3, F), cpdag(net4, F)))
  expect_true(all.equal(cpdag(net4, F), cpdag(net5, F)))
})

test_that("ctsdag is equivalent to cpdag if no interventions and no prior are given", {
  expect_true(all.equal(cpdag(net1), ctsdag(net1, NULL)))
})

#An intervention on C in net1 should not change anything, because D -> E is coerced otherwise it would introduce a v-structure.
#Similar results are true for net4 and net5
#An intervention on C in net2 and net3 produce the same tsdag, with E-D undirected

tsdag_23_C <- base
arcs(tsdag_23_C) <- matrix(c("C", "A",
                             "C", "B",
                             "D", "C",
                             "E", "D",
                             "D", "E"), byrow = T, ncol = 2)
#graphviz.plot(tsdag_23_C)

#An intervention in A in net5 should produce the same graph, again because of avoidance of v-structures.
#An intervention in A for the other nets should produce undirected edges in all but the incoming edge to A.

tsdag_1234_A <- base
arcs(tsdag_1234_A) <- matrix(c("C", "A",
                               "C", "B",
                               "B", "C",
                               "D", "C",
                               "C", "D",
                               "E", "D",
                               "D", "E"), byrow = T, ncol = 2)
#graphviz.plot(tsdag_1234_A)

test_that("An intervention in C should not change networks 1, 4, and 5", {
  expect_true(all.equal(ctsdag(net1, "C"), net1))
  expect_true(all.equal(ctsdag(net4, "C"), net4))
  expect_true(all.equal(ctsdag(net5, "C"), net5))
})

test_that("An intervention on C in nets 2 and 3 should produce net 23", {
  expect_true(all.equal(ctsdag(net2, "C"), tsdag_23_C))
  expect_true(all.equal(ctsdag(net3, "C"), tsdag_23_C))
})

test_that("An intervention on A in nets 1, 2, and 3 should produce net 1234", {
  expect_true(all.equal(ctsdag(net1, "A"), tsdag_1234_A))
  expect_true(all.equal(ctsdag(net2, "A"), tsdag_1234_A))
  expect_true(all.equal(ctsdag(net3, "A"), tsdag_1234_A))
  expect_true(all.equal(ctsdag(net4, "A"), tsdag_1234_A))
})

test_that("An intervention on A in net 5 should not change net 5", {
  expect_true(all.equal(ctsdag(net5, "A"), net5))
})

base <- empty.graph(LETTERS[1:8])
net_long <- `modelstring<-`(base, value = "[A][C|A][B|C][D|C][E|D][F|E][G|F][H|G]")

#graphviz.plot(cpdag(net_long, F))

test_that("An intervention on C in net long will orient the cascade", {
  expect_true(nrow(undirected.arcs(cpdag(net_long, F))) == 14)
  expect_true(all.equal(ctsdag(net_long, "C"), net_long))
})

# Repeating on Pearl's original examples
base <- empty.graph(LETTERS[1:5])
net1 <- `modelstring<-`(base, value = "[E|C][D|B:C][C|A][B|A][A]")
net2 <- `modelstring<-`(base, value = "[B|A][D|B:C][E|C][A|C][C]")
net3 <- `modelstring<-`(base, value = "[B|A][D|B:C][C|E][A|C][E]")
net4 <- `modelstring<-`(base, value = "[A|B][D|B:C][C|A][E|C][B]")

test_that("These are each of the same equivalence class.", {
  expect_true(all.equal(cpdag(net1, F), cpdag(net2, F)))
  expect_true(all.equal(cpdag(net2, F), cpdag(net3, F)))
  expect_true(all.equal(cpdag(net3, F), cpdag(net4, F)))
})

test_that("Networks 1, 2, and 3 are equivalent under intervention on B", {
  expect_true(all.equal(ctsdag(net1, "B"), ctsdag(net2, "B")))
  expect_true(all.equal(ctsdag(net2, "B"), ctsdag(net3, "B")))
})

# Now testing with priors

beta <- as.data.frame(arcs(net1), stringsAsFactors = F)
beta$prob <- runif(narcs(net1))
beta

test_that("ctsdag is NOT equivalent to cpdag if no interventions and no prior are given", {
  expect_true(all.equal(cpdag(net1), ctsdag(net1, NULL, NULL)))
  expect_true(all.equal(cpdag(net1), ctsdag(net1, NULL, beta = beta))== "Different number of directed/undirected arcs")
})

test_that("ctsdag with a non-null beta arg, applied to two graphs that would otherwise have
          the same equivalence class, will NOT produce the same PDAG if the edges that differ
          between them have different prior edge probabilities. (no interventions in this test)", {
            expect_true(all.equal(ctsdag(net1), ctsdag(net2)))
            expect_true(all.equal(ctsdag(net1), ctsdag(net2, beta=beta)) == "Different number of directed/undirected arcs")
            expect_true(all.equal(ctsdag(net2), ctsdag(net3)))
            expect_true(all.equal(ctsdag(net2, beta = beta), ctsdag(net4, beta=beta)) == "Different arc sets")
            expect_true(all.equal(ctsdag(net3), ctsdag(net4)))
            expect_true(all.equal(ctsdag(net3, beta = beta), ctsdag(net4, beta=beta)) == "Different arc sets")
})

test_that("ctsdag with a non-null beta arg, applied to two graphs that would otherwise have
          the same equivalence class, WILL produce the same PDAG if the edges that differ
          between them have the same prior edge probabilities. (no interventions in this test)", {
            beta2 <- beta
            beta2[4, ]$prob <- .4 # C -> A differs btw net1 and net2
            beta2 <- rbind(beta2, c("C", "A", .4))
            beta2$prob <- as.numeric(beta2$prob)
            expect_true(all.equal(ctsdag(net1), ctsdag(net2)))
            expect_true(all.equal(ctsdag(net1, beta = beta2), ctsdag(net2, beta=beta2)))
            beta3 <- beta
            beta3[1, ]$prob <- .6 # C -> E
            beta3 <- rbind(beta3, c("E", "C", .6))
            beta3$prob <- as.numeric(beta3$prob)
            expect_true(all.equal(ctsdag(net2), ctsdag(net3)))
            expect_true(all.equal(ctsdag(net2, beta = beta3), ctsdag(net3, beta=beta3)))
})
net1 <- `modelstring<-`(base, value = "[A|C][B|C][D|C][E|D][C]")
net2 <- `modelstring<-`(base, value = "[A|C][B|C][C|D][E|D][D]")
net3 <- `modelstring<-`(base, value = "[A|C][B|C][C|D][D|E][E]")
net4 <- `modelstring<-`(base, value = "[A|C][C|B][D|C][E|D][B]")
net5 <- `modelstring<-`(base, value = "[C|A][B|C][D|C][E|D][A]")
test_that("ctsdag with a non-null beta arg, applied to two graphs that would otherwise have
          the same equivalence class, WILL produce the same PDAG if the edges that differ
          between them have the same prior edge probabilities. (no interventions in this test).
          This is the same test as before except we omit the common arc(s), so we test that the
          CS prior will coerce the to be the same.", {
            beta2 <- beta[-3, ]
            expect_true(all.equal(ctsdag(net1), ctsdag(net2)))
            expect_true(all.equal(ctsdag(net1, beta = beta2), ctsag(net2, beta=beta2)))
            beta3 <- beta[-4, ]
            expect_true(all.equal(ctsdag(net2), ctsdag(net3)))
            expect_true(all.equal(ctsdag(net2, beta = beta3), ctsdag(net3, beta=beta3)))
            beta4 <- beta[-c(3, 4), ]
            expect_true(all.equal(ctsdag(net3), ctsdag(net4)))
            expect_true(all.equal(ctsdag(net3, beta = beta4), ctsdag(net4, beta=beta4)))
            beta5 <- beta[-c(1, 2), ]
            expect_true(all.equal(ctsdag(net5), ctsdag(net5)))
            expect_true(all.equal(ctsdag(net5, beta = beta5), ctsdag(net5, beta = beta5)))
})

test_that("An intervention on C in nets 2 and 3 should produce net 23", {
  expect_true(all.equal(ctsdag(net2, "C"), tsdag_23_C))
  expect_true(all.equal(ctsdag(net3, "C"), tsdag_23_C))
})

new_net <- ctsdag(net1, "A")
new_beta <- as.data.frame(arcs(new_net)[c(4, 7), ])
new_beta$prob <- runif(2)
arcs(new_net) <- arcs(new_net)[-7, ] # remove E->D so only D->E remains.
test_that("An intervention on A, and a skewed prior on D-E on nets 1, 2, 3, 4,
          should produce the same net except for net 3, where the E-D edge is E->D not D<-E", {
  expect_true(all.equal(ctsdag(net1, "A", new_beta), new_net))
  expect_true(all.equal(ctsdag(net2, "A", new_beta), new_net))
  expect_true(all.equal(ctsdag(net3, "A", new_beta), new_net)) # Because of avoiding introducing V-structure
  expect_true(all.equal(ctsdag(net4, "A", new_beta), new_net))
})

base <- empty.graph(LETTERS[1:8])
net_long <- `modelstring<-`(base, value = "[A][C|A][B|C][D|C][E|D][F|E][G|F][H|G]")

#graphviz.plot(cpdag(net_long, F))
beta <- data.frame(from = "E", to = "F", prob = ".3")
test_that("A skewed prior on E->F will prevent F->G, and G->H from being undirected
          as changing these would produce a v-structure.", {
            net_long_pdag <- base
            arcs(net_long_pdag) <- arcs(cpdag(net_long))[-c(10, 12, 14),]
            expect_true(all.equal(ctsdag(net_long, beta = beta), net_long_pdag))
})

test_that("An intervention on C in net long will orient the cascade despite beta", {
  expect_true(nrow(undirected.arcs(cpdag(net_long, F))) == 14)
  expect_true(all.equal(ctsdag(net_long, "C", beta = beta), net_long))
})