inst/extdata/scripts/entropy_trajectory_visualization2.R

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

################################################################################
## Reshaping and visualization the data from the sim.
################################################################################
#source(system.file("extdata", "entropy_trajectory_visualization.Rdata", package = "bninfo"))
library(combinat)
library(ggplot2)
library(dplyr)
library(tidyr)

load("inst/extdata/sim_results/entropy_trajectory_simulations/no_prior_edges/averaging_entropies_vanilla_3-8-16_no_bayes_1000iss.Rdata")
load("inst/extdata/sim_results/entropy_trajectory_simulations/with_prior_edges/averaging_entropies_directed_3-8-16_no_bayes_1000iss.Rdata")
load("inst/extdata/sim_results/active_learning_results/no_prior_result_3-8-16_iss1000.Rdata")
load("inst/extdata/sim_results/active_learning_results/directed_prior_result_3-8-16_iss1000.Rdata")
results <- list(averaging_entropies_vanilla,  averaging_entropies_directed)
int_targets <- c("PKC", "Akt", "PKA", "PIP2", "Mek")
permutations <- permn(int_targets)
results <- results %>%#, avg_entropies_undirected)
  lapply(function(item){
    for(i in 1:length(permutations)){
      names(item[[i]]) <- c("obs", permutations[[i]])
    }
    item
  }) %>%
  lapply(function(result){
    lapply(result, function(item){
      data.frame(first = names(item)[2],
                 second = names(item)[3],
                 third = names(item)[4],
                 fourth = names(item)[5],
                 fifth = names(item)[6],
                 obs_val = item[1],
                 first_val = item[2],
                 second_val = item[3],
                 third_val = item[4],
                 fourth_val = item[5],
                 fifth_val = item[6],
                 stringsAsFactors = F)
      })
  } %>%
    {plyr::ldply(.)})
results[[1]]$prior_info <- "none"
results[[2]]$prior_info <- "directed_edges"
#results[[3]]$prior_info <- "undirected_edges"
#results[[4]]$prior_info <- "bl_only"
#results[[5]]$prior_info <- "undirected_bl"
results_full <- tbl_df(plyr::ldply(results)) %>%
   group_by(prior_info, first) %>%
     mutate(first_val = mean(first_val)) %>%
     group_by(first, second) %>%
     mutate(second_val = mean(second_val)) %>%
     group_by(first, second, third) %>%
     mutate(third_val = mean(third_val)) %>%
     group_by(first, second, third, fourth) %>%
     mutate(fourth_val = mean(fourth_val)) %>%
     group_by(first, second, third, fourth, fifth) %>%
     mutate(fifth_val = mean(fifth_val)) %>%
     ungroup %>%
     unique %>%
    mutate(ordering = apply(.[c("first", "second", "third",
                                "fourth", "fifth")],
                            1, paste, collapse = "-")) %>%
           select(-first, -second, -third, -fourth, -fifth) %>%
    gather(experiment, entropy, obs_val:fifth_val) %>%
    mutate(experiment = ordered(experiment,
                              levels = c("obs_val", "first_val",
                                         "second_val", "third_val",
                                         "fourth_val", "fifth_val")))

result <- filter(results_full, prior_info == "directed_edges")
best_label <- directed_prior_result %$%
  selected %>%
  paste0(collapse = "-")
result <- mutate(result, type = ifelse(ordering == best_label, "best", "not_best"))
best_data <- no_prior_result$all_results[c(4, 8, 12, 16, 20)] %>%
  lapply(function(item){
    c(quantile(item, .025), mean(item), quantile(item, .975))
  }) %>%
  {do.call("rbind", .)} %>%
  data.frame %>%
  setNames(c("lower", "IG", "upper")) %>%
  {rbind(c(NA,NA,NA), .)} %>%
  {cbind(filter(result, type == "best"), .)}

ggplot(result, aes(x = experiment, y = entropy, group = ordering)) +
  geom_line(data = result,#filter(result, type != "best"),
            aes(group = ordering), alpha = 0.1) +
  ylim(c(-.05, 1)) +
  geom_line(data = best_data,
            aes(x = experiment, y = entropy, group = ordering), lwd = 1.5, colour = "red") +
  geom_line(data = best_data,
            aes(x = experiment, y = IG, group = ordering), colour = "blue") +
  geom_hline(yintercept = 0, lwd = 0.4) +
  geom_vline(xintercept = 4, lwd = 0.5, colour = "darkred") +
  geom_errorbar(data = best_data,  width=.1, colour = "blue",
                aes(x = experiment, y = IG, ymin = lower, ymax = upper, group = ordering))
########


result <- filter(results_full, prior_info == "directed_edges")
best_label <- paste0(directed_prior_result$selected, collapse="-")
result <- mutate(result, type = ifelse(ordering == best_label, "best", "not_best"))
best_data <- no_prior_result$all_results[c(4, 8, 12, 16, 20)] %>%
  lapply(function(item){
    c(quantile(item, .025), mean(item), quantile(item, .975))
  }) %>%
  {do.call("rbind", .)} %>%
  data.frame %>%
  setNames(c("lower", "IG", "upper")) %>%
  {rbind(c(NA,NA,NA), .)} %>%
  {cbind(filter(result, type == "best"), .)}

ggplot(result, aes(x = experiment, y = entropy, group = ordering)) +
  geom_line(data = filter(result, type != "best"),
            aes(group = ordering), alpha = 0.1) +
  geom_line(data = best_data,
            aes(x = experiment, y = entropy, group = ordering), lwd = 1.5, colour = "red") +
  geom_line(data = best_data,
            aes(x = experiment, y = IG, group = ordering), colour = "blue") +
  geom_hline(yintercept = 0, lwd = 0.4) +
  geom_vline(xintercept = 4, lwd = 0.5, colour = "darkred") +
  geom_errorbar(data = best_data,  width=.1, colour = "blue",
                aes(x = experiment, y = IG, ymin = lower, ymax = upper, group = ordering)) +
  ylim(c(-.05, 1))