tests/testthat/test-active_learning.R

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

#setwd("/Users/robertness/Dropbox/code/bninfo/tests/testthat")
context("active learning")
data(tcells)
intervention_array <- tcells$processed$interventions
.data <- tcells$processed$.data
test_that("When simulating new edges for a candidate,
          the simulated edges include any whitelisted edges used at the start.", {
            base_wl <- matrix(c("PKC", "Raf",
                                "PKA", "Raf",
                                "Raf", "Mek",
                                "Mek", "Erk"), ncol = 2, byrow = T)
            cl <- makeCluster(4)
            edge_probs <- boot.strength(.data, algorithm = "tabu", cluster = cl, cpdag = FALSE,
                                        algorithm.args = list(whitelist = base_wl))
            simmed_wl_starting <- sim_edge_wl(.data, edge_probs, starting_edges = base_wl,
                                              intervention_targets = c("Jnk", "Mek"))
            delta_starting <- fast_edge_table(.data, wl = simmed_wl_starting, cluster = cl)
            simmed_wl_new <- sim_edge_wl(.data, delta_starting, starting_edges = base_wl, intervention_targets = c("Jnk", "Mek", "PKA"))
            expect_equal(intersect(arcs2names(base_wl), arcs2names(simmed_wl_new)), arcs2names(base_wl))
          })


data("tcell_examples")
net <- tcell_examples$net_fit
.data <- rbn(net, n = 250)
mapk <- matrix(c("PKC", "Raf",
                 "PKA", "Raf",
                 "Raf", "Mek",
                 "Mek", "Erk"), ncol = 2, byrow = T) %>%
  set_colnames(c("from", "to"))
algo_args <- list(tabu = 50, score = "bde", prior = "cs", whitelist = mapk)

test_that("Directly learning a set ts-dags of from data will
          result in dags with some undirected edges and hence
          less orientaiton entropy", {
  selected <- "PKC"
  candidate <- "Akt"
  fitted_nets <- random_graph(names(.data), white_list = mapk, num = 30) %>%
    lapply(function(net){
      .data_boot <- sample_n(.data, nrow(.data), replace = T)
      tabu(.data_boot, start = net, whitelist = mapk, score = "bde", tabu = 50, prior = "cs")
    })
  ce_start <- lapply(fitted_nets, ctsdag, interventions = selected) %>%
    custom.strength(names(.data), cpdag = FALSE)
  ce_next <- lapply(fitted_nets, ctsdag, interventions = c(selected, candidate)) %>%
    custom.strength(names(.data), cpdag = FALSE)
  test <- mean(orientation_entropy(ce_start)) - mean(orientation_entropy(ce_next)) > 0
  expect_true(test)
})

test_that("transition sequence can be performed on an individual sampled network", {
  insurance %>%
    hc(maxp = 1) %>%
    ctsdag(c("DrivingSkill","SeniorTrain")) %>%
    list %>%
    custom.strength(names(insurance)) %>%
    orientation_entropy %>%
    sum
})



# testthat("simulated information gain (IG) under null hypothesis of no IG
#          has statistical variation", {
#            .data <- filter(ssachs, INT == 0) %>%
#              select(-INT)
#            selected <- c("Akt", "PKA", "Raf")
#            IG_null_dist <- rep(0, 10)
#            for(i in 1:10){
#              M1 <- sim_averaging(.data, M_base, selected)
#              M2 <- sim_averaging(.data, M_base, selected)
#              IG_instance <- abs(mean(M1$entropy) - mean(M2$entropy))
#              IG_null_dist[i] <- IG_instance
#            }
#            rng <- range(IG_null_dist)
#            expect_that((rng[2] - rng[1]) > 0)
#           })





testthat("Null hypothesis information gain statistic will grow increasingly farther than one as
          simulated information gain (IG) under null hypothesis of no IG
         has statistical variation", {
           .data <- filter(ssachs, INT == 0) %>%
             select(-INT)
           selected <- c("PKA", "Raf", "Akt", "P38", "Jnk")
           dists <- list()
           Ms <- list()
           for(s in 1:length(selected)){
             IG_null_dist <- rep(0, 10)
             print(s)
             for(i in 1:10){
               M1 <- sim_averaging(.data, M_base, selected[1:s])
               M2 <- sim_averaging(.data, M_base, selected[1:s])
               IG_instance <- abs(mean(M1$entropy) - mean(M2$entropy))
               IG_null_dist[i] <- IG_instance
             }
             dists[[s]] <- IG_null_dist
             Ms[[s]] <- M1
           }
           for(m in 2:length(selected)){
             expect_that(sd_vals[m] > sd_vals[m - 1])
           }
         })