model.full.to.short = c(
  'lstm'='LSTM',
  'nac'='$\\mathrm{NAC}_{+}$',
  'nac-nac-n'='$\\mathrm{NAC}_{\\bullet}$',
  'posnac-nac-n'='$\\mathrm{NAC}_{\\bullet,\\sigma}$',
  'reregualizedlinearposnac-nac-n'='$\\mathrm{NAC}_{\\bullet,\\mathrm{NMU}}$',
  'nalu'='NALU',
  'reregualizedlinearnac'='NAU',
  'reregualizedlinearnac-nac-m'='NMU'
)

model.latex.to.exp = c(
  '$\\mathrm{NAC}_{+}$'=expression(paste("", "", plain(paste("NAC")),
                                         phantom()[{
                                           paste("", "+")
                                         }], "")),
  '$\\mathrm{NAC}_{+,R_z}$'=expression(paste("", "", plain(paste("NAC")),
                                         phantom()[{
                                           paste("", "+", ",", "R", phantom()[{
                                             paste("z")
                                           }])
                                         }], "")),
  '$\\mathrm{NAC}_{\\bullet}$'=expression(paste("", "", plain(paste("NAC")),
                                           phantom()[{
                                             paste("", symbol("\xb7"))
                                           }], "")),
  '$\\mathrm{NAC}_{\\bullet,\\sigma}$'=expression(paste("", "", plain(paste("NAC")),
                                                        phantom()[{
                                                          paste("", symbol("\xb7"), ",", sigma)
                                                        }], "")),
  '$\\mathrm{NAC}_{\\bullet,\\mathrm{NMU}}$'=expression(paste("", "", plain(paste("NAC")),
                                                              phantom()[{
                                                                paste("", symbol("\xb7"), ",", plain(paste("NMU")))
                                                              }], "")),
  'LSTM'='LSTM',
  'NALU'='NALU',
  'NAU'='NAU',
  'NMU'='NMU'
)

model.to.exp = function(v) {
  return(unname(revalue(v, model.latex.to.exp)))
}

operation.full.to.short = c(
  'op-cumsum'='cumsum',
  'op-cumprod'='cumprod'
)

extract.by.split = function (name, index, default=NA) {
  split = strsplit(as.character(name), '_')[[1]]
  if (length(split) >= index) {
    return(split[index])
  } else {
    return(default)
  }
}

range.full.to.short = function (range) {
  range = substring(range, 3)

  if (substring(range, 0, 1) == '[') {
    return(paste0('U', gsub('\\]-\\[', '] ∪ U[', gsub(' ', '', range))))
  } else {
    return(paste0('U[', gsub('^,', '-', gsub('-', ',', range)), ']'))
  }
}

regualizer.get.part = function (regualizer, index) {
  split = strsplit(regualizer, '-')[[1]]
  return(as.double(split[index + 1]))
}

regualizer.get.type = function (regualizer, index) {
  split = strsplit(regualizer, '-')[[1]]
  return(split[index + 1])
}

regualizer.scaling.get = function (regualizer, index) {
  split = strsplit(regualizer, '-')[[1]]
  return(as.numeric(split[index + 1]))
}

dataset.get.part = function (dataset, index, simple.value) {
  split = strsplit(dataset, '-')[[1]]
  if (split[2] == 'simple') {
    return(simple.value)
  } else {
    return(as.numeric(split[index + 1]))
  }
}

model.get.mnist.setup = function (model) {
  split = strsplit(model, '-')[[1]]
  if (split[2] == 'l') {
    return('linear')
  } else if (split[2] == 's') {
    return('softmax')
  } else {
    return(NA)
  }
}

model.get.simplification.setup = function (model) {
  split = strsplit(model, '-')[[1]]
  if (split[3] == 'n') {
    return('none')
  } else if (split[3] == 's') {
    return('solved-accumulator')
  } else if (split[3] == 'p') {
    return('pass-though')
  } else {
    return(NA)
  }
}

extrapolation.loss.name.to.integer = function (loss.name) {
  split = strsplit(loss.name, '\\.')[[1]]
  return(as.integer(split[4]))
}

expand.name = function (df) {
  names = data.frame(name=unique(df$name))

  df.expand.name = names %>%
    rowwise() %>%
    mutate(
      model=revalue(extract.by.split(name, 1), model.full.to.short, warn_missing=FALSE),
      digits=substring(extract.by.split(name, 2), 3),
      hidden.size=as.integer(substring(extract.by.split(name, 3), 3)),
      operation=revalue(extract.by.split(name, 4), operation.full.to.short, warn_missing=FALSE),

      oob.control = ifelse(substring(extract.by.split(name, 5), 5) == "r", "regualized", "clip"),
      regualizer.scaling = regualizer.get.type(extract.by.split(name, 6), 1), # rs[1]
      regualizer.shape = regualizer.get.type(extract.by.split(name, 6), 2), # rs[2]
      epsilon.zero = as.numeric(substring(extract.by.split(name, 7), 5)),

      regualizer.scaling.start=regualizer.scaling.get(extract.by.split(name, 8), 1),
      regualizer.scaling.end=regualizer.scaling.get(extract.by.split(name, 8), 2),

      regualizer=regualizer.get.part(extract.by.split(name, 9), 1),
      regualizer.z=regualizer.get.part(extract.by.split(name, 9), 2),
      regualizer.oob=regualizer.get.part(extract.by.split(name, 9), 3),

      model.mnist = model.get.mnist.setup(extract.by.split(name, 10)),
      model.final = model.get.simplification.setup(extract.by.split(name, 10)),

      interpolation.length=as.integer(substring(extract.by.split(name, 11), 3)),
      extrapolation.length=substring(extract.by.split(name, 12), 3),

      batch.size=as.integer(substring(extract.by.split(name, 13), 2)),
      seed=as.integer(substring(extract.by.split(name, 14), 2))
    )

  df.expand.name$name = as.factor(df.expand.name$name)
  df.expand.name$operation = factor(df.expand.name$operation, c('cumsum', 'cumprod'))
  df.expand.name$model = as.factor(df.expand.name$model)

  return(merge(df, df.expand.name))
}


# Script to create histogram of eta values
# ShinyMixR will add a vector with the selected models, e.g.:
# models <- c("run1","run2")
library(ggplot2)
lapply(models,function(x){
  dat  <- readRDS(paste0("./shinyMixR/",x,".res.rds"))
  etav <- nlme::ranef(dat)[, -1];
  if(length(names(etav))!=0){
    pll <- lapply(names(etav),function(pl){
      ggplot(etav,aes_string(pl)) + geom_histogram(fill="grey",color="black") + labs(title=pl)
    })
    dir.create(paste0("./analysis/",x),showWarnings=FALSE)
    R3port::html_plot(pll,out=paste0("./analysis/",x,"/hist.eta.html"),show=FALSE,title="ETA distribution")
  }
})


context("mr system")
library(simulateGP)

test_that("create system", {

	dat <- create_system(nidx=1000, nidy=1000, nidu=0, nu=0, na=0, nb=0, var_x.y=0.1, nsnp_x=100, var_gx.x=0.1, var_gx.y=0, mu_gx.y=0, prop_gx.y=1, nsnp_y=0, var_gy.y=0, var_gy.x=0, mu_gy.x=0, prop_gy.x=1)
	expect_true(is.list(dat))
})

test_that("init_parameters", {

	dat <- init_parameters(var_x.y=0.1, nsnp_x=100, var_gx.x=0.1, var_gx.y=0, mu_gx.y=0, prop_gx.y=1, nsnp_y=0, var_gy.y=0, var_gy.x=0, mu_gy.x=0, prop_gy.x=1)
	expect_true(is.list(dat))

	dat <- add_u(dat, nsnp_u=100, var_u.x=0.1, var_u.y=0.1, var_gu.u=0.1)
	expect_true(is.list(dat))

	dat2 <- sample_system_effects(dat)
	expect_true(is.list(dat2))

	dat3 <- simulate_population(dat2, 1000)
	expect_true(is.list(dat3))

	dat4 <- estimate_system_effects(dat3)
	expect_true(is.list(dat4))
})

test_that("test_system", {

	skip("need random forest")
	ss <- create_system(nidx=10000, nidy=10000, nidu=0, nu=0, na=0, nb=0, var_x.y=0.1, nsnp_x=10, var_gx.x=0.1, var_gx.y=0, mu_gx.y=0, prop_gx.y=1, nsnp_y=10, var_gy.y=0.1, var_gy.x=0, mu_gy.x=0, prop_gy.x=1)
	res <- test_system(ss)
	expect_true(is.list(res))
})


#Spectrum costs
library(tidyverse)
require("ggrepel")
library(ggpubr)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

data <- read.csv(file.path(folder, 'data_inputs', 'spectrum_costs_old.csv'))

data$income = factor(data$income, levels=c("High", "Upper Middle", "Lower Middle", "Unknown"))

coverage <- data[data$type == "coverage",]

coverage$group = factor(coverage$group, levels=c("High", "Median", "Low"))

coverage <- ggplot(coverage, aes(x=year, y=dollars.mhz.pop, colour=income, shape=group))  +
  geom_point(size=3) +
  geom_label_repel(aes(label = iso3), size = 3) +
  scale_x_continuous(expand = c(0, 0.1), limits = c(2008,2017),
                     breaks= c(2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017)) +
  scale_y_continuous(expand = c(0, 0.1)) +
  annotate("text", x = 2009.2, y = 2.86, label = "Extreme", vjust=-1) +
  geom_hline(yintercept=2.86, linetype="dashed", color = "grey", size=.5) +
  annotate("text", x = 2009.2, y = 1.88, label = "Outliers", vjust=-1) +
  geom_hline(yintercept=1.88, linetype="dashed", color = "grey", size=.5) +
  annotate("text", x = 2009.2, y = 0.91, label = "High", vjust=-1) +
  geom_hline(yintercept=0.91, linetype="dashed", color = "grey", size=.5) +
  annotate("text", x = 2009.2, y = 0.58, label = "Median", vjust=-1) +
  geom_hline(yintercept=0.58, linetype="dashed", color = "grey", size=.5) +
  theme(axis.text.x = element_text(angle = 30)) +
  guides(colour=guide_legend(title="Income"), shape=guide_legend(title="Price")) +
  labs(title = "Coverage spectrum prices comprising 700 MHz, 800 MHz, 850 MHz and 900 MHz",
       x=NULL,
       y='$ / MHz / Per Capita (USD)',
       subtitle = "Prices adjusted for PPP exchange rates, inflation and license duration, and include annual fees."
       )

capacity <- data[data$type == "capacity",]

capacity$group = factor(capacity$group, levels=c("Extreme outlier", "Outlier", "High", "Median", "Low"))

capacity <- ggplot(capacity, aes(x=year, y=dollars.mhz.pop, colour=income, shape=group))  +
  geom_point(size=3) +
  geom_label_repel(aes(label = iso3), size = 3) +
  scale_x_continuous(expand = c(0, 0.1),  limits = c(2008,2017),
                     breaks= c(2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017)) +
  scale_y_continuous(expand = c(0, 0.035)) +
  annotate("text", x = 2009.2, y = 1.26, size=3.5,label = "Extreme", vjust=-1) +
  geom_hline(yintercept=1.26, linetype="dashed", color = "grey", size=.5) +
  annotate("text", x = 2009.2, y = 0.80, size=3.5,label = "Outliers", vjust=-1) +
  geom_hline(yintercept=0.80, linetype="dashed", color = "grey", size=.5) +
  annotate("text", x = 2009.2, y = 0.35, size=3.5,label = "High", vjust=-1) +
  geom_hline(yintercept=0.35, linetype="dashed", color = "grey", size=.5) +
  annotate("text", x = 2009.2, y = 0.13, size=3.5,label = "Median", vjust=-1) +
  geom_hline(yintercept=0.13, linetype="dashed", color = "grey", size=.5) +
  theme(axis.text.x = element_text(angle = 30)) +
  guides(colour=guide_legend(title="Income"), shape=guide_legend(title="Price")) +
  labs(title = "Capacity spectrum prices comprising AWS, PCS, 1800 MHz, 2100 MHz and 2600 MHz",
       x=NULL,
       y='$ / MHz / Per Capita (USD)',
       subtitle = "Prices adjusted for PPP exchange rates, inflation and license duration, and include annual fees."
      )

panel <- ggarrange(coverage, capacity, ncol = 1, nrow = 2, align = c("hv"), common.legend = TRUE, legend="bottom")

path = file.path(folder, 'figures', 'panel.png')
ggsave(path, units="in", width=8, height=12)
print(panel)
dev.off()

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

data <- read.csv(file.path(folder, 'data_inputs', 'spectrum_by_cluster_country.csv'))

data$income[data$Country == 'Uganda'] <- 'Lower'
data$income[data$Country == 'Malawi'] <- 'Lower'
data$income[data$Country == 'Kenya'] <- 'Lower Middle'
data$income[data$Country == 'Senegal'] <- 'Lower Middle'
data$income[data$Country == 'Pakistan'] <- 'Lower Middle'
data$income[data$Country == 'Albania'] <- 'Upper Middle'
data$income[data$Country == 'Peru'] <- 'Upper Middle'
data$income[data$Country == 'Mexico'] <- 'Upper Middle'

data$income = factor(data$income, levels=c("Upper Middle", "Lower Middle", "Lower"))

cluster_prices <- ggplot(data, aes(x=Year, y=usd_per_mhz_per_pop, colour=income))  +
  geom_point(size=3) +
  geom_label_repel(aes(label = Country), size = 3) +
  scale_x_continuous(limits = c(2010,2018),
                     breaks= c(2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018)) +
  scale_y_continuous(limits=c(0, 0.2)) +
  theme(axis.text.x = element_text(angle = 30)) +
  guides(colour=guide_legend(title="Income")) +
  labs(title = "Spectrum Prices", x=NULL, y='$ / MHz / Per Capita (USD)')

#export to folder
path = file.path(folder, 'figures', 'cluster_prices.png')
ggsave(path, units="in", width=8, height=8)
print(cluster_prices)
dev.off()

subset <- select(data, Country, usd_per_mhz_per_pop)

mean_spectrum_prices <- aggregate(x = subset$usd_per_mhz_per_pop,
                                  by = list(subset$Country),
                                  FUN = mean)


library(dplyr)
#' Load dataset with publications and GRIDs
grids <- readr::read_csv("grids.csv")
grids
#' Remove NA and `not_in_grid`
grids <-
  filter(grids,
         !is.na(grid_id_consolidated) &
           !grid_id_consolidated == "not_in_grid")
#' Get bipartite network, and calculate unipartite representation
grids_mat <- table(grids$grid_id_consolidated, grids$pub_id)
mat_t <- grids_mat %*% t(grids_mat)
#' convert to edge list using igraph library, we want a undirected network without loops (self-links)
my_net <- igraph::graph_from_adjacency_matrix(mat_t, mode = c("undirected"), diag = FALSE)
my_graph <- igraph::get.edgelist(my_net)
#' let's get geocodes using the Solr store. See also `solr_grid.r`
#' Call Solr API within R
library(solrium)
#' Connect
solrium::solr_connect("localhost:8983/solr/grid/select",
                      errors = "complete",
                      verbose = FALSE)
#' Call
my_graph_in <- plyr::ldply(my_graph[,1], function(x) solrium::solr_search(q = paste0("id:", x)))
my_graph_out <- plyr::ldply(my_graph[,2], function(x) solrium::solr_search(q = paste0("id:", x)))
#' Remove missing geocodes
p1 <- my_graph_in %>% select(lng, lat) %>% filter(!is.na(lng))
p2 <- my_graph_out %>% select(lng, lat) %>% filter(!is.na(lng))
#' convert to numeric values
p1 <- sapply(p1, as.numeric) %>% dplyr::as_data_frame()
p2 <- sapply(p2, as.numeric) %>% dplyr::as_data_frame()
#' Get intermediate points (way points) between the two locations with longitude/latitude coordinates
arch <- geosphere::gcIntermediate(p1,
                       p2,
                       n=50,
                       breakAtDateLine=FALSE,
                       addStartEnd=TRUE,
                       sp=TRUE)

#' http://docs.ggplot2.org/0.9.3.1/fortify.map.html
arch_fortified <- plyr::ldply(arch@lines, ggplot2::fortify)
#' get world map
library(ggplot2)
library(ggmap)
library(sp)
library(grid)
library(geosphere)
world <- map_data("world")
world <- world[world$region != "Antarctica",]

#' ggplot2 code
my_plot <- ggplot() +
  geom_map(data=world, map=world,
           aes(x=long, y=lat, map_id=region),
           color="#191919", fill="#7f7f7f", size=0.05, alpha=1/4) +
  geom_line(aes(long,lat,group=group), data=arch_fortified, alpha= 1/100 ,size=0.5, colour="skyblue1") +
  ggthemes::theme_map() +
  theme(strip.background = element_blank()) +
  theme(panel.background = element_rect(fill = "#01001C", colour=NA)) +
  theme(legend.position = "none") +
  geom_point(data = p1, aes(lng, lat), alpha = 1/100, size = 0.3, colour = "#B0E2FF") +
  geom_point(data = p2, aes(lng, lat), alpha = 1/100, size = 0.3, colour = "#B0E2FF")
#' export
#+ fig.width=12, fig.height=6
my_plot
ggsave("network.pdf", width = 12, height = 6)

#' Europe and North America
#+ fig.width=12, fig.height=6

my_plot + coord_cartesian(xlim=c(-160,35),ylim=c(15,70))
ggsave("network_na_europe.pdf", width = 12, height = 6)
#' Links
#' - https://github.com/ricardo-bion/medium_visualization


library(dplyr)
library(tidyr)
library(shiny)
library(ggplot2)
load("app_data.rda")

input <- list(House_Can = "Young", Gov_Can = "Walker", Senate_Can = "Sullivan",SenateQuantile = 0.5, HouseQuantile = .75, GovQuantile = 0.6, Prop1Quantile = .3, Prop2Quantile = .5, Prop3Quantile = .5, Prop4Quantile = .2)
shinyServer(function(input, output, session) {

reactive_plot <- reactive({
if(input$House_Can == "Dunbar")         {house_percentile <- quantile(app_data$Dunbar, input$HouseQuantile) }
if(input$House_Can == "McDermott")      {house_percentile <- quantile(app_data$McDermott, input$HouseQuantile)}
if(input$House_Can == "Young")          {house_percentile <- quantile(app_data$Young, input$HouseQuantile)}

if(input$Gov_Can == "Clift")           {gov_percentile <- quantile(app_data$Clift, input$GovQuantile) }
if(input$Gov_Can == "Myers")           {gov_percentile <- quantile(app_data$Myers, input$GovQuantile)}
if(input$Gov_Can == "Parnell")         {gov_percentile <- quantile(app_data$Parnell, input$GovQuantile)}
if(input$Gov_Can == "Walker")          {gov_percentile <- quantile(app_data$Walker, input$HouseQuantile)}

if(input$Gov_Can == "Clift")           {gov_percentile <- quantile(app_data$Clift, input$GovQuantile) }
if(input$Gov_Can == "Myers")           {gov_percentile <- quantile(app_data$Myers, input$GovQuantile)}
if(input$Gov_Can == "Parnell")         {gov_percentile <- quantile(app_data$Parnell, input$GovQuantile)}
if(input$Gov_Can == "Walker")          {gov_percentile <- quantile(app_data$Walker, input$HouseQuantile)}

if(input$Senate_Can == "Begich")           {sen_percentile <- quantile(app_data$Begich, input$SenateQuantile) }
if(input$Senate_Can == "Fish")             {sen_percentile <- quantile(app_data$Fish, input$SenateQuantile)}
if(input$Senate_Can == "Gianoutsos")       {sen_percentile <- quantile(app_data$Gianoutsos, input$SenateQuantile)}
if(input$Senate_Can == "Sullivan")         {sen_percentile <- quantile(app_data$Sullivan, input$SenateQuantile)}

one_percentile   <- quantile(app_data$Prop1, input$Prop1Quantile)
two_percentile   <- quantile(app_data$Prop2, input$Prop2Quantile)
three_percentile <- quantile(app_data$Prop3, input$Prop3Quantile)
four_percentile  <- quantile(app_data$Prop4, input$Prop3Quantile)

app_data <- app_data[, c("District","Total_Votes", input$House_Can, input$Senate_Can, input$Gov_Can, "Prop1", "Prop2",       "Prop3",       "Prop4")]

gov_diff   <- gov_percentile - app_data[,input$Gov_Can]
house_diff <- house_percentile - app_data[,input$House_Can]
sen_diff<- sen_percentile - app_data[,input$Senate_Can]
one_diff   <- one_percentile - app_data$Prop1
two_diff   <- two_percentile- app_data$Prop2
three_diff <- three_percentile - app_data$Prop3
four_diff  <- four_percentile - app_data$Prop4

vote_distance <- sqrt(
    gov_diff^2    +
    house_diff^2  +
    sen_diff^2 +
    one_diff^2    +
    two_diff^2    +
    three_diff^2  +
    four_diff^2
  )

df <- data.frame(District = app_data$District,
           gov_diff,
           house_diff,
           one_diff,
           two_diff,
           three_diff,
           four_diff,
           vote_distance,
           Total_Votes = app_data$Total_Votes)

if(input$leverage != TRUE) { df$vote_distance <- (df$vote_distance/6)/df$Total_Votes}
df$District <- factor(df$District, levels = as.character(df$District[order(-df$vote_distance)]))

plot_list <- list()
plot_list$hist <- ggplot(data = df, aes(y = vote_distance/6, x = District)) + geom_bar(stat = "identity", position = "dodge") +
  coord_flip()

plot_list
})

output$testplot <- renderPlot({
  print(reactive_plot()$hist)  })
})


require(procPharm)
require(reticulate)
pyPharm <- import('python_pharmer')

tmpRD <- get(load("./extras/RD.200309.30.m.m3.p1.Rdata"))

# Find where the AITC is located and go out 120 points

fancyBin<- function(dat){
    pulsesWithNN <- c('^[bB]ob.*', "^AITC.*", "^[cC]aps.*", "^[mM]enth.*", "[kK][.]40.*")
    nnNames <- c('blob','aitc', 'menthol', 'capsaicin', 'k40')

    for( i in 1:length(pulsesWithNN)){
        print(i)

        # Make sure the pulse exists
        pulse <- grep(pulsesWithNN[i], dat$w.dat$wr1)

        if(length(pulse) > 0){
            minWin <- min( pulse )
            maxWin <- minWin + 119

            # Snag the pulse for all cells
            pulseToScore <- as.data.frame(t(dat$blc[minWin:maxWin,-1]))

            # Now use the python score all the responses of interest
            featureFrame <- pyPharm$featureMaker(pulseToScore, 10)
            featureScores <- pyPharm$modelRunner(featureFrame, nnNames[i])

            # Transfer these scoring to the binary dataframe
            binName <- grep(pulsesWithNN[i], names(dat$bin), value=T)
            dat$bin[binName] <- featureScores
        }

    }
    return(dat)
}

tmpRD <- fancyBin(tmpRD)


writePlotToFile <- function(x, y, xLabel, yLabel, color, pathOutputFile){
  png(filename= pathOutputFile, width = 700, height = 500)
  plot(x, y, xlab=xLabel, ylab=yLabel, col=color); # ylim=c(0,400000)
  # Draw vertical lines
  abline(v=10, col="red")
  abline(v=15, col="red")
}

addPlot <- function(x, y, color){
	points(x,y, col=color)
}

convertSecToMin <- function(sec){
	return(sec/60)
}

convertMsToMin <- function(ms){
  return(ms/60000)
}

args <- commandArgs(trailingOnly = TRUE)
argLength <- length(args)
if(argLength != 6){
 	cat("Usage: script <throughput> <insertFile> <updateFile> <readFile> <scanFile> <outputFile>\n")
	quit()
}

throughputFile = args[1]
insertFile = args[2];
updateFile = args[3];
readFile = args[4]
scanFile = args[5];
pathOutputFile = args[6];

throughputData <- read.csv(file=throughputFile,head=TRUE,sep=",")
insertData <- read.csv(file=insertFile,head=TRUE,sep=",")
updateData <- read.csv(file=updateFile,head=TRUE,sep=",")
readData <- read.csv(file=readFile,head=TRUE,sep=",")
scanData <- read.csv(file=scanFile,head=TRUE,sep=",")

writePlotToFile(convertSecToMin(throughputData$sec), throughputData$throughput, "Minuten", "throughput (ops/sec)", 1, paste(pathOutputFile, '_throughput_plot.png', sep=''))
writePlotToFile(convertMsToMin(insertData$ms), insertData$latency, "Minuten", "Latency (µs)", 1, paste(pathOutputFile, '_latency_plot.png', sep=''))
addPlot(convertMsToMin(updateData$ms), updateData$latency, 2)
addPlot(convertMsToMin(readData$ms), readData$latency, 3)
addPlot(convertMsToMin(scanData$ms), scanData$latency, 4)

legend("topright", inset=.05, title="Legend", c('Insert', 'Update', 'Read', 'Scan'), col=1:4, pch=1)


## @knitr code1
cos(pi)
## @knitr end_code1


#!/usr/bin/env Rscript
library(data.table)
library("optparse")
library("qqman")
t_col <- function(color, percent = 50, name = NULL) {
  #      color = color name
  #    percent = % transparency
  #       name = an optional name for the color

## Get RGB values for named color
rgb.val <- col2rgb(color)

## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
             max = 255,
             alpha = (100 - percent) * 255 / 100,
             names = name)

## Save the color
invisible(t.col)
}

computedher<-function(beta, se, af,N){
#https://journals.plos.org/plosone/article/file?type=supplementary&id=info:doi/10.1371/journal.pone.0120758.s001
maf<-af
maf[!is.na(af) & af>0.5]<- 1 - maf[!is.na(af) & af>0.5]
ba<-!is.na(beta) & !is.na(se) & !is.na(maf) & !is.na(N)
a<-rep(NA, length(beta))
b<-rep(NA, length(beta))
a<-2*(beta[ba]**2)*(maf[ba]*(1-maf[ba]))
b<-2*(se[ba]**2)*N[ba]*maf[ba]*(1-maf[ba])
res<-rep(NA, length(beta))
res[ba]<-a[ba]/(a[ba]+b[ba])
res
}

option_list = list(
  make_option(c( "--gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--ld_file"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c( "--pheno"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chr_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--bp_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ps_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--a1_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--a2_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--beta_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--se_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--af_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--N_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--ps_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--chr_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--p_gwas"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--min_pvalue"), type="numeric", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--min_r2"), type="numeric", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--info_gwascat"), type="character", default=NULL,
              help="dataset file name", metavar="character"),
  make_option(c("--out"), type="character", default="out.txt",
              help="output file name [default= %default]", metavar="character")
);

checkhead<-function(head,Data, type){
if(length(which(head %in% names(Data)))==0){
print(names(Data))
print(paste('not found ', head,'for',type ,'data'))
q(2)
}
}
Test=F
#--chr_gwas ${params.head_chr} --ps_gwas ${params.head_bp} --a1_gwas ${params.head_A1} --a2_gwas ${params.head_A2
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);
if(Test)opt=list(gwascat='Diastolic_AwigenLD_all.csv',gwas='Diastolic_AwigenLD_range.init',chr_gwas='CHR',ps_gwas='BP',a1_gwas='ALLELE1',a2_gwas='ALLELE0',beta_gwas='BETA',se_gwas='SE',af_gwas='A1FREQ',chr_gwascat='chrom',bp_gwascat='chromEnd',p_gwas='P_BOLT_LMM',ps_gwascat='chromEnd',chr_gwascat='chrom',out='Diastolic_AwigenLD_ld',ld_file='Diastolic_AwigenLD_ld.ld',min_pvalue='0.001',min_r2=0.2,info_gwascat="pubMedID;author;trait;initSample")

headse=opt[['se_gwas']];headbp=opt[['ps_gwas']];headchr=opt[['chr_gwas']];headbeta=opt[['beta_gwas']];heada1=opt[['a1_gwas']];heada2=opt[['a2_gwas']];headpval=opt[['p_gwas']];headaf<-opt[['af_gwas']];headbeta=opt[['beta_gwas']]
headchrcat=opt[['chr_gwascat']];headbpcat=opt[['ps_gwascat']];heada1catrs<-"riskAllele";headzcat="z.cat";headafcat<-'risk.allele.af';heada1cat<-'risk.allele.cat'
outhead=opt[['out']]

datagwascat=read.csv(opt[['gwascat']])
#datagwascat[,heada1cat]<-sapply(strsplit(as.character(datagwascat[,heada1catrs]),split='-'),function(x)x[2])
datagwas<-read.table(opt[['gwas']], header=T)
checkhead(headpval, datagwas,'pval');checkhead(headse, datagwas,'se');checkhead(headbp, datagwas,'bp');checkhead(headchr, datagwas, 'chr');checkhead(headbeta, datagwas, 'beta')

checkhead(headbpcat,datagwascat,'bp cat');checkhead(headchrcat,datagwascat,'chro cat');

# CHR_A         BP_A         SNP_A  CHR_B         BP_B         SNP_B           R2
datald<-fread(opt[['ld_file']])
tmpa<-unique(datald[,c('CHR_A','BP_A','SNP_A')]);names(tmpa)<-c('CHR','BP','SNP');
tmpb<-unique(datald[,c('CHR_B','BP_B','SNP_B')]);names(tmpb)<-c('CHR','BP','SNP');
tmp<-rbind(tmpa,tmpb)
tmpall<-unique(rbind(tmpa,tmpb))
tmpall<-tmpall[,c('CHR','BP','SNP','CHR','BP','SNP')]
tmpall$R2<-1
names(tmpall)<-names(datald)
datald<-rbind(datald,tmpall)

#   CHR_A     BP_A     SNP_A CHR_B     BP_B      SNP_B       R2
#1:    18 48132646 rs1437649    18 48133241 rs61148001 0.896039

headN<-opt[['N_value']]
if(is.null(opt[['N_gwas']])){
if(is.null(opt[['N_value']]))Nval<-10000 else Nval=opt[['N_value']]
datagwas[,'N_gwas']<-Nval
headN<-'N_gwas'
}

baliseh2=F
if(!is.null(headaf)){
checkhead(headaf, datagwas,'af');
datagwas$h2.gwas<-computedher(datagwas[,headbeta], datagwas[,headse], datagwas[,headaf],datagwas[,headN])
datagwas$z.gwas<-datagwas[,headbeta]/datagwas[,headse]
}else{
cat('no frequencie\n')
datagwas$h2.gwas<-NA
datagwas$z.gwas<-NA
baliseh2=T

}

datalda1<-merge(datagwascat, datald, by.x=c(headchrcat,headbpcat), by.y=c("CHR_A", "BP_A"));names(datalda1)[names(datalda1)=="CHR_B"]<-headchr;names(datalda1)[names(datalda1)=="BP_B"]<-headbp;names(datalda1)[names(datalda1)=="SNP_B"]<-'rs_gwas';names(datalda1)[names(datalda1)=="SNP_A"]<-'rs_cat'
datalda2<-merge(datagwascat, datald, by.x=c(headchrcat,headbpcat), by.y=c("CHR_B", "BP_B"));names(datalda2)[names(datalda2)=="CHR_A"]<-headchr;names(datalda2)[names(datalda2)=="BP_A"]<-headbp;names(datalda2)[names(datalda2)=="SNP_A"]<-'rs_gwas';names(datalda2)[names(datalda2)=="SNP_B"]<-'rs_cat'

dataldallcat<-rbind(datalda1,datalda2)

if(Test){
rsclump<-"12:2523697";rscat="rs55935819";chrocat<-12;bpcat<-2521579
datagwas[datagwas[,headchr]==12 & datagwas[,headbp]==2523697,]
datagwascat[datagwascat[,headchrcat]==chrocat & datagwascat[,headbpcat]==bpcat,]
datagwascat[datagwascat[,'name']==rscat ,]

dataldallcat[dataldallcat$rs_gwas==rsclump,]
dataldallcat[dataldallcat$rs_cat==rsclump,]
dataldallcat[dataldallcat$rs_cat==rscat,]
datald[datald$SNP_B==rsclump | datald$SNP_A==rsclump,]
datagwas[datagwas$CHR=='18' & datagwas$BP==48133241,]
datald[datald$SNP_B==rscat | datald$SNP_A==rscat,]
#datagwascat[datagwascat$name=='rs745821',]
dataldallcat[dataldallcat$rs_cat==rscat,]
dataldallcat[dataldallcat$rs_gwas==rsclump,]
}

datalda1<-merge(dataldallcat, datagwas, by.x=c(headchr,headbp), by.y=c(headchr,headbp))
if(Test)datalda1[datalda1$name==rscat,]
#datald[datald$CHR_A==18 & datald$BP_A==48144571 ,]
#datalda1[datalda1$rs_cat=='rs745821',]
#datalda1[datalda1$rs_gwas=='18:48144571',]

write.table(datalda1, file=paste(opt[['out']],'_all.txt',sep=''), row.names=F, col.names=T,quote=F)

infocat=strsplit(opt[['info_gwascat']],split=';')[[1]]

datalda1$info_gwas<-paste(datalda1[,headchr],':',datalda1[,headbp],'-beta:',datalda1[,headbeta], ',se:',datalda1[,headse],',pval:',datalda1[,headpval],',R2:', datalda1[,'R2'],sep='')
datalda1$info_gwascat<-""
for(cat in infocat)datalda1$info_gwascat<-paste(datalda1$info_gwascat,cat,':',datalda1[,cat],',',sep='')
datagwassumm<-aggregate(as.formula(paste('info_gwas~',headbpcat, '+',headchrcat)), data=datalda1,function(x)paste(unique(x), collapse=';'))
datagwascatsumm<-aggregate(as.formula(paste('info_gwascat~',headbpcat, '+',headchrcat)), data=datalda1, function(x)paste(unique(x), collapse=';'))
datagwasminpval<-aggregate(as.formula(paste(headpval,'~',headbpcat, '+',headchrcat)), data=datalda1,min)
datagwasminpval<-merge(datagwasminpval,datalda1, by=c(headchrcat,headbpcat,headpval),all=F)

allresume<-merge(merge(datagwassumm,datagwascatsumm,all=T, by=c(headchrcat,headbpcat)),datagwasminpval, all=T, by=c(headchrcat,headbpcat))
names(allresume)[c(1,2)]<-c('chr_gwas', 'bp_gwas_cat')
write.csv(allresume, file=paste(opt[['out']],'_resume.csv',sep=''),row.names=F)

###
#head(datalda1)
#print(range(datalda1$R2))
#cat(opt[['min_pvalue']])
datalda1sig<-datalda1[datalda1[,headpval]<opt[['min_pvalue']],]
#datalda1sig<-datalda1
#if(nrow(datalda1sig)>0){
#datalda1sig$info_gwas<-paste(datalda1sig[,headchr],':',datalda1sig[,headbp],'-beta:',datalda1sig[,headbeta], ',se:',datalda1sig[,headse],',pval:',datalda1sig[,headpval],',R2:', datalda1sig[,'R2'],sep='')
#}else{
#}
#datalda1sig$info_gwascat<-""
#for(cat in infocat)datalda1sig$info_gwascat<-paste(datalda1sig$info_gwascat,cat,':',datalda1sig[,cat],',',sep='')
if(nrow(datalda1sig)>0){
datagwasminpval<-aggregate(as.formula(paste(headpval,'~',headbpcat, '+',headchrcat)), data=datalda1sig,min)
datagwassumm<-aggregate(as.formula(paste('info_gwas~',headbpcat, '+',headchrcat)), data=datalda1sig,function(x)paste(unique(x), collapse=';'))
datagwascatsumm<-aggregate(as.formula(paste('info_gwascat~',headbpcat, '+',headchrcat)), data=datalda1sig, function(x)paste(unique(x), collapse=';'))
}else{
datagwasminpval<-datalda1sig[F,c(headbpcat,headchrcat,headpval)]
datagwassumm<-datalda1sig[F,c('info_gwas',headchrcat,headbpcat)]
datagwascatsumm<-datalda1sig[F,c('info_gwascat',headchrcat,headbpcat)]
}

allresume<-merge(merge(datagwassumm,datagwascatsumm,all=T, by=c(headchrcat,headbpcat)), datagwasminpval,all=T, by=c(headchrcat,headbpcat))
allresume<-allresume[allresume[,headpval]<opt[['min_pvalue']],]
names(allresume)[c(1,2)]<-c('chr_gwas', 'bp_gwas_cat')
#minpval<-aggregate(as.formula(paste(headpval,'~',headbpcat, '+',headchrcat)), data=datalda1sig,min)
#names(minpval)[3]<-"min_pvalgwas"
#allresume<-merge(allresume,minpval,by=c(1,2))

## write sig
write.csv(allresume, file=paste(opt[['out']],'_resumesig.csv',sep=''),row.names=F)


# difference is largely orthogonal from effect however measured
# the majority of diff FP are expressed at low levels
# this takes about 2 hours on a mobile i9 with 32 G of RAM
# data saved as data/output.summary.ty.Rda

# change this to run the simulation if wanted
# depends on TP-FP-ty-setup.r for datasets
run.this = FALSE

# TP: true positives are those found in the subset that are also
# found in the whole dataset
# intersect(whole,test)
# rate is TP/whole

# FP: false positives are those found in the subset that are not
# found in the whole dataset
# diff of whole
# TP.effect <- setdiff(test,whole)

if(!exists('output.summary.ty')){
  load(paste(my.path,'data/output.summary.ty.Rda', sep=''))
}

if(run.this == TRUE){
output.summary.ty <- list()
output.summary2 <- list()

# original tests done at 100 replicates
test.size <- 100
max.samples <- 20
registerDoMC(6) # this is the MC backend.
# 4 cores seems to be the performance limit
# beyond that there is throttling of each thread

output.summary.ty <- foreach(j = 2:max.samples)%dopar%{
    print(j)
	n.samples = j

	summary.stats <- matrix(data=NA, ncol=12, nrow=test.size)

	colnames(summary.stats) <- c('eff.TP', 'eff.FP', 'diff.TP', 'diff.FP', 'eff.diff.TP', 'eff.diff.FP', 'ol.TP', 'ol.FP', 'ol.diff.TP','ol.diff.FP', 'ol.eff.diff.TP', 'ol.eff.diff.FP')

	for(i in 1:test.size){
		test.col <- c(sample(1:161, n.samples), sample(162:373, n.samples))
		test.conds <- c(rep("P", n.samples), rep("Y", n.samples))
		test.data <- d[,test.col]

		x.test <- aldex.clr(test.data, test.conds, verbose=F)
		x.e.test <- aldex.effect(x.test, CI=T, verbose=F)

		test.diff <- rownames(x.e.test)[which(abs(x.e.test$diff.btw) > 1)]

		test.ol <- rownames(x.e.test)[which(x.e.test$overlap < 0.1)]

		test.eff <- rownames(x.e.test)[which(abs(x.e.test$effect) > 1)]

		test.diff.eff <- intersect(test.diff, test.eff)
		test.diff.ol <- intersect(test.diff, test.ol)
		test.ol.eff.diff <- intersect(test.eff, intersect(test.ol, test.diff))

		summary.stats[i,1] <- length(intersect(ty.eff, test.eff))
		summary.stats[i,2] <- length(setdiff(test.eff, ty.eff))

		summary.stats[i,3] <- length(intersect(ty.diff, test.diff))
		summary.stats[i,4] <- length(setdiff(test.diff, ty.diff))

		summary.stats[i,5] <- length(intersect(ty.diff.eff, test.diff.eff))
		summary.stats[i,6] <- length(setdiff(test.diff.eff, ty.diff.eff))

		summary.stats[i,7] <- length(intersect(ty.ol, test.ol))
		summary.stats[i,8] <- length(setdiff(test.ol, ty.ol))

		summary.stats[i,9] <- length(intersect(ty.diff.ol, test.diff.ol))
		summary.stats[i,10] <- length(setdiff(test.diff.ol, ty.diff.ol))

		summary.stats[i,11] <- length(intersect(ty.diff.eff, test.ol.eff.diff))
		summary.stats[i,12] <- length(setdiff(test.ol.eff.diff, ty.diff.eff))
	}

    output.summary2[[j]] <- summary.stats
}
save(output.summary.ty, file=paste(my.path,'data/output.summary.ty.Rda', sep=''))
} # end run.this if statement


##########################################################################################################################################################à
# Qt V PC M Qin Qout

############################################################################################################################

setwd("")
chem <- read.csv("data/chem_data_prob.csv", stringsAsFactors = FALSE)             # physicochemical parameters constant are in 1/minutes
TK <- read.csv("data/tk_data/TK_prob.csv",stringsAsFactors=FALSE)                 # toxicokinetic parameters
fBW <- read.csv("data/physio/fBW_animals_prob.csv",stringsAsFactors = FALSE)      # organ fractions, incl var-distribution parameters
fCO <- read.csv("data/physio/fCO_animals_prob.csv",stringsAsFactors = FALSE)      # blood flow fractions, incl var-distribution parameters
rates <- read.csv("data/physio/rates_animals_prob.csv",stringsAsFactors = FALSE)  # physiological rates (not chemical-dependent)
fPC <- read.csv("data/physio/PC_tissue_prob.csv",stringsAsFactors = FALSE)        # tissue composition, fixed during var-analysis

############################################################################################################################

BW <- BW            # bodyweight (kg)
CO <- CO/20         # cardiac output (fro minutes to L/3sec)

# fBW (peso frazione)        fCO (blood flow fractions)           PC           V (volume)          Q

Q_abomasum=Q_adipose=Q_brain=Q_carcass=Q_crop=Q_gizzard=Q_heart=Q_intestine=Q_kidney=0;
Q_liver=Q_lun=Q_mamgland=Q_muscle=Q_omasum=Q_reprod=Q_reticulum=Q_rumen=Q_stomach=Q_lumen=0;
Q_ven=Q_art=0;
Q_milk=Q_egg=Q_urine=Q_air=Q_feces=Q_metab=0

dQ_met <- ifelse(!is.na(phys$Vmax)&!is.na(phys$Km),(phys$Vmax*(phys$C/phys$PC))/(phys$Km+phys$C/phys$PC),0)
dQ_met_liver=phys$C[phys$comp=="liver"]*phys$Cl[phys$comp=="liver"]

phys$dM_in <- phys$dM_in + phys$dM_met[phys$comp=="liver"]*phys$fbile*phys$fbact
phys$dM_met[phys$comp=="liver"]*(1-phys$fbile[phys$comp=="lumen"]*phys$fbact[phys$comp=="lumen"])

#ELIMINATION

phys$dM_exh <- ifelse(phys$comp=="ven", CO*phys$C[phys$comp=="ven"],0) #all mass in venous blood is transported

phys$dM_out <- phys$dM_out + phys$dM_exh

phys$dM_in[phys$comp=="art"] <- phys$dM_in[phys$comp=="art"] + CO*phys$C[phys$comp=="ven"] * (CO/(CO+Qexhale*phys$PC[phys$comp=="air"]))
phys$dM_in[phys$comp=="air"] <- phys$dM_in[phys$comp=="air"] + CO*phys$C[phys$comp=="ven"] * ((Qexhale*phys$PC[phys$comp=="air"])/(CO+Qexhale*phys$PC[phys$comp=="air"]))

dQ_urine <- phys$C[phys$comp=="kidney"]*phys$Cl[phys$comp=="kidney"]
dQ_milk <- phys$C[phys$comp=="mamgland"]*phys$Qmilk[phys$comp=="mamgland"]
dQ_reprod <- phys$C[phys$comp=="reprod"]*phys$Qegg[phys$comp=="reprod"]
dQ_feces <- phys$M*phys$kgastric

dQ_exh=dQ_urine+dQ_milk+dQ_reprod+dQ_feces


##############################################################
# TODO:
# 1. get the env rasters at start and end,
#calculate scaled 3d distance between each pixel before and after change,
# then run spatial regression of phenotype change on env change

# 2. go back and look at draft yosemite fig and work on other parts of it

# 3. generate gif of rotating 3d landscape with phenotype and phenotype change on it
# (figure out hillshading/shadow for that??)

# 4. do same thing for pop density! (still need to KDE it; see py script)

# 5. get drafts of all figs combined and plopped into paper to get Ian's feedback

library(raster)
library(rgdal)
library(rasterVis)
library(rayshader)
library(pals)
library(wesanderson)
library(MASS)
library(nlme)
library(ggplot2)
library(ggthemes)
library(cowplot)

# output controls
save_vid = F
save_figs = F

###################
###################
###### MAPS #######
###################
###################

# read in the phenotype rasters
rasterize_table = function(filename, dem){
    rast = raster(as.matrix(read.table(filename)))
    rast@extent = dem@extent
    rast@crs = dem@crs
    return(rast)
}

# function to normalize a matrix to values between low and high,
# optionally flooring them integers
normalize_low_to_high = function(mat, low, high, floor_it=F){
    minval = min(mat)
    maxval = max(mat)
    out = (mat-minval)/(maxval-minval)
    out = ((high-low) * out)+low
    if (floor_it){
        out = floor(out)
    }
    return(out)
}

# function to get an ixjx3 array of RGB values
# corresponding to the given palette's hex values
# for an ixj array of data
get_rgb_vals = function(arr, pal){
    rgbs = lapply(seq(1, length(pal)),
                  function(i){return(col2rgb(pal[i]))})
    out_arr = array(0, dim=c(nrow(arr), ncol(arr),3))
    for (i in seq(dim(arr)[1])){
        for (j in seq(dim(arr)[2])){
            out_arr[i, j, ] = rgbs[[arr[i, j]]][,1]
        }
    }
    return(out_arr)
}

# function to make a RGB-contrast ixjx3 array
# from the ixj raster of data, using the given palette
make_rgb_contrast_array = function(rast, pal){
    # convert raster to a matrix
    mat = rayshader::raster_to_matrix(rast)
    # normalize to ints between 1 and palette length
    norm = normalize_low_to_high(mat, 1, length(pal), floor_it=T)
    # convert to a 3-layer array of the RGB values
    rgb_arr = get_rgb_vals(norm, pal)
    # permute to line up correctly for the plot_3D function (I believe?)
    rgb_arr = aperm(rgb_arr, c(2,1,3))
    # create a contrast array
    rgb_contrast = scales::rescale(rgb_arr, to=c(0,1))
    return(rgb_contrast)
}

# function to make a hillshade plot of the given raster and given DEM,
# colored by the given palette, using the given title
make_hillshade_plot = function(rast, dem, pal, title){
    slope = terrain(dem, opt='slope')
    aspect = terrain(dem, opt='aspect')
    hill = hillShade(slope, aspect, angle=65, direction=180)
    # plot the overlay for phenotype change
    plot(hill, main = title, col = grey(1:100/100), legend = FALSE)
    plot(rast, add = TRUE, alpha = .5, col=pal)
}

# function to make a 3d plot of the given raster and given DEM,
# colored by the given palette, using the given title
make_3d_plot = function(rast, dem, pal, title, var_name='no_var', zscale=10,
                        phi=30, theta_start=-45, fov=0,
                        background_color='#000000', title_bar_color='#ffffff',
                        title_color='#000000', snapshot=F, video=F){
    # get the dem as a matrix
    demmat = raster_to_matrix(dem)
    #use some of rayshader's built-in textures on the dem
    # NOTE: FIGURE OUT HOW TO ADD THIS TO GET HILLSHADING? CAN I EVEN DO IT?
    if (F){
    demmat_texture = demmat %>%
          sphere_shade(texture = "desert") %>%
          add_water(detect_water(demmat), color='desert') %>%
          add_shadow(ray_shade(demmat), 0.5) %>%
          add_shadow(ambient_shade(demmat), 0)
    }
    # get the raster as an RGB-contrast 3-layer array
    rgb_contrast = make_rgb_contrast_array(rast, pal)
    # make the plot
    plot_3d(rgb_contrast, demmat, windowsize = c(1100,900), zscale = zscale,
            shadowdepth = -50, zoom=0.5, phi=phi, theta=theta_start, fov=fov,
            background = background_color, shadowcolor = "#523E2B")
    if (snapshot){
        render_snapshot(title_text = title, title_bar_color = title_bar_color,
                        title_color = title_color, title_bar_alpha = 1)
    }
    if (video){
        # save 3d rotating video
        angles= seq(0,360,length.out = 1441)[-1]
        for(i in 1:(length(angles)-1)) {
          render_camera(theta=theta_start+angles[i], phi=phi)
          render_snapshot(filename = sprintf("./video_files/yosemite_vid_%s_%i.png", var_name, i),
                          title_text = title, title_bar_color = title_bar_color,
                          title_color = title_color, title_bar_alpha = 1) }
        rgl::rgl.close()
        system(paste0(sprintf("ffmpeg -framerate 60 -i ./video_files/yosemite_vid_%s", var_name),
                      "_%d.png -pix_fmt yuv420p ",
                      sprintf("./video_files/yosemite_%s.mp4", var_name)))
    }
}

# function to normalize the values in the before and after rasters
# (so that differences calculated as 3d Euclidean distances weight
# each var equally), but to do so using the full range of var values
# across both the b4 and after layers (so that calculated differences
# still reflect the fact that changes in temp are largely increases,
# changes in sdm are largely decreases, ppt is mixed)
get_normed_stacks = function(b4, af){
    for (i in seq(nlayers(b4))){
        vals = c(b4[[i]][,], af[[i]][,])
        minval = min(vals)
        maxval = max(vals)
        b4[[i]] = (b4[[i]] - minval)/(maxval-minval)
        af[[i]] = (af[[i]] - minval)/(maxval-minval)
    }
    return(list(b4, af))
}

# function to make a hillshaded ggplot with the given titile
# and from the given input raster using the layer data
# (which will be labeled in the legend
# using the given display_name, and the colors for which will be 'cols'
# will be scaled between minval and maxval, with the mean of those two
# vals being used as the contour-line value)
make_gg_hillshade_plot = function(rast, hillrast, display_name,
                                  minval, maxval, cols, title,
                                  include_title=FALSE){
  if (!include_title){
      title=''
  }
  # make both rasters into data.frames
  df = as.data.frame(rast, xy=T)
  hill_df = as.data.frame(hillrast, xy=T)
  colnames(df) = c('x', 'y', 'layer')
  # create the ggplot object
  out = ggplot() +
      # plot the main raster, filling by its value column
      geom_raster(data = df,
                  aes(x = x, y = y, fill=layer)) +
      # add the hillshade raster, filling by its value column
      geom_raster(data = hill_df,
                  aes(x = x, y = y, alpha=layer)) +
      # add the contour line at the midway value
      # between the min and max of this variable across time
      geom_contour(data = df, colour='#edede8',
                   breaks=c(minval, mean(c(minval, maxval)), 1.01*maxval),
                   aes(x=x, y=y, z=layer)) +
      # scale the fill using the given colors and display_name
      scale_fill_gradientn(colours=cols, name=display_name,
                           limits=c(minval, maxval*1.01)) +
      # scale the alpha vals of the hillshade layer
      scale_alpha(range = c(0.15, 0.5), guide = "none") +
      # use the ggthemes map theme
      ggthemes::theme_map() +
      # tweak theme aspects
      theme(legend.position = 'right',
            legend.background = element_rect(fill = "darkgray"),
            legend.key = element_rect(fill = "lightblue", color = NA),
            #legend.key.size = unit(2, 'cm'),
            #legend.key.height = unit(1.2, "cm"), #legend.key.width = unit(0.4,"cm"),
            legend.text = element_text(size=14),
            legend.title = element_text(size=16),
            plot.title = element_text(size = 18),
            axis.ticks.length = unit(0.2, 'cm'),
            #axis.title = element_text(),
            plot.margin = unit(c(0,0,0,0), 'cm'),
            axis.text = element_text(size=10), #, angle=45),
            axis.ticks = element_line(),
            axis.title.x = element_blank(),
            axis.title.y = element_blank()) +
      #xlab("lon") +
      #ylab("lat") +
      # add the title
      ggtitle(title) +
      # set to map coordinates,
      # and fix the x- and y-axis limits to remove the annoying margin
      coord_quickmap(xlim = c(min(df$x), max(df$x)),
                      ylim = c(min(df$y), max(df$y)),
                      expand=F)
  return(out)
}

# function to create mirrored sets of individuals and pad them around the
# real individuals, to take care of edge effects
mirror_pad_inds = function(inds, extent){
    # get original and mirrored x and y coords
    xs = inds$x
    ys = inds$y
    mirr_xs = -xs
    mirr_ys = -ys
    # create a set of inds mirrored to the left
    lpad = inds
    lpad$x = mirr_xs
    # create a set of inds mirrored to the right
    rpad = inds
    rpad$x = mirr_xs+(2*extent[[1]])
    # create a set of inds mirrored below
    bpad = inds
    bpad$y = mirr_ys
    # create a set of inds mirrored above
    upad = inds
    upad$y = mirr_ys+(2*extent[[2]])
    # concatenate all into new data.frame
    out = rbind(inds, lpad, rpad, bpad, upad)
    return(out)
}

####################
# Get and prep data:

# TODO: DELETE LO-RES DEM??
# read in the yosemite DEM
dem = raster('yosemite_DEM_90x90.tif')

# read in the before and after kriged phenotypes
b4_z = rasterize_table('b4_cc_krig.txt', dem)
af_z = rasterize_table('af_cc_krig.txt', dem)
# and get the phenotype-change raster
del_z = af_z - b4_z

# downscale everything (for better viz)
factor = 20
# TODO: DELETE LO-RES DEM??
dem = disaggregate(dem, factor, method='bilinear')
b4_z = disaggregate(b4_z, factor, method='bilinear')
af_z = disaggregate(af_z, factor, method='bilinear')
del_z = disaggregate(del_z, factor, method='bilinear')

# read in the hi-res DEM, mosaic, and clip (NOTE: doesn't need reprojection)
hrdem1 = raster('./hi_res_DEM/n37_w120_1arc_v3.tif')
hrdem2 = raster('./hi_res_DEM/n37_w121_1arc_v3.tif')
hrdem3 = raster('./hi_res_DEM/n38_w120_1arc_v3.tif')
hrdem4 = raster('./hi_res_DEM/n38_w121_1arc_v3.tif')
hrdem = mosaic(hrdem1, hrdem2, hrdem3, hrdem4, fun='mean')
hrdem = crop(hrdem, dem)

# get the 3 variables before climate change
b4 = stack(c('./yosemite_env_layers/ppt_1980-2010_90x90.tif',
             './yosemite_env_layers/tmp_1980-2010_90x90.tif',
             './yosemite_env_layers/sdm_1980-2010_90x90.tif'))

# get the 3 vars after
af = stack(c('./yosemite_env_layers/594_ppt_2100_90x90.tif',
             './yosemite_env_layers/594_tmp_2100_90x90.tif',
             './yosemite_env_layers/594_sdm_2100_90x90.tif'))

# norm them
normed = get_normed_stacks(b4, af)

# get the Euclidean-distance raster
# (Euclidean distance each pixel traveled in normed env space)
euc = sqrt(sum((normed[[2]] - normed[[1]])^2))

# read in the CSVs of individs' points
b4_inds = read.csv('./b4_cc_individs.csv')
af_inds = read.csv('./af_cc_individs.csv')

# produce 2D KDE plots of population density, as rasters
# NOTE: transpose the KDE matrices because, per the docs,
# x vals are on the rows (not sure why?)
# NOTE: add a margin to the limits, then subset the core of the KDE
# matrix, to attempt to ameliorate the edge effect
# NOTE: normalizing the raster by its own sum,
# then multiplying by total pop size, as I believe this
# gives me cells that can be interpreted as actual pop densities
h=8
real_width = nrow(b4)
margin_width=10
lims=c(-margin_width, real_width+margin_width,
       -margin_width, real_width+margin_width)

mirr_b4_inds = mirror_pad_inds(b4_inds, c(90,90))
mirr_af_inds = mirror_pad_inds(af_inds, c(90,90))

b4_kde = kde2d(mirr_b4_inds$x, mirr_b4_inds$y,
                        n=real_width + (2*margin_width),
                        h=c(h,h), lims=lims)
b4_kde = b4_kde[[3]][(margin_width+1):(margin_width+real_width),
                     (margin_width+1):(margin_width+real_width)]
b4_kde = raster(t(b4_kde))
b4_kde = nrow(b4_inds) * b4_kde/cellStats(b4_kde, 'sum')
b4_kde@extent = b4@extent
b4_kde@crs = b4@crs
af_kde = kde2d(mirr_af_inds$x, mirr_af_inds$y,
                        n=real_width + (2*margin_width),
                        h=c(h,h), lims=lims)
af_kde = af_kde[[3]][(margin_width+1):(margin_width+real_width),
                     (margin_width+1):(margin_width+real_width)]
af_kde = raster(t(af_kde))
af_kde = nrow(af_inds) * af_kde/cellStats(af_kde, 'sum')
af_kde@extent = af@extent
af_kde@crs = af@crs

#################
# Make the plots:

# get hillshade raster
slope = terrain(hrdem, opt='slope')
aspect = terrain(hrdem, opt='aspect')
hill = hillShade(slope, aspect, angle=15, direction=10);

# plot temperature and phenotype hillshade plots,
# before and after climate change
n_breaks = 100
#cols = coolwarm(n_breaks)
cols = brewer.rdbu(n_breaks*1.5)[125:26]

b4_tmp_hillplot = make_gg_hillshade_plot(b4[[2]], hill, '°C     ',
                              b4[[2]]@data@min, af[[2]]@data@max,
                              cols, 'temperature before climate change')
af_tmp_hillplot = make_gg_hillshade_plot(af[[2]], hill, '°C     ',
                              b4[[2]]@data@min, af[[2]]@data@max,
                              cols, 'temperature after climate change')
b4_z_hillplot = make_gg_hillshade_plot(b4_z, hill, 'pheno\nval',
                              b4_z@data@min, af_z@data@max,
                              cols, 'phenotypes before climate change')
af_z_hillplot = make_gg_hillshade_plot(af_z, hill, 'pheno\nval',
                              b4_z@data@min, af_z@data@max,
                              cols, 'phenotypes after climate change')

pg_tmp_z = plot_grid(b4_tmp_hillplot, af_tmp_hillplot,
                     b4_z_hillplot, af_z_hillplot,
                     ncol=2)

if (save_figs){
  ggsave(pg_tmp_z, file='b4_af_tmp_z_maps.pdf',
         width=30, height=20, units = "cm", dpi=1200)
}

# plot hab suitability and pop density hillshade plots,
# before and after climate change
n_cols = 100
zissou = wes_palette("Zissou1", n_cols, type = "continuous")

min_sdm_val = min(b4[[3]]@data@min, af[[3]]@data@min)
max_sdm_val = max(b4[[3]]@data@max, af[[3]]@data@max)
min_kde_val = min(b4_kde@data@min, af_kde@data@min)
max_kde_val = max(b4_kde@data@max, af_kde@data@max)

b4_sdm_hillplot = make_gg_hillshade_plot(b4[[3]], hill, 'hab\nsuit',
                              min_sdm_val, max_sdm_val,
                              zissou, 'habitat suitability before climate change')
af_sdm_hillplot = make_gg_hillshade_plot(af[[3]], hill, 'hab\nsuit',
                              min_sdm_val, max_sdm_val,
                              zissou, 'habitat suitability after climate change')
b4_nt_hillplot = make_gg_hillshade_plot(b4_kde, hill, 'inds/\ncell',
                              min_kde_val, max_kde_val,
                              zissou, 'population density before climate change')
af_nt_hillplot = make_gg_hillshade_plot(af_kde, hill, 'inds/\ncell',
                              min_kde_val, max_kde_val,
                              zissou, 'population density after climate change')

pg_sdm_nt = plot_grid(b4_sdm_hillplot, af_sdm_hillplot,
                      b4_nt_hillplot, af_nt_hillplot,
                      ncol=2)

if (save_figs){
  ggsave(pg_sdm_nt, file='b4_af_sdm_nt_maps.pdf',
         width=30, height=20, units = "cm", dpi=1200)
}

# 3d plots
zscale=5
if (save_vid){
  make_3d_plot(b4_z, dem, coolwarm, 'Kriged phenotype before climate change',
               var_name='pheno', zscale=zscale, background_color='#a6a490',
               title_bar_color='#ebebeb', snapshot=F, video=T, phi=22, fov=70)
}

make_3d_plot(del_z, dem, zissou,
             'Difference in kriged phenotypes before and after climate change',
             zscale=zscale, background_color='#000000', title_bar_color='#99cde0')

###############################################################

###############################################################

# get a normalized difference raster, then plot it
diff_inds = (af_kde-b4_kde)/b4_kde
col = colorRampPalette(c("red", "white", "blue"))(255)
plot(diff_inds, col=col)

# investigate relationship between change in pop density and env change
diff_inds_vals = diff_inds[,]
euc_vals = euc[,]
coords = lapply(seq(length(euc_vals)), function(i){return(xyFromCell(diff_inds, i))})
coords = data.frame(matrix(unlist(coords), ncol=2, byrow=T))
colnames(coords) = c('lon', 'lat')
df = data.frame(inds = diff_inds_vals, euc = euc_vals,
                lon = coords$lon, lat = coords$lat, dummy=1)
mod = lme(fixed=inds ~ euc, data=df, random= ~1|dummy,
          correlation=corGaus(1, form = ~ lon + lat))
# plot scatterplot along with model trendline
plot(euc[,], diff_inds[,])

###################
###################
###### ETC. #######
###################
###################

# make the pop-growth plot
nt = read.csv('./Nt_EXTENDED.csv')
# set total burn-in time, then truncate dataset
burn_t = 98
nt$t = nt$t-98
nt = nt[nt$t>=0, ]
# set ylims
ylims = c(min(nt$Nt)*0.9, max(nt$Nt) * 1.1)

nt_plot = ggplot() +
    geom_line(aes(t, Nt), col='#47b3ab', size=2, data=nt) +
    geom_vline(xintercept= 509, colour = '#fc033d') +
    geom_vline(xintercept= 594, colour = '#fc033d') +
    scale_x_continuous(name = '') +
    #scale_x_continuous(name = 't (time steps)') +
    scale_y_continuous(name = '', limits=ylims) +
    #scale_y_continuous(name = 'Nt (individuals/cell)', limits=ylims) +
    ggthemes::theme_gdocs() +
    #ggtitle("Population dynamics") +
    theme(axis.title = element_text(size=30),
          axis.text = element_text(size=28, color='black'))
nt_plot

ggsave(nt_plot, file='Nt_plot.pdf',
       width=40, height=20, units='cm', dpi=500)

# note that mean popsize af/mean popsize b4 = sum(sdm_af)/sum(sdm_b4)
b4sum = sum(b4[[3]][,])
afsum = sum(af[[3]][,])
sdm_ratio = afsum/b4sum
print('sdm ratio')
print(sdm_ratio)
b4meanNt = mean(nt[200:400,'Nt'])
afmeanNt = mean(nt[600:650,'Nt'])
Nt_ratio = afmeanNt/b4meanNt
print("Nt ratio")
print(Nt_ratio)


# Analyze Stan fit objects generated on the cluster.

rm(list = ls())
gc()

setwd("~/Desktop/Code/laplace_approximation/Script/")
.libPaths("~/Rlib")
scriptDir <- getwd()

library(rstan)
library(posterior)
library(dplyr)
library(tidyr)
library(boot)
library(latex2exp)
source("tools/cmdStanTools.r")
source("tools/stanTools.r")
source("tools/analysisTools.r")

pars <- c("lambda", "tau", "caux", "f", "lp__")

nChains <- 6  # 4 + 2 chains over two runs.
nIter <- 2000  # 2000  # number of samples (so not including warmup)
nIter_total <- nChains * nIter

##########################################################################
## Read in results from Bernoulli logit model with adapt_delta = 0.99
modelName <- "bernoulli_logit_glm_rhs"

delivDir <- file.path("deliv", modelName, "cluster")
# stanfit <- readRDS(file = file.path(delivDir, paste0(modelName,
#                                     "Fit_long_warmup.Rsave")))
stanfit <- readRDS(file = file.path(delivDir, paste0(modelName,
                     "_1_to_4", "Fit.Rsave")))
stanfit2 <- readRDS(file = file.path(delivDir, paste0(modelName,
                      "_5_to_6", "Fit.Rsave")))
check_div(stanfit)
check_div(stanfit2)

# closer examination
sampler_params <- get_sampler_params(stanfit, inc_warmup = FALSE)
# sampler_params_chain1 <- sampler_params[[1]]
if (FALSE) {
divergence_by_chain <-
  sapply(sampler_params, function(x) sum(x[, "divergent__"]))
divergence_by_chain
step_size_by_chain <-
  sapply(sampler_params, function(x) mean(x[, "stepsize__"]))
step_size_by_chain
accept_by_chain <-
  sapply(sampler_params, function(x) mean(x[, "accept_stat__"]))
accept_by_chain

mass_matrix <- get_mass_matrix(stanfit, nChains = 4)
str(mass_matrix)
}

# adapt_info <- get_adaptation_info(stanfit2)
# string <- "# Step size = 0.00654987\n# Diagonal elements of inverse mass matrix:\n#"
# start <- nchar(string) + 1
# end <- nchar(adapt_info[1]) - nchar("\n# ")
# mass_matrix_chain1 <- substring(adapt_info[1], start, end)
# mass_matrix_chain1 <-
#   as.numeric(strsplit(mass_matrix_chain1, split =", ")[[1]])

samples <- rstan::extract(stanfit, pars = pars)
samples2 <- rstan::extract(stanfit2, pars = pars)
log_lambda <- log(rbind(samples$lambda, samples2$lambda))

index <- select_lambda(log_lambda, quant = 0.9, n_select = 6)
log_lambda_select <- log_lambda[, index]
names <- c(paste0("log_lambda[", index, "]"), "iteration", "chain")

posterior.sample <- construct_plot_data(log_lambda_select, nIter, nChains,
                                        names)
# trace_plot(posterior.sample)
density_hist(posterior.sample)
quant_select_plot(log_lambda, quant = 0.9, threshold = 2.5)

#extract other parameters
tau <- c(samples$tau, samples2$tau)
caux <- c(samples$caux, samples2$caux)
summary_table(log_lambda_select, tau, caux, index)

samples_standard <- data.frame(log_lambda_1816 = log_lambda[, 1816],
                               log_lambda_2586 = log_lambda[, 2586],
                               tau = tau,
                               caux = caux)

# inspect the predicted f
f <- rbind(samples$f, samples2$f)
p <- inv.logit(f)
p_expected <- colMeans(p)

##########################################################################
## Read in results from Bernoulli logit using ela
modelName2 <- "bernoulli_logit_glm_ela"
delivDir2 <- file.path("deliv", modelName2, "cluster")
stanfit_ela <- readRDS(file = file.path(delivDir2, paste0(modelName2, "Fit.Rsave")))
check_div(stanfit_ela)

pars <- c("lambda", "tau", "caux", "f", "lp__")
samples_ela <- rstan::extract(stanfit_ela, pars = pars)

# plot estimated probability
# inspect the predicted f
f_ela <- samples_ela$f
p_ela <- inv.logit(f_ela)
p_ela_expected <- colMeans(p_ela)

log_lambda_ela <- log(samples_ela$lambda)

# log_lambda <- log_lambda_ela
index <- select_lambda(log_lambda_ela, quant = 0.9, n_select = 6)
tau <- samples_ela$tau
caux <- samples_ela$caux
parm_select <- log_lambda_ela[, index]
names <- c(paste0("log_lambda[", index, "]"), "iteration", "chain")

# check samples for selected log_lambdas.
posterior.sample <- construct_plot_data(parm_select, nIter, nChains, names)
density_hist(posterior.sample)

# check samples for log tau.
posterior.sample.tau <- construct_plot_data(log(tau), nIter, nChains,
                                            c("log tau", "iteration", "chain"))
density_hist(posterior.sample.tau, bins = 30)
quant_select_plot(log_lambda, quant = 0.9, threshold = 2.5)

caux <- samples_ela$caux
summary_table(log_lambda_select, tau, caux, index)

#####################################################################
## Plots to save

pdf(file = file.path("deliv", "cluster_analysis",
                     paste(modelName,"Plots%03d.pdf",  sep = "")),
    width = 6, height = 6, onefile = F)

# do quantile plot using results from both models
quant_select_plot2(log_lambda, log_lambda_ela, quant = 0.9, threshold = 2.3)

samples_ela <- data.frame(log_lambda_1816 = log_lambda_ela[, 1816],
                          log_lambda_2586 = log_lambda_ela[, 2586],
                          tau = tau,
                          caux = caux) #,
                          # f = f)

samples_all <- rbind(samples_standard, samples_ela)
samples_all$log_tau <- log(samples_all$tau)
samples_all$log_caux <- log(samples_all$caux)
samples_all <- samples_all[, c(1, 2, 5, 6)]

samples_all <- gather(samples_all)
algorithm <- rep(rep(c("(full) HMC", "HMC + Laplace"), each = 12000), 4)
samples_all$method <- algorithm
key_labels <- c(TeX("$\\log \ c_{aux}$"), TeX("$\\log \\lambda_{1816}$"),
                TeX("$\\log \\lambda_{2586}$"), TeX("$\\log \\tau$"))
samples_all$key <- factor(samples_all$key, label = key_labels)

comp_plot <- ggplot(data = samples_all) +
  geom_histogram(aes(x = value, fill = method), alpha = 0.5, color = "black",
                 bins = 30, position = "identity") + theme_bw() +
  facet_wrap(~key, scale = "free", ncol = 1, labeller = "label_parsed") +
  theme(
    legend.position = c(.95, 0.17),
    legend.justification = c("right", "top"),
    legend.box.just = "right",
    legend.margin = margin(6, 6, 6, 6),
    text = element_text(size = 15)
  )
comp_plot

# next, examine ESS / s
pars = c("tau", "caux", "lambda[1816]", "lambda[2586]")
table_ela <- summary(stanfit_ela, pars = pars)[1]
ness_ela <- table_ela$summary[, 9]
time <- sum(get_elapsed_time(stanfit_ela)) / 6
eff_ela <- ness_ela / time

# table_standard1 <- summary(stanfit, pars = pars)[1]
ness_1 <- summary(stanfit, pars = pars)[1]$summary[, 9]
time1 <- sum(get_elapsed_time(stanfit))

table_standard2 <- summary(stanfit2, pars = pars)[1]
ness_2 <- table_standard2$summary[, 9]
time2 <- sum(get_elapsed_time(stanfit))

ness_standard <- ness_1 + ness_2
time <- (time1 + time2) / 6
eff_standard <- ness_standard / time

data_eff <- data.frame(parameter = rep(pars, 2), eff = c(eff_standard, eff_ela),
                       method = rep(c("(full) HMC", "HMC + Laplace"),
                                       each = 4))

plot_eff <- ggplot(data = data_eff,
                   aes(x = parameter, y = eff, fill = method)) +
  geom_bar(stat = "identity", width = 0.3, alpha = 0.8, position = "dodge") +
  # facet_wrap(~ parameter, scale = "free", nrow = 1) +
  theme_bw() + theme(text = element_text(size = 10)) + coord_flip() +
  ylab("ESS / s") + xlab(" ") +
  theme(
    legend.position = c(.95, 0.98),
    legend.justification = c("right", "top"),
    legend.box.just = "right",
    legend.margin = margin(6, 6, 6, 6)
  ) + theme(text = element_text(size = 18)) +
  scale_x_discrete(labels = c("tau" = parse(text = TeX("$\\tau$")),
                              "caux" = parse(text = TeX("$\\c_{aux}$")),
                              "lambda[1816]" = parse(text = TeX("$\\lambda_{1816}$")),
                              "lambda[2586]" = parse(text = TeX("$\\lambda_{2586}$"))))
plot_eff

plot_prob <- ggplot(data = data.frame(prob = p_expected,
                                      prob_ela = p_ela_expected),
                    aes(x = prob, y = prob_ela)) +
  geom_point() + theme_bw() + geom_abline(intercept = 0, slope = 1,
                                          color = "red",
                                         linetype = "dashed", size = 1.0) +
  xlim(0, 1) + ylim(0, 1) + xlab("Probability (full HMC)") +
  ylab("Probability (HMC + Laplace)") +
  theme(text = element_text(size = 15))
plot_prob

dev.off()

###############################################################################


nox<-2; noy<-3;
paper<-T        # graphics on paper=file (TRUE) or on screen (FALSE)
run.ID<-'SumPerc'         # file id used for paper output
cleanup()

first.year.on.plot<-1990
last.year.on.plot<-2040
single.species<-F                    # single species mode or multispecies mode
Portrait<-F

percentile<-c(0.50,0.25,0.75,0.05,0.95)   #first value must be 50 and last value the highest
percentile<-c(0.50,0.05,0.95)   #first value must be 50 and last value the highest

include.assess.forcast.line<-T      # verical line at last assessment year
include.F.reference.points<-F
include.SSB.reference.points<-T
incl.sp<-seq(15,23)                      # species number to be included. Numbers or "all"
incl.sp<-"all"

first.pch<-0    # first pch symbol
first.color<-1   # first color

palette("default")                # good for clolorfull plots
#palette(gray(seq(0,.9,len=10)))  # gray scale for papers, use len =500 to get black only

dirs<-c("T1-T2_stoc_rec_assess_run01", "T1-T2_stoc_rec_assess_run02","T1-T2_stoc_rec_assess_run03")
labels<-c("Run 1 Single sp Fmsy","Run 2 Multi sp Fmsy","Run 3, with TAC constraints")

 #####################
for (dir in dirs) {
  if ( file.access(file.path(data.path,dir,"sms.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist'))
}

Init.function() # get SMS.contol object  including sp.names

for (dir in dirs) {
  if (!single.species) {
    file<-file.path(data.path,dir,'mcout_eaten_M2.out')
    if ( file.access(file, mode = 0) ==0) {
       eaten<-read.table(file,header=TRUE)
       eaten<-data.frame(scen=dir,vari='Eaten',eaten)
       eaten<-subset(eaten,select=c(-Repetion,-Iteration))
       names(eaten)<-c("scenario","Variable","Species.n","Year","Value")
    }
  }

  file<-file.path(data.path,dir,'mcout_recruit.out')
  rec<-read.table(file,header=TRUE)
  rec<-data.frame(scen=dir,vari='Rec',rec)
  rec<-subset(rec,select=c(-Repetion,-Iteration))
  names(rec)<-c("scenario","Variable","Species.n","Year","Value")

  file<-file.path(data.path,dir,'mcout_mean_F.out')
  FF<-read.table(file,header=TRUE)
  FF<-data.frame(scen=dir,vari='F',FF)
  FF<-subset(FF,select=c(-Repetion,-Iteration))
  names(FF)<-c("scenario","Variable","Species.n","Year","Value")

  file<-file.path(data.path,dir,'mcout_SSB.out')
  ssb<-read.table(file,header=TRUE)
  ssb<-data.frame(scen=dir,vari='SSB',ssb)
  ssb<-subset(ssb,select=c(-Repetion,-Iteration))
  names(ssb)<-c("scenario","Variable","Species.n","Year","Value")

  file<-file.path(data.path,dir,'mcout_yield.out')
  yield<-read.table(file,header=TRUE)
  yield<-data.frame(scen=dir,vari='Yield',yield)
  yield<-subset(yield,select=c(-Repetion,-Iteration))
  names(yield)<-c("scenario","Variable","Species.n","Year","Value")

 if (!single.species) { if (dir==dirs[1]) all<-rbind(rec,FF,ssb,yield,eaten) else all<-rbind(all,rec,FF,ssb,yield,eaten)}
 else {if (dir==dirs[1]) {all<-rbind(rec,FF,ssb,yield)} else all<-rbind(all,rec,FF,ssb,yield)}
}

all<-subset(all,(Year>=first.year.on.plot & Year<=last.year.on.plot) ,drop=T)
len.per<-length(percentile)

if (include.F.reference.points | include.SSB.reference.points) ref.points<-Read.reference.points()

if (paper) {dev<-"png"; w8=10} else {dev<-"screen"; w8=8}
if (incl.sp=="all") sp.plot<-unique(yield$Species.n) else sp.plot<-incl.sp
len.dir<-length(dirs)

 plotvar<-function(sp=sp,vari='SSB',tit=vari,ylab='(1000t)',div=1) {
  v<-droplevels(subset(values,Variable==vari,select=c(-Variable,-Species.n)))

    if ((gi %% (nox*noy))==0  | gi==0) {
      newplot(dev,nox,noy,filename=paste("com_",run.ID,'_',sp.names[sp],sep=''),Portrait=Portrait,w8=w8);

      # make legends
      if (paper) lwds<-2
      else lwds<-2
      par(mar=c(0,0,0,0))
      plot(10,10,axes=FALSE,xlab=' ',ylab=' ',xlim=c(0,1),ylim=c(0,1))
      legend("center",legend=labels,col=first.color:(first.color+len.dir-1),
              pch=first.pch:(first.pch-1+len.dir),cex=2,title=sp.names[sp])
      gi<<-gi+1
      par(mar=c(2.5,5,3,1))   # c(bottom, left, top, right)
    }

    gi<<-gi+1

     b<-tapply(v$Value/div,list(v$scenario,v$Year), function(x) quantile(x,probs = percentile))
     y<-as.numeric(dimnames(b)[[2]])
     maxval<-max(unlist(b))
     v<-matrix(unlist(b[1,]),nrow=len.per)

    if (paper) {lwds<-1}
    else { lwds<-2;}

    plot(y,v[1,],main=tit,xlab="",ylab=ylab,type='b',lwd=lwds,ylim=c(0,maxval),col=first.color,pch=first.pch)
    for (j in (2:len.per)) lines(y,v[j,],col=first.color,type='l',lwd=lwds,lty=2)

    for (i in (2:len.dir)) {
      v<-matrix(unlist(b[i,]),nrow=len.per)
      lines(y,v[1,],col=first.color+i-1,pch=first.pch+i-1,type='b',lwd=lwds)
      for (j in (2:len.per)) lines(y,v[j,],col=first.color+i-1,type='l',lwd=lwds,lty=2)
    }

    if (include.assess.forcast.line) abline(v=SMS.control@last.year.model)

    if (include.SSB.reference.points & vari=="SSB") {
      if (ref.points[sp,"Blim"] >0) abline(h=ref.points[sp,"Blim"]/div,lty=2)
      if (ref.points[sp,"Bpa"] >0) abline(h=ref.points[sp,"Bpa"]/div,lty=3)
    }
    if (include.F.reference.points & vari=="F") {
      if (ref.points[sp,"Flim"] >0) abline(h=ref.points[sp,"Flim"],lty=2)
      if (ref.points[sp,"Fpa"] >0) abline(h=ref.points[sp,"Fpa"],lty=3)
    }
  }

 for (sp in (sp.plot)) {
  gi<-0
  values<-subset(all,Species.n==sp)

  plotvar(sp=sp,vari="Rec",tit="Recruits",ylab="(billions)",div=1000000)
  plotvar(sp=sp,vari="F",ylab=' ',div=1)
  plotvar(sp=sp,vari="SSB",div=1000)
  plotvar(sp=sp,vari="Yield",tit="Yield",div=1000)
  #plotvar(sp=sp,vari="Yield.hat",tit="Expected Yield")
  if (!single.species) plotvar(sp=sp,vari="Eaten",tit="Eaten biomass",div=1000)
  if (paper) cleanup()
}


# Visualize data from approval_averages and averages_by_grade

# Packages: ggplot2, plyr, dplyr, tidyr

#SETUP -----------------------------------------------------------------------------------------

# load required packages
library(ggplot2)
library(plyr)
library(dplyr)
library(tidyr)

# set wd
setwd('c:/rstuff/projects/dt_approval/')

# read in csv files
averages = read.csv('approval_averages.csv')
averages_by_grade = read.csv('averages_by_grade.csv')

# summary of both (SHOULD BE IDENTICAL)
summary(averages)
summary(averages_by_grade)

# rename column X
averages = rename(averages, c("Pollster"="X"))
averages_by_grade = rename(averages_by_grade, c("Pollster"="X"))

#DIVERGING LOLLIPOP (APPROVE) -----------------------------------------------------------------------------------------------

# create copy of averages
avg_copy = data.frame(averages)

# set rownames
avg_copy$Pollster = rownames

# compute normalized adjusted_approve_avg
avg_copy$Adjusted_Approve_Z = round((avg_copy$Adjusted_Approve_AVG - mean(avg_copy$Adjusted_Approve_AVG))
                                    /sd(avg_copy$Adjusted_Approve_AVG), 2)

# above/below flag (for potential diverging bar)
avg_copy$Average_Rank = ifelse(avg_copy$Adjusted_Approve_Z < 0, "Below", "Above")

# order by Adjusted_Approve_Z
avg_copy = avg_copy[order(avg_copy$Adjusted_Approve_Z),]

# make pollster factor
avg_copy$Pollster = factor(avg_copy$Pollster, levels = avg_copy$Pollster)

# create plot
ggplot(avg_copy, aes(x=Pollster, y=Adjusted_Approve_Z, label=Adjusted_Approve_Z))+
  geom_point(stat='identity', fill='black', size=7)+
  geom_segment(aes(y=0, x=Pollster, yend=Adjusted_Approve_Z, xend=Pollster), color='black')+
  geom_text(color='white', size=2)+
  labs(title='Adjusted Approval Comparison', subtitle='Normalized Mean Adjusted Approval from approval_averages.csv')+
  ylim(-3, 3)+
  coord_flip()

#DIVERGING LOLLIPOP (DISAPPROVE) ----------------------------------------------------------------------------------------

# create copy of averages
avg_copy2 = data.frame(averages)

# set rownames
avg_copy2$Pollster = rownames

# compute normalized adjusted_disapprove_avg
avg_copy2$Adjusted_Disapprove_Z = round((avg_copy2$Adjusted_Disapprove_AVG - mean(avg_copy2$Adjusted_Disapprove_AVG))
                                        /sd(avg_copy2$Adjusted_Disapprove_AVG), 2)

# above/below flag (for potential diverging bar)
avg_copy2$Average_Rank = ifelse(avg_copy2$Adjusted_Disapprove_Z < 0, "Below", "Above")

# order by Adjusted_Disapprove_Z
avg_copy2 = avg_copy2[order(avg_copy2$Adjusted_Disapprove_Z),]

# make pollster factor
avg_copy2$Pollster = factor(avg_copy2$Pollster, levels = avg_copy2$Pollster)

# create plot
ggplot(avg_copy2, aes(x=Pollster, y=Adjusted_Disapprove_Z, label=Adjusted_Disapprove_Z))+
  geom_point(stat='identity', fill='black', size=7)+
  geom_segment(aes(y=0, x=Pollster, yend=Adjusted_Disapprove_Z, xend=Pollster), color='black')+
  geom_text(color='white', size=2)+
  labs(title='Adjusted Disapproval Comparison', subtitle='Normalized Mean Adjusted Disapproval from approval_averages.csv')+
  ylim(-3, 5)+
  coord_flip()

#ORDERED BAR (APPROVE BY GRADE) ---------------------------------------------------------------------------

# create copy of averages_by_grade
grade_avg = data.frame(averages_by_grade)

# group mean adjusted approve by grade
Graded_Adjusted_Approve = aggregate(grade_avg$Adjusted_Approve_AVG, by=list(grade_avg$Grade),
                                    FUN=mean)

# rename columns
colnames(Graded_Adjusted_Approve) = c("Grade", "Adjusted_Approval_Average")

# sort by Adjusted_Approval_Average
Graded_Adjusted_Approve = Graded_Adjusted_Approve[order(Graded_Adjusted_Approve$Adjusted_Approval_Average),]

# make grades a factor to retain order
Graded_Adjusted_Approve$Grade = factor(Graded_Adjusted_Approve$Grade, levels=Graded_Adjusted_Approve$Grade)

# create plot
ggplot(Graded_Adjusted_Approve, aes(x=Grade, y=Adjusted_Approval_Average))+
  geom_bar(stat='identity', width=0.5, fill='springgreen4')+
  scale_y_continuous(breaks=seq(0,100,10))+
  labs(title="Average Adjusted Approval by Grade",
       subtitle="Ordered from lowest to highest")

#ORDERED BAR (DISAPPROVE BY GRADE) -------------------------------------------------------------------------

# group mean adjusted disapprove by grade
Graded_Adjusted_Disapprove = aggregate(grade_avg$Adjusted_Disapprove_AVG, by=list(grade_avg$Grade),
                                       FUN=mean)

# rename columns
colnames(Graded_Adjusted_Disapprove) = c("Grade", "Adjusted_Disapproval_Average")

# sort by Adjusted_Disapproval_Average
Graded_Adjusted_Disapprove = Graded_Adjusted_Disapprove[order(Graded_Adjusted_Disapprove$Adjusted_Disapproval_Average),]

# make grades a factor to retain order
Graded_Adjusted_Disapprove$Grade = factor(Graded_Adjusted_Disapprove$Grade, levels=Graded_Adjusted_Disapprove$Grade)

# create plot
ggplot(Graded_Adjusted_Disapprove, aes(x=Grade, y=Adjusted_Disapproval_Average))+
  geom_bar(stat='identity', width=0.5, fill='red3')+
  scale_y_continuous(breaks=seq(0,100,10))+
  labs(title="Average Adjusted Disapproval by Grade",
        subtitle="Ordered from lowest to highest")

#MULTIPLE VARIABLE BAR (BY GRADE) ------------------------------------------------------------------------------------

# merge Graded_Adjusted_Approve and Graded_Adjusted_Disapprove
Graded_Totals = merge(Graded_Adjusted_Approve, Graded_Adjusted_Disapprove, by=1, all=TRUE)

# make grade a factor
Graded_Totals$Grade = factor(Graded_Totals$Grade, levels=c('A+', 'A', 'A-', 'A/B', 'B+', 'B',
                                                           'B-', 'B/C', 'C+', 'C', 'C-', 'C/D',
                                                           'D+', 'D', 'D-'))
# order by grade
Graded_Totals = Graded_Totals[order(Graded_Totals$Grade),]

# 'gather' the data into a new variable
Gathered_Totals = Graded_Totals %>%
  gather("Key", "Adjusted_Average", -Grade)

# create plot
ggplot(Gathered_Totals, aes(x=Grade, y=Adjusted_Average, fill=Key))+
  scale_fill_manual(values=c("springgreen4", "red3"))+
  scale_y_continuous(breaks=seq(0,50,10))+
  geom_col(position="dodge", width=0.5)+
  labs(title="Adjusted Averages Comparison",
       subtitle="Ordered by Grade (descending)")


#' comput mc hierarchucal clustering using the normalized confusion matrix
#'
#' @param mc_id metacell id
#' @param graph_id cgraph to define edges and impose them on the metacells
#' @param confu a confusion matrix derived from e.g. mcell_mc_confusion_matm or mcell_mc_coclust_confusion_mat
#'
#' @export

mcell_mc_hclust_confu = function(mc_id, graph_id, confu=NULL)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("undefined meta cell object " , mc_id)
	}
	if(is.null(graph_id)) {
		if(is.null(confu)) {
			stop("MC-ERR, missing graph_id AND confu object when trying to hclust mc by confusion matrix")
		}
		if(nrow(confu) != ncol(mc@mc_fp) | ncol(confu) != nrow(confu)) {
			stop("MC-ERR, bad ocnfusion matrix dimension when trying to hcluster mc by confusion matrix")
		}
	} else {
		cgraph = scdb_cgraph(graph_id)
		if(is.null(cgraph)) {
			stop("undefined cgraph object when trying to plot confusion, id " , graph_id)
		}

		max_deg = nrow(cgraph@edges)
		confu = mcell_mc_confusion_mat(mc_id, graph_id, max_deg, ignore_mismatch=T)
	}
	r_confu = rowSums(confu)
	c_confu = colSums(confu)
	norm = r_confu %*% t(c_confu)
	confu_n = confu/norm
	confu_n[is.na(confu_n)] = 0
	confu_n[is.nan(confu_n)] = 0

	confu_nodiag = confu_n
	diag(confu_nodiag) = 0
	confu_n = pmin(confu_n, max(confu_nodiag))
	confu_n = pmin(confu_n, quantile(confu_n, 1-3/nrow(confu_n)))
	epsilon = quantile(confu_n[confu_n!=0],0.02)
	hc = hclust(as.dist(-log10(epsilon+confu_n)),"average")
	return(hc)
}

#' identify super structure in an mc cover, based on hcluster of the confusion matrix
#'
#' @param mc_id id of metacell object ina scdb
#' @param mc_hc hclust object onthe metacells (e.g. derive from mcell_mc_hclust_confu)
#' @param T_gap the minimal branch length for defining a supper metacell structure
#'
#' @export

mcell_mc_hierarchy = function(mc_id, mc_hc, T_gap)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("undefined meta cell object " , mc_id)
	}

	mc_ord = rep(0, length(mc_hc$order))
	mc_ord[mc_hc$order] = 1:length(mc_hc$order)

	n_mc = ncol(mc@mc_fp)

	lfp = log2(mc@mc_fp)

	parent = rep(-1, n_mc-1)
	cells = rep(0, times=n_mc-1)
	mcs = list()
	gaps = rep(0, times=n_mc-1)
	for(i in 1:nrow(mc_hc$merge)) {
		left = mc_hc$merge[i,1]
		right = mc_hc$merge[i,2]
		if(left < 0) {
			cs = names(which(mc@mc == -left))
			cell_left = length(cs)
			mc_left = -left
		} else {
			cell_left = cells[left]
			mc_left = mcs[left]
			parent[left] = i
			gaps[left] = mc_hc$height[i] - mc_hc$height[left]
		}
		if(right < 0) {
			cs = names(which(mc@mc == -right))
			cell_right= length(cs)
			mc_right = -right
		} else {
			cell_right= cells[right]
			mc_right = mcs[right]
			parent[right] = i
			gaps[right] = mc_hc$height[i] - mc_hc$height[right]
		}
#		message("in node ", i, " l ", left, " r ", right)
		mcs[[i]] = c(unlist(mc_right), unlist(mc_left))
		cells[i] = cell_right + cell_left
	}
	n_min_outcells = 300
	hits = list()
#	covered = rep(0, times = length(gaps))
	hit_i = 1
	sup_x = c()
	for(i in which(gaps > T_gap)) {
		j = parent[i]
		mincells = cells[i] + n_min_outcells
		while(j != -1 & cells[j] < mincells) {
			j = parent[j]
		}
		if(j != -1) {
#			message("node ", i, " sup ", j)
#& covered[j] == 0
			N = cells[j]
			n = cells[i]
			mcs_in = mcs[[i]]
			mcs_out = setdiff(mcs[[j]], mcs[[i]])
			lfp_avg_in = apply(lfp[,mcs_in], 1, mean)
			lfp_min_in = apply(lfp[,mcs_in], 1, min)
			lfp_max_in = apply(lfp[,mcs_in], 1, max)
			if(length(mcs_out) > 1) {
				lfp_max_out= apply(lfp[,mcs_out], 1, max)
				lfp_min_out= apply(lfp[,mcs_out], 1, min)
				lfp_avg_out= apply(lfp[,mcs_out], 1, mean)
			} else {
				if(length(mcs_out) == 0) {
					message("zero length mcs out??")
					stop("boom")
				}
				lfp_max_out= lfp[,mcs_out]
				lfp_min_out= lfp[,mcs_out]
				lfp_avg_out= lfp[,mcs_out]
			}

			e_marks = tail(sort(lfp_avg_in),20)
			sep_marks = tail(sort(lfp_min_in),20)
			marks_gap = tail(sort(lfp_avg_in - lfp_avg_out),20)
			marks_gap_anti = head(sort(lfp_avg_in - lfp_avg_out),20)

			x_ord = mean(mc_ord[mcs[[i]]])
			sup_x = c(sup_x, x_ord)
			hits[[hit_i]] = list(marks = e_marks,
								min_marks = sep_marks,
								marks_gap = marks_gap,
								marks_gap_anti=marks_gap_anti,
								mcs = mcs[[i]],
								x_ord = x_ord, sup_mcs = mcs[[j]])
			hit_i = hit_i + 1
		}
	}

	hits = hits[order(sup_x)]
	return(hits)
}

#' plot super strucutre: super clust mc footprint, and selected genes
#'
#' @param mc_id id of metacell object
#' @param graph_id id of graph for (Re-) constructing confusion matrix
#' @param mc_order the mc ordering (e.g., hc$order using the output of mcell_mc_hclust_confu)
#' @param sup_mcs the list you get from mcell_mc_hierarchy (for now)
#' @param width width of figure in pixels
#' @param height height of figure in pixels
#' @param fig_fn figure name (NULL will create a figure named [mc_id]_supmc_confu in the figure directory)
#' @param min_nmc minimal number of mc in supmc set, smaller gruops will not be plotted
#' @param shades heatmap color palette
#' @param plot_grid plot vertical grid in the heatmap
#' @param show_mc_ids plot mc ids below the heatmap
#'
#' @export

mcell_mc_plot_hierarchy = function(mc_id, graph_id, mc_order, sup_mcs, width, height, fig_fn=NULL, min_nmc=2, shades = colorRampPalette(c("white", "pink", "red", "black", "brown", "orange")), plot_grid=T, show_mc_ids=F)
{
	mc = scdb_mc(mc_id)
	if(is.null(mc)) {
		stop("undefined meta cell object " , mc_id)
	}
	n_mc = ncol(mc@mc_fp)
	colors = mc@colors

	confu = mcell_mc_confusion_mat(mc_id, graph_id, 1000, ignore_mismatch=T)
	r_confu = rowSums(confu)
	c_confu = colSums(confu)
	norm = r_confu %*% t(c_confu)
	confu_n = confu/norm

	confu_n = confu_n[mc_order, mc_order]
	colors = colors[mc_order]
	colnames(confu_n) = (1:ncol(confu_n))[mc_order]
	rownames(confu_n) = (1:ncol(confu_n))[mc_order]
	colors[is.na(colors)] = "gray"

	fps = as.matrix(do.call(cbind, lapply(sup_mcs,
					function(x) { fp = rep(0, n_mc);
										fp[unlist(x$sup_mcs)]=1;
										fp[unlist(x$mcs)]=2;
										fp })))

	if(is.null(fig_fn)) {
		fig_fn = scfigs_fn(mc_id, "supmc_confu")
	}
	marks = unlist(lapply(sup_mcs, function(x) {
						m = x$marks[x$marks > 0.4]
						return(paste(names(tail(m,5)),collapse=","))
					}
				))

	gap_marks = unlist(lapply(sup_mcs, function(x) {
						m = x$marks_gap[x$marks_gap > 0.4];
						s = rev(names(tail(m,5)));
						return(substr(paste(s, collapse=","),1,30))
					}
					))
	gap_amarks = unlist(lapply(sup_mcs, function(x) {
						m = x$marks_gap_anti[x$marks_gap_anti < -0.4];
						s = rev(names(head(m,5)));
						return(substr(paste(s, collapse=","),1,30))
					}
					))
	gap_marks = paste(gap_marks,gap_amarks,sep=" | ")
	marks = paste(marks, 1:length(marks), sep=" :")
	vert = F

	f_sup = colSums(fps>1)>min_nmc

	grids = -1+apply(fps[mc_order,f_sup],2,function(x) min(which(x>1)))
	grids = c(grids, apply(fps[mc_order,f_sup],2,function(x) max(which(x>1))))

	marks = marks[f_sup]
	gap_marks = gap_marks[f_sup]

	.plot_start(fig_fn, w=width, h=height)

	layout(matrix(c(1,2,3), ncol=1), heights=c(10,10,0.5))

	par(mar=c(0,30,2,40))
	image(fps[mc_order, f_sup], col=c("white", "lightgray", "blue"), xaxt='n', yaxt='n')
	mtext(marks, side = 2, at=seq(0,1,length.out=length(marks)), las=2, cex=1)
	mtext(gap_marks, side = 4, at=seq(0,1,len=length(marks)), las=2, cex=1)
	if (plot_grid) {
		abline(v=(-0.5+grids)/(n_mc-1), lwd=0.5)
	}

	par(mar=c(0,30,0,40))
	confu_nodiag = confu_n
	diag(confu_nodiag) = 0
	confu_n = pmin(confu_n, max(confu_nodiag))
	confu_n = pmin(confu_n, quantile(confu_n, 1-3/nrow(confu_n)))
	image(confu_n,col=shades(1000),xaxt='n', yaxt='n')
	if (plot_grid) {
		abline(v=(-0.5+grids)/(n_mc-1), lwd=0.5)
	}
	par(mar=c(5,30,0,40))
	image(as.matrix(1:n_mc,nrow=1), col=colors, yaxt='n', xaxt='n')

	if (show_mc_ids) {
		mtext(colnames(confu_n), side=1, at=seq(0, 1, len=ncol(confu_n)), las=2, line=1, cex=0.7)
	}
	dev.off()
}


# This is a test/example rd file
# Two spheres, metallic shader, three lights
# Left interpolated; right, not

Display "Metal Shader"  "Screen" "rgbdouble"
Format 640 480
CameraFOV 5
CameraEye 0 0 50

WorldBegin

FarLight 0 0 -1  1.0  1.0  1.0  1.0

FarLight  1  1 -0.5  1.0 0.0 0.0  0.5  #Red Light    -- Lower Left
FarLight  0 -1 -0.5  0.0 1.0 0.0  0.5  #Green Light  -- Up
FarLight -1  1 -0.5  0.0 0.0 1.0  0.5  #Blue Light   -- Lower Right

Ka 0.5
Kd 1.0
Ks 0.5

Color 0.9 0.8 0.2

Specular 1.0 1.0 1.0 10

Surface "metal"
#Surface "plastic"

Translate -1.25 0 0

Sphere 1.0 -1.0 1.0 360.0

Translate 2.5 0 0

OptionBool "Interpolate" off

Sphere 1.0 -1.0 1.0 360.0

WorldEnd


## Written by Eilis
## takes .info files (1 per chromosome) and creates plots to summarise imputation

args<-commandArgs(trailingOnly = TRUE)

library(data.table)
dirName<-args[1]
refFile<-args[2]
colName<-args[3]

refPanel<-fread(refFile, data.table = FALSE)
if(!"id" %in% colnames(refPanel)){
	refPanel$id<-paste(refPanel$"#CHROM", refPanel$POS, refPanel$REF, refPanel$ALT, sep = ":")
}

compRefPanel<-matrix(data = NA, ncol = 2, nrow = 22)
colnames(compRefPanel)<-c("cor", "MAD")
nVar<-matrix(data = 0, nrow = 10, ncol = 10)
for(chr in 1:22){
	png(paste(dirName,"/ImputationQualityPlots_chr", chr, ".png", sep = ""), width = 12, height = 8, units = "in", res = 200)
	par(mfrow = c(2,2))

	imputScores<-read.table(gzfile(paste(dirName,"/chr", chr, ".info.gz", sep = "")), header = TRUE, na.strings = "-")
	index<-match(imputScores$SNP,refPanel$id)

	plot(density(imputScores$Rsq, na.rm = TRUE), main = paste("chr", chr, sep = ""), xlab = "Rsq")

	## compare freq against refPanel
	plot(refPanel[index,colName],imputScores$ALT_Frq,xlab = "RefPanel MAF", ylab = "Imputed sample MAF", pch = 16)
	## calculate median absolute deviation
	mtext(side = 3, line = 0.5, adj = 1, paste("MAD =", signif(median(abs(refPanel[index,colName] -imputScores$ALT_Frq), na.rm = TRUE), 3), sep = ""))

	compRefPanel[chr,1]<-cor(refPanel[index,colName],imputScores$ALT_Frq, use = "p")
	compRefPanel[chr,2]<-median(abs(refPanel[index,colName] -imputScores$ALT_Frq), na.rm = TRUE)

	## summarise INFO score distribution by MAF
	tabRsqMAF<-table(cut(imputScores$Rsq, seq(0,1,0.1)), cut(imputScores$MAF, seq(0,0.5,0.05)))
	barplot(tabRsqMAF,ylab = "N variants", legend = rownames(tabRsqMAF), xlab = "MAF", col = colorRampPalette(c("white", "navy"))(10), main = paste("chr", chr, sep = ""))
	tabRsqMAFPer<-t(t(tabRsqMAF)/colSums(tabRsqMAF)*100)
	barplot(tabRsqMAFPer,ylab = "%", xlab = "MAF", col = colorRampPalette(c("white", "navy"))(10))

	nVar<-nVar+tabRsqMAF

	dev.off()
}

write.csv(nVar, paste(dirName,"/nVariantsSummary.csv", sep = ""))
write.csv(compRefPanel, paste(dirName,"/CompRefPanelSummary.csv", sep = ""))