tests/testthat/test-hc-ode.R

In bmihaljevic/bnclassify: Learning Discrete Bayesian Network Classifiers from Data

context("HC ODE")

test_that("augmenting ODE arcs nominal", {  
  a <- arcs_to_orphans(letters[1:4], letters[6:10])
  expect_equal(nrow(a), 6 * 2 + 20)
  expect_equal(a, unique(a))
})

test_that("augmenting ODE arcs no orphans", {  
  a <- arcs_to_orphans(NULL, letters[6:10])
  expect_null(a)
})

test_that("augmenting ODE arcs overlapping", {  
  expect_error(arcs_to_orphans(letters[1:6], letters[6:10]), 'disjoint')
})

test_that("augmenting ODE arcs no non-orphans", {  
  a <- arcs_to_orphans(letters[1:6], NULL)
  expect_equal(nrow(a), 15 * 2)
  expect_equal(a, unique(a))
})

test_that("Remove cycles single cycle", {
  nb <- nbcarp(car[, 5:7])
  nb <- add_feature_parents('lug_boot', 'safety', nb) 
  a <- arcs_to_orphans('lug_boot', 'safety')
  d <- discard_cycles(a, nb)
  expect_equal(nrow(d), 0)
})

test_that("Remove cycles two cycles", {
  nb <- nbcarp(car[, 4:7])
  nb <- add_feature_parents('lug_boot', 'safety', nb)
  nb <- add_feature_parents('lug_boot', 'persons', nb) 
  a <- arcs_to_orphans('lug_boot', c('safety', 'persons'))
  d <- discard_cycles(a, nb)
  expect_equal(nrow(d), 0)
})

test_that("Remove cycles: cycles and non-cycle", {
  nb <- nbcarp(car[, 4:7])
  nb <- add_feature_parents('lug_boot', 'safety', nb)
  a <- arcs_to_orphans(c('lug_boot', 'persons'), 'safety')
  d <- discard_cycles(a, nb) 
  a <- as.matrix(a)
  expect_equivalent(d, a[-1, ])
  expect_equivalent(d[1, ], c('safety', 'persons'))
})

test_that("Discard perms two-column mat", {
  m <- matrix(c('a', 'b', 'b', 'a'), ncol = 2)
  n <- discard_reversed(m)  
  expect_equal(n, m[2, , drop = FALSE])
})

test_that("Discard perms empty mat", {
  m <- matrix(character(), ncol = 2)
  n <- discard_reversed(m)  
  expect_equal(ncol(n), 2)
  expect_equal(nrow(n), 0)
})

test_that("augment arcs nominal", {
  nb <- nbcar()
  a <- augment_ode_arcs(nb)
  expect_equal(nrow(a), 15)
})

test_that("augment arcs no features", {
  nb <- nbcarclass()
  expect_error(augment_ode_arcs(nb), "orphans")
})

test_that("augment arcs no arcs", {
  nb <- nbcarp(car[, 6:7])
  a <- augment_ode_arcs(nb)
  expect_equal(nrow(a), 0)
})

test_that("augment arcs one arc nominal", {
  nb <- nbcarp(car[, 5:7])
  a <- augment_ode_arcs(nb)
  expect_equal(nrow(a), 1)
  expect_equal(a[1, ], c(from = 'safety', to = 'lug_boot'))
})

test_that("augment arcs one arc nominal", {
  nb <- nbcarp(car[, -(3:5)])
  a <- augment_ode_arcs(nb)
  expect_equal(nrow(a), 3)
})

test_that("augment arcs", {
  nb <- nbcarp(car[, 4:7])
  nb <- add_feature_parents('lug_boot', 'safety', nb)
  a <- augment_ode_arcs(nb)
  expect_equal(nrow(a), 2)
  expect_equal(a[1, ], c(from = 'safety', to = 'persons'))
  expect_equal(a[2, ], c(from = 'lug_boot', to = 'persons'))
})

test_that("augment ode nominal", {
  nb <- nbcar()
  anbs <- augment_ode(nb)
  expect_equal(length(anbs), 15)
})

test_that("augment ode iterate", {
  nb <- nbcarp(car[ , 4:7])
  anbs <- augment_ode(nb)
  expect_equal(length(anbs), 3)
  
  nb <- anbs[[1]]
  anbs <- augment_ode(nb)
  expect_equal(length(anbs), 2)
  
  nb <- anbs[[1]]
  anbs <- augment_ode(nb)
  expect_equal(length(anbs), 0)
})

test_that("Superparents nominal", {  
  nb <- nbcar()
  a <- superparent_children(nb)
  expect_equal(length(a), 6)
  expect_equal(a[[1]], setdiff(features(nb), 'buying'))
  expect_equal(a[[6]], setdiff(features(nb), 'safety'))
})

test_that("Superparents one feature", {  
  nb <- nbcarp(car[, 6:7])
  a <- superparent_children(nb)
  expect_null(a)
})

test_that("Superparents no orphans", {  
  nb <- nbcarp(car[, 5:7])
  nb <- add_feature_parents('safety', 'lug_boot', nb)
  a <- superparent_children(nb)
  expect_null(a)
})

test_that("augment ode hc nominal", {
  nb <- nbcar()
  mem <- make_cpts_cache(car, smooth = 0.01)
  a <- augment_ode_sp(nb, NULL, train = list(mem, mem), test = list(car, car))
  expect_equal(length(a), 5)  
})
  
test_that("Discard existing", {
  nb <- nbcarp(car) 
  arcs <- arcs_to_orphans(features(nb), character()) 
  d <- discard_existing(arcs, nb)
  expect_equal(nrow(d), nrow(arcs))
  
  nb <- add_feature_parents('lug_boot', 'safety', nb)  
  d <- discard_existing(arcs, nb)
  expect_equal(nrow(d), nrow(arcs) - 1) 
})