#!/usr/bin/env Rscript

#--Load packages
#library(RColorBrewer)
#coul <- colorRampPalette(brewer.pal(5, "YlOrRd"))(25)
require(colorspace)
require(gplots)
require(dplyr)
coul <- heat_hcl(29, c=c(90, 40), l=c(30, 90), power=c(1/5, 1.5))

#--Load Fst
fstMat <- read.table("fstMatrix0.05.txt", header=F, as.is=T)
fstMat2 <- fstMat %>%
  mutate_at(vars(-V1), funs(./1000))
m <- as.matrix(fstMat2[,-c(1)])
rownames(m) <- fstMat2[,c(1)]
colnames(m) <- fstMat2[,c(1)]
#write.table(m, file = "fstMatrix0.05.txt", col.names=F, row.names=T,quote=F,sep="\t")

#--Load PCA
evecDat <- read.table("world-evecDat.txt", header=T, as.is=T)

#--Make plots

#fst
fst <- function() {
        distance = dist(m, method = "manhattan")
	cluster = hclust(distance, method = "ward.D")
	#heatmap.2(m, col = coul, density.info="none", trace="none", key.xlab=expression(F[ST]), key.title=NA)
        #jpeg("WorldHeat.jpeg", width = 7, height = 7, units = "in", res = 1200, pointsize = 12)
	heatmap.2(m,
		  col = coul,
		  density.info="none",
		  trace="none",
		  key.xlab=expression(F[ST]),
		  key.title=NA,
		  lmat = rbind(c(0,3),c(2,1),c(0,4)),
		  lwid = c(0.4,4),
		  lhei = c(1,9,2),
		  margins=c(2,8),
		  key.par = list(mar= c(4, 1, 3, 9)),
		  Rowv=as.dendrogram(cluster),
		  Colv=as.dendrogram(cluster),
		  #Colv=F
	)
	#dev.off()
}

#evec
ev <- function() {
         plot(evecDat[,2], evecDat[,3], xlab="PC1", ylab="PC2", type="n")
             for(i in 1:nrow(evecDat)){
             if(evecDat[i,13]=='BA') points(evecDat[i,2], evecDat[i,3], col="deeppink", pch=20)
             if(evecDat[i,13]=='SB') points(evecDat[i,2], evecDat[i,3], col="deeppink", pch=20)
             if(evecDat[i,13]=='FO') points(evecDat[i,2], evecDat[i,3], col="deeppink", pch=20)
             if(evecDat[i,13]=='ESN') points(evecDat[i,2], evecDat[i,3], col="deeppink1", pch=20)
             if(evecDat[i,13]=='YRI') points(evecDat[i,2], evecDat[i,3], col="deeppink1", pch=20)
             if(evecDat[i,13]=='MSL') points(evecDat[i,2], evecDat[i,3], col="deeppink2", pch=20)
             if(evecDat[i,13]=='GWD') points(evecDat[i,2], evecDat[i,3], col="deeppink3", pch=20)
             if(evecDat[i,13]=='LWK') points(evecDat[i,2], evecDat[i,3], col="deeppink1", pch=20)
             if(evecDat[i,13]=='ACB') points(evecDat[i,2], evecDat[i,3], col="deeppink4", pch=20)
             if(evecDat[i,13]=='ASW') points(evecDat[i,2], evecDat[i,3], col="deeppink4", pch=20)
             if(evecDat[i,13]=='CLM') points(evecDat[i,2], evecDat[i,3], col="gray54", pch=20)
             if(evecDat[i,13]=='MXL') points(evecDat[i,2], evecDat[i,3], col="gray53", pch=20)
             if(evecDat[i,13]=='PEL') points(evecDat[i,2], evecDat[i,3], col="gray52", pch=20)
             if(evecDat[i,13]=='PUR') points(evecDat[i,2], evecDat[i,3], col="gray51", pch=20)
             if(evecDat[i,13]=='CEU') points(evecDat[i,2], evecDat[i,3], col="chartreuse", pch=20)
             if(evecDat[i,13]=='FIN') points(evecDat[i,2], evecDat[i,3], col="chartreuse1", pch=20)
             if(evecDat[i,13]=='GBR') points(evecDat[i,2], evecDat[i,3], col="chartreuse2", pch=20)
             if(evecDat[i,13]=='IBS') points(evecDat[i,2], evecDat[i,3], col="chartreuse3", pch=20)
             if(evecDat[i,13]=='TSI') points(evecDat[i,2], evecDat[i,3], col="chartreuse4", pch=20)
             if(evecDat[i,13]=='BEB') points(evecDat[i,2], evecDat[i,3], col="royalblue", pch=20)
             if(evecDat[i,13]=='GIH') points(evecDat[i,2], evecDat[i,3], col="royalblue1", pch=20)
             if(evecDat[i,13]=='ITU') points(evecDat[i,2], evecDat[i,3], col="royalblue2", pch=20)
             if(evecDat[i,13]=='PJL') points(evecDat[i,2], evecDat[i,3], col="royalblue3", pch=20)
             if(evecDat[i,13]=='STU') points(evecDat[i,2], evecDat[i,3], col="royalblue4", pch=20)
             if(evecDat[i,13]=='CDX') points(evecDat[i,2], evecDat[i,3], col="goldenrod", pch=20)
             if(evecDat[i,13]=='CHB') points(evecDat[i,2], evecDat[i,3], col="goldenrod1", pch=20)
             if(evecDat[i,13]=='CHS') points(evecDat[i,2], evecDat[i,3], col="goldenrod2", pch=20)
             if(evecDat[i,13]=='JPT') points(evecDat[i,2], evecDat[i,3], col="goldenrod3", pch=20)
             if(evecDat[i,13]=='KHV') points(evecDat[i,2], evecDat[i,3], col="goldenrod4", pch=20)
             }
}

#--PCA legend
legn <- function() {
             legend("center", c("BA=BANTU","SB=SEMI-BANTU","FO=FULBE","ESN=ESAN in Nigeria","YRI=Yoruba in Ibadan, Nigeria",
                                "MSL=Mende in Sierra Leone", "GWD=Gambian Mandinka", "LWK=Luhya in Webuye, Kenya",
                                "ACB=African Caribbean in Barbados", "ASW=African-American SW",
                                "CLM=Colombian", "MXL=Mexican-American", "PEL=Peruvian", "PUR=Puerto Rican",
                                "CEU=CEPH", "FIN=Finnish", "GBR=British in England and Scotland",
                                "IBS=Iberian populations in Spain", "TSI=Toscani in Italy","", "BEB=Bengali in Bangladesh",
                                "GIH=Gujarati Indian in Houston, TX", "ITU=Indian Telugu in the UK",
                                "PJL=Punjabi in Lahore, Pakistan", "STU=Sri Lankan Tamil in the UK",
                                "CDX=Dai Chinese", "CHB=Han Chinese", "CHS=Southern Han Chinese", "JPT=Japanese",
                                "KHV=Kinh Vietnamese"),
                             col=c("deeppink", "deeppink","deeppink","deeppink1","deeppink1",
                                "deeppink2", "deeppink2","deeppink3","deeppink4","deeppink4","gray54","gray53",
                                "gray52","gray51","chartreuse","chartreuse1", "chartreuse2","chartreuse3",
                                "chartreuse4","white","royalblue","royalblue1","royalblue2","royalblue3","royalblue4",
                                "goldenrod","goldenrod1", "goldenrod2","goldenrod3","goldenrod4"),
                             pch=c(20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,1,20,20,20,20,20,20,20,20,20,20),
                             ncol=3, bty="n", cex=0.7)
}

#   #--Plot all
#   #jpeg("WorldHeatPCA.jpeg", width = 15, height = 10, units = "in", res = 1200, pointsize = 14)
#   pdf("WorldPCA_Heat.pdf", width = 15, height = 10, pointsize = 13, colormodel="cmyk", paper="A4")
#     layout.matrix <- matrix(c(1, 2), nrow = 1, ncol = 2)
#     layout(mat = layout.matrix)
#      par(fig=c(0,0.5,0,1), new=T)
#       plot.new()
#       fst()
#      par(fig=c(0.5,1,0.35,1), mar=c(4,4,2,1), new=T, bty="n", cex=0.9, cex.lab=0.8)
#       plot.new()
#       ev()
#      par(fig=c(0.5,1,0,0.40), mar=c(4,2,0,0), new=T, bty="l", cex=0.9)
#       plot.new()
#       legn()
#   dev.off()

#--Plot Fst
bitmap("WorldHeat.tiff", width = 7, height = 7, units = "in", res = 300, points=12)
#pdf("WorldHeat.pdf", width = 7, height = 7, pointsize = 13, colormodel="cmyk", paper="A4")
  fst()
dev.off()

#--Plot PCA
#jpeg("WorldPCA.jpeg", width = 7, height = 7, units = "in", res = 1200, pointsize = 12)
bitmap("WorldPCA.tiff", width = 7, height = 8, units = "in", res = 300, pointsize=14)
#pdf("WorldPCA.pdf", width = 6, height = 8, pointsize = 13, colormodel="cmyk", paper="A4")
   par(fig=c(0,1,0.35,1), mar=c(4,4,4,2), bty="n", cex=1, cex.lab=0.6, cex.axis=0.6)
    #plot.new()
    ev()
   par(fig=c(0,1,0,0.40), mar=c(4,3,0,0), new=T, bty="l", cex=0.8)
    plot.new()
    legn()
dev.off()


#' Train deep learning SDM
#'
#' @importFrom magrittr %>%
#'
#' @param input_data A dataframe containing parsed and processed deep learning data.
#'
#' @return A list containing the trained deep learning model object and a history object for performance evaluation.
#' @examples
#' \dontrun{
#' # download benchmarking data
#' benchmarking_data <- get_benchmarking_data("Lynx lynx",
#'                                            limit = 1500)
#'
#' # transform benchmarking data into a format suitable for deep learning
#' # if you have previously used a partitioning method you should specify it here
#' benchmarking_data_dl <- prepare_dl_data(input_data = benchmarking_data$df_data,
#'                                        partitioning_type = "default")
#'
#' # perform sanity check on the transformed dataset
#' # for the training set
#' head(benchmarking_data_dl$train_tbl)
#' table(benchmarking_data_dl$y_train_vec)
#'
#' # for the test set
#' head(benchmarking_data_dl$test_tbl)
#' table(benchmarking_data_dl$y_test_vec)
#'
#' # train neural network
#' keras_results <- train_dl(benchmarking_data_dl)
#'
#' # inspect results
#' keras_results$history
#'
#' # you can also plot them
#' plot(keras_results$history)
#'}
#'@export
train_dl <- function(input_data) {
    # initialize model
    model_keras <- keras::keras_model_sequential()

    # specify network architecture
    model_keras %>%
        keras::layer_dense(units = 13,
                           kernel_initializer = "uniform",
                           activation = "relu",
                           input_shape = ncol(input_data$train_tbl)) %>%
        keras::layer_dropout(rate = 0.1) %>%
        keras::layer_dense(units = 13,
                           kernel_initializer = "uniform",
                           activation = "relu") %>%
        keras::layer_dropout(rate = 0.1) %>%
        keras::layer_dense(units = 1,
                           kernel_initializer = "uniform",
                           activation = "sigmoid") %>%
        keras::compile(optimizer = "adam",
                       loss = "binary_crossentropy",
                   metrics = c("accuracy"))

    # train model
    history <- keras::fit(object = model_keras,
                          x = as.matrix(input_data$train_tbl),
                          y = input_data$y_train_vec,
                          batch_size = 50,
                          epochs = 100,
                          validation_split = 0.3,
                          view_metrics = FALSE,
                          verbose = 0)

    result_list <- list(model = model_keras,
                        history = history)

    return(result_list)
}


#Read in the data
cdata <- read.table("german.data", h=F, sep = ' ')

#Add readable column names
colnames(cdata) <- c("chkngAcctStatus", "durationMonths", "creditHistory", "loanPurpose", "creditAmount", "savingsTotal", "crrntEmplmtSince", "instllmtPct", "persnlStatus", "othrDebtorGuaranters", "crrntResidenceSince", "propertyType", "age", "otherInstllmtType", "housingType", "existingCredits","jobStatus", "numDependents", "registeredPhone", "foriegnWorker", "goodBad")

#Change the target variable into categorical with values 'Good' and 'Bad'
cdata$goodBad<-as.factor(ifelse(cdata$goodBad == 1, "Good", "Bad"))

cdata %>% plot_ly(x = cdata$goodBad, type = "histogram") %>% layout(title = "Histogram of 'Good' vs 'Bad'")

#A base plot is created across Total savings and the target:

plot(cdata$savingsTotal, cdata$goodBad,
     main="Savings account/bonds ~ Good-Bad",
     xlab="Savings/Bonds",
     ylab="Good-Bad", legend = T)

#Then the next piece of code shows the median loan duration in months against defaults:

cdata_df <- tbl_df(cdata)

cdata_df %>% group_by(goodBad) %>% summarise(meanMonths = mean(durationMonths), medianMonths = median(durationMonths))  %>% plot_ly(x = ~goodBad, y = ~medianMonths, type = "bar") %>% layout(title = " median loan duration in months vs goodBad")

#We then created Scatter plot of Credit Amount and Age with color separation of Good and Bad loans:
cdata_df %>% plot_ly(x = ~age, y = ~creditAmount, color = ~goodBad, colors = c("red", "blue"), type = "scatter", mode = "markers" ) %>% layout(title = "Age vs creditAmount by goodBad")


#library(igraph)
library(sna)
#library(network)

#loading.attributes
x<-Cit.HepPh.WithDates[c(1:10000),c(1,3)]
x$val<-1
names(x)<-c('snd','rec','val')
g<-as.matrix(x)
#g <- graph.data.frame(d = x, directed = T)
#g<-network(x, matrix.type = 'edgelist', directed=TRUE)

#g<-rgraph(10,tprob=0.06)
#g<-as.edgelist.sna(g)
#Find weak components
cd<-component.dist(g,connected="weak")
cd$membership              #Who's in what component?
cd$csize                   #What are the component sizes?
#Plot the size distribution
plot(1:length(cd$cdist),cd$cdist/sum(cd$cdist),ylim=c(0,1),type="h")
lgc<-component.largest(g,connected="weak")  #Get largest component
gplot(g,vertex.col=2+lgc)  #Plot g, with component membership
#Plot largest component itself

png(filename = "Rnetwork.png",
    width = 1160, height = 1160, units = "px", pointsize = 12,
    bg = "transparent")
gplot(component.largest(g,connected="weak",result="graph"))
dev.off()


install.packages("quantmod")
install.packages("httr")
install.packages("Quandl")
install.packages("plotly")
install.packages("devtools")
devtools::install_github("amrrs/coinmarketcapr")
install.packages("coindeskr")
require(devtools)
# install.packages("quantstrat", repos = "http://R-Forge.R-project.org") # package ‘quantstrat’ is not available (for R version 4.0.1)
devtools::install_github("braverock/blotter")
devtools::install_github("braverock/quantstrat")

# getting started

# initialization of a variable
my_numeric_variable <- 1
my_string_variable <- "hello"
# print a variable
my_numeric_variable # and type enter
print(my_string_variable)

# vectors
myNumericVector = c(1,2,3,4,5,6)
mySequence = 1:24
myStringVector = c("hello", "world", "!")
myStringVector[1] # print hello
myStringVector[-2] # print hello!
myStringVector[1:2] # print hello world
myStringVector[c(1,3)] # print hello!

myLogicVector = c(TRUE, FALSE, T, F)
assign("myVector", c(1:6))
# operations with vectors
sum(myNumericVector)
mean(myNumericVector)
median(myNumericVector)
myVector*2
myVector/2
myNewVector <- myNumericVector + myVector # allow
myNewVector <- myNumericVector + mySequence # allow
myNewVector <- myNumericVector + c(1:5) # deny

# matrix
myMatrix <- matrix(1:10, nrow = 2, ncol = 5)
myMatrix[2,2] # prints 4
myMatrix[1,] # prints row 1
myMatrix[,2] # prints column 2
# merge of vectors
vectorOne <- c("one", 0.1)
vectorTwo <- c("two", 1)
vectorThree <- c("three", 10)
myVectors <- matrix(c(vectorOne, vectorTwo, vectorThree), nrow = 3, ncol = 2, byrow = 1)
colnames(myVectors) <- c("vector number", "quantity")
rownames(myVectors) <- c("yesterday", "today", "tomorrow")

# functions
RSIaverage <- function(price, n1, n2) {
  RSI_1 <- RSI(price = price, n = n1)
  RSI_2 <- RSI(price = price, n = n2)
  calculatedAverage <- (RSI_1 + RSI_2) / 2
  colnames(calculatedAverage) <- "RSI_average"
  return(calculatedAverage)
}


repo = "http://cran.us.r-project.org"
library(caret)
library(ggfortify)
library(ggplot2)
library(dplyr)
library(rpart)
library(rpart.plot)
library(RSQLite)
library(DBI)
library(randomForest)
library(e1071)
library(class)

remove_cols= function(l, cols){
    return(l[! l %in% cols])
}

make_factors = function(model_data){
model_data$Structure1 = as.factor(model_data$Structure1)
model_data$Pipe_Geome = as.factor(model_data$Pipe_Geome)
model_data$Pipe_Mater = as.factor(model_data$Pipe_Mater)
model_data$Condition = as.factor(model_data$Condition)
return(model_data)
}

base_dir<- "C:/Users/Jeff/Documents/research/Sadler_3rdPaper/manuscript/"
data_dir<- "C:/Users/Jeff/Google Drive/research/Sadler_3rdPaper_Data/"
fig_dir <- paste(base_dir, "Figures/general/", sep="")
db_filename <- "floodData.sqlite"

con = dbConnect(RSQLite::SQLite(), dbname=paste(data_dir, db_filename, sep=""))

test_df = dbReadTable(con, 'test_geog_data_hg')
train_df = dbReadTable(con, 'train_geog_data_hg')

colnames(test_df)

cols_to_remove = c('level_0', 'index', 'is_dntn', 'flood_pt', 'event_name', 'num_flooded', 'location', 'count', 'flooded', 'in_hague')
in_col_names = remove_cols(colnames(test_df), cols_to_remove)
out_col_name = 'flooded'

test_df = make_factors(test_df)
train_df = make_factors(train_df)

train_data = train_df[, append(in_col_names, out_col_name)]
test_data = test_df[, append(in_col_names, out_col_name)]

train_in_data = train_df[, in_col_names]
test_in_data = test_df[, in_col_names]

tst_out = test_df[, out_col_name]
trn_out = train_df[, out_col_name]

dt_fmla = as.formula(paste(out_col_name, "~", paste(in_col_names, collapse="+")))

colnames(train_data)

fit = rpart(dt_fmla, method='class', data=train_data, minsplit=1, minbucket=1)
printcp(fit)

tiff(paste(fig_dir, "Plot_hg.tif"), width=9, height=6, units='in', res = 300)
rpart.plot(fit, under=TRUE, cex=0.9, extra=1, varlen = 6)
dev.off()
rpart.plot(fit, under=TRUE, cex=0.9, extra=1, varlen = 6)

pfit<- prune(fit, cp=fit$cptable[which.min(fit$cptable[,"xerror"]),"CP"])
rpart.plot(pfit, under=TRUE, cex=0.8, extra=1, varlen = 6)

pred = predict(pfit, train_data, type = 'class')
table(trn_out, pred)

pred = predict(pfit, test_data, type = 'class')
table(tst_out, pred)


#' ---
#' author: "Jenny Bryan"
#' output: github_document
#' ---

#+ setup, include = FALSE
library(knitr)
opts_chunk$set(fig.path = 'figure/scatterplot-', error = TRUE)

#' Note: this report is made by rendering an R script. So the narrative is very
#' minimal.

library(tibble)
library(ggplot2)

#' Load the [`gapminder`](https://github.com/jennybc/gapminder) data package.
library(gapminder)
gapminder

ggplot(gapminder, aes(x = gdpPercap, y = lifeExp)) # nothing to plot yet!

ggplot(gapminder, aes(x = gdpPercap, y = lifeExp)) +
  geom_point()

p <- ggplot(gapminder, aes(x = gdpPercap, y = lifeExp)) # just initializes

#' scatterplot
p + geom_point()

#' log transformation ... quick and dirty
ggplot(gapminder, aes(x = log10(gdpPercap), y = lifeExp)) +
  geom_point()
#' a better way to log transform
p + geom_point() + scale_x_log10()

#' let's make that stick
p <- p + scale_x_log10()
#' common workflow: gradually build up the plot you want
#' re-define the object 'p' as you develop "keeper" commands

#' convey continent by color: MAP continent variable to aesthetic color
p + geom_point(aes(color = continent))
## add summary(p)!
plot(gapminder, aes(x = gdpPercap, y = lifeExp, color = continent)) +
  geom_point() + scale_x_log10() # in full detail, up to now

#' address overplotting: SET alpha transparency and size to a value
p + geom_point(alpha = (1/3), size = 3)

#' add a fitted curve or line
p + geom_point() + geom_smooth()
p + geom_point() + geom_smooth(lwd = 3, se = FALSE)
p + geom_point() + geom_smooth(lwd = 3, se = FALSE, method = "lm")

#' revive our interest in continents!
p + aes(color = continent) + geom_point() +
  geom_smooth(lwd = 3, se = FALSE)

#' facetting: another way to exploit a factor
p + geom_point(alpha = (1/3), size = 3) +
  facet_wrap(~ continent)
p + geom_point(alpha = (1/3), size = 3) +
  facet_wrap(~ continent) +
  geom_smooth(lwd = 2, se = FALSE)

#' exercises:

#' * plot lifeExp against year
ggplot(gapminder, aes(x = year, y = lifeExp,
                      color = continent)) +
  geom_jitter(alpha = 1/3, size = 3)

#' * make mini-plots, split out by continent
#' HINT: use facet_wrap()
ggplot(gapminder, aes(x = year, y = lifeExp,
                      color = continent)) +
  facet_wrap(~ continent, scales = "free_x") +
  geom_jitter(alpha = 1/3, size = 3) +
  scale_color_manual(values = continent_colors)

ggplot(subset(gapminder, continent != "Oceania"),
       aes(x = year, y = lifeExp, group = country, color = country)) +
  geom_line(lwd = 1, show_guide = FALSE) + facet_wrap(~ continent) +
  scale_color_manual(values = country_colors) +
  #scale_color_brewer()+
  theme_bw() + theme(strip.text = element_text(size = rel(1.1)))

#' * add a fitted smooth and/or linear regression, w/ or w/o facetting

ggplot(gapminder, aes(x = year, y = lifeExp,
                      color = continent)) +
  facet_wrap(~ continent, scales = "free_x") +
  geom_jitter(alpha = 1/3, size = 3) +
  scale_color_manual(values = continent_colors) +
  geom_smooth(lwd = 2)

#' * use `dplyr::filter()` to plot lifeExp against
#' year for just one country or continent
jc <- "Cambodia"
gapminder %>%
  filter(country == jc) %>%
  ggplot(aes(x = year, y = lifeExp)) +
  labs(title = jc) +
  geom_line()

rwanda <- gapminder %>%
  filter(country == "Rwanda")
p <- ggplot(rwanda, aes(x = year, y = lifeExp)) +
  labs(title = "Rwanda") +
  geom_line()
print(p)
ggsave("rwanda.pdf")
ggsave("rwanda.pdf",plot = p)

#' * other ideas?

#' plot lifeExp against year
(y <- ggplot(gapminder, aes(x = year, y = lifeExp)) + geom_point())

#' make mini-plots, split out by continent
y + facet_wrap(~ continent)

#' add a fitted smooth and/or linear regression, w/ or w/o facetting
y + geom_smooth(se = FALSE, lwd = 2) +
  geom_smooth(se = FALSE, method ="lm", color = "orange", lwd = 2)

y + geom_smooth(se = FALSE, lwd = 2) +
  facet_wrap(~ continent)

#' last bit on scatterplots
#' how can we "connect the dots" for one country?
#' i.e. make a spaghetti plot?
y + facet_wrap(~ continent) + geom_line() # uh, no
y + facet_wrap(~ continent) + geom_line(aes(group = country)) # yes!
y + facet_wrap(~ continent) + geom_line(aes(group = country)) +
  geom_smooth(se = FALSE, lwd = 2)

#' note about subsetting data

#' sadly, ggplot() does not have a 'subset =' argument
#' so do that 'on the fly' with subset(..., subset = ...)
ggplot(subset(gapminder, country == "Zimbabwe"),
       aes(x = year, y = lifeExp)) + geom_line() + geom_point()

#' or could do with dplyr::filter
suppressPackageStartupMessages(library(dplyr))
ggplot(gapminder %>% filter(country == "Zimbabwe"),
       aes(x = year, y = lifeExp)) + geom_line() + geom_point()

#' let just look at four countries
jCountries <- c("Canada", "Rwanda", "Cambodia", "Mexico")
ggplot(subset(gapminder, country %in% jCountries),
       aes(x = year, y = lifeExp, color = country)) + geom_line() + geom_point()

#' when you really care, make your legend easy to navigate
#' this means visual order = data order = factor level order
ggplot(subset(gapminder, country %in% jCountries),
       aes(x = year, y = lifeExp, color = reorder(country, -1 * lifeExp, max))) +
  geom_line() + geom_point()

#' another approach to overplotting
#' ggplot(gapminder, aes(x = gdpPercap, y = lifeExp)) +
ggplot(gapminder, aes(x = gdpPercap, y = lifeExp)) +
  scale_x_log10() + geom_bin2d()

sessionInfo()


###Ranking hospitals in all states

rankall <- function(outcome, num = "best"){
    ## Read outcome data
    data <- read.csv("outcome-of-care-measures.csv", colClasses = "character")
    fd   <- as.data.frame(cbind(data[, 2],  # col 2 for hospital
                                data[, 7],  # col 7 for state
                                data[, 11],  # col 11 for  heart attack
                                data[, 17],  # col 17 for heart failure
                                data[, 23]), # col 23 for pneumonia
                          stringsAsFactors = FALSE)
    colnames(fd) <- c("hospital", "state", "heart attack", "heart failure", "pneumonia")
    fd[, eval(outcome)] <- as.numeric(fd[, eval(outcome)])

    ## Check that state and outcome are valid

    if (!outcome %in% c("heart attack", "heart failure", "pneumonia")){
        stop('invalid outcome')
    } else if (is.numeric(num)) {
        bystate <- with(fd, split(fd, state))
        ordered  <- list()
        for (i in seq_along(bystate)){
            bystate[[i]] <- bystate[[i]][order(bystate[[i]][, eval(outcome)],
                                                 bystate[[i]][, "hospital"]), ]
            ordered[[i]]  <- c(bystate[[i]][num, "hospital"], bystate[[i]][, "state"][1])
        }
        result <- do.call(rbind, ordered)
        output <- as.data.frame(result, row.names = result[, 2], stringsAsFactors = FALSE)
        names(output) <- c("hospital", "state")
    } else if (!is.numeric(num)) {
        if (num == "best") {
            bystate <- with(fd, split(fd, state))
            ordered  <- list()
            for (i in seq_along(bystate)){
                bystate[[i]] <- bystate[[i]][order(bystate[[i]][, eval(outcome)],
                                                     bystate[[i]][, "hospital"]), ]
                ordered[[i]]  <- c(bystate[[i]][1, c("hospital", "state")])
            }
            result <- do.call(rbind, ordered)
            output <- as.data.frame(result, stringsAsFactors = FALSE)
            rownames(output) <- output[, 2]
        } else if (num == "worst") {
            bystate <- with(fd, split(fd, state))
            ordered  <- list()
            for (i in seq_along(bystate)){
                bystate[[i]] <- bystate[[i]][order(bystate[[i]][, eval(outcome)],
                                                     bystate[[i]][, "hospital"],
                                                     decreasing = TRUE), ]
                ordered[[i]]  <- c(bystate[[i]][1, c("hospital", "state")])
            }
            result <- do.call(rbind, ordered)
            output <- as.data.frame(result, stringsAsFactors = FALSE)
            rownames(output) <- output[, 2]
        } else {
            stop('invalid num')
        }
    }
return(output)
}


"0.0"
"+0.0"
"-0.0"
"1.2"
"1.2E10"
"1.2E+10"
"1.2E-10"
"1.2e10"
"1.2e+10"
"1.2e-10"
"1.2e0"
"1.2e+0"
"1.2e-0"
".2"
".2e0"
".2e+0"
".2e-0"
",2"


## ----load packages, echo=FALSE-------------------------------------------
library(tidyverse)
library(lubridate)
library(broom)

## ----read TB incidence data and check------------------------------------
tb <- read_csv(here::here("data/TB_notifications_2019-07-01.csv"))
tb %>%                                  # first we get the tb data
  filter(year == 2016) %>%              # then we focus on just the year 2016
  group_by(country) %>%                 # then we group by country
  summarize(
    cases = sum(c_newinc, na.rm=TRUE)   # to create a summary of all new cases
    ) %>%
  arrange(desc(cases))                  # then we sort countries to show highest number new cases first

## ----example 1 What are the variables, echo=FALSE------------------------
grad <- read_csv("../data/graduate-programs.csv")
head(grad[c(2,3,4,6)])

## ----example 2 whats in the column names, echo=FALSE---------------------
genes <- read_csv("../data/genes.csv")
head(genes)

## ----example 3 what are the variables and records, echo=FALSE------------
melbtemp <- read.fwf("../data/ASN00086282.dly",
   c(11, 4, 2, 4, rep(c(5, 1, 1, 1), 31)), fill=T)
head(melbtemp[,c(1,2,3,4,seq(5,100,4))])

## ----example 4 what are the variables and experimental units, echo=FALSE----
tb <- read_csv(here::here("data/tb.csv"))
tail(tb)
#colnames(tb)

## ----example 4 what are the variables and observations, echo=FALSE-------
pew <- read.delim(
  file = "http://stat405.had.co.nz/data/pew.txt",
  header = TRUE,
  stringsAsFactors = FALSE,
  check.names = F
)
pew[1:5, 1:5]

## ----example 6 what are the factors measurements and experimental units, echo = FALSE----
load(here::here("data/french_fries.rda"))
head(french_fries, 4)

## ----setup a simple example, echo = FALSE--------------------------------
dframe <- data.frame(id = 1:2, trtA=c(2.5,4.6), trtB = c(45, 35))

## ----gather the example data into long form------------------------------
dframe
dframe %>% gather(treatment, outcome, trtA, trtB)

## ----read in and process the TB data-------------------------------------
read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  select(country, iso3, year, starts_with("new_sp_")) %>%
  head()

## ----turn TB data into long form-----------------------------------------
tb1 <- read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  select(country, iso3, year, starts_with("new_sp_")) %>%
  gather(key, count, starts_with("new_sp_"))
tb1 %>% na.omit() %>% head()

## ----extract variable names from original column names-------------------
tb2 <- tb1 %>%
  separate(key, sep = "_", into=c("foo_new", "foo_sp", "sexage"))
tb2 %>% na.omit() %>% head()

## ----continue extracting variable names----------------------------------
tb3 <- tb2 %>% select(-starts_with("foo")) %>%
  mutate(sex=substr(sexage, 1, 1),
         age=substr(sexage, 2, length(sexage))) %>%
  select(-sexage)
tb3 %>% na.omit() %>% head()

## ----your turn to work on the french fries data, echo=FALSE--------------
head(french_fries)

## ----put french fries in long form---------------------------------------
ff_long <- gather(french_fries, key = type, value =
                    rating, potato:painty)
head(ff_long)

## ----spread it back into wide form---------------------------------------
french_fries_weeks <- spread(ff_long, key = time,
                             value = rating)

head(french_fries_weeks)

## ----week 1 vs week 9, fig.width=5, fig.height = 5-----------------------
french_fries_weeks %>%
  ggplot(aes(x = `1`, y = `9`)) + geom_point()

## ----ratings on the different scales-------------------------------------
ff.m <- french_fries %>%
gather(type, rating, -subject, -time, -treatment, -rep)
head(ff.m)

## ---- fig.height=2, fig.width=8------------------------------------------
ggplot(data=ff.m, aes(x=rating)) + geom_histogram(binwidth=2) +
facet_wrap(~type, ncol=5)

## ----side-by-Side boxplots, fig.width=8, fig.height=5--------------------
ggplot(data=ff.m, aes(x=type, y=rating, fill=type)) +
geom_boxplot()

## ----ratings by week, fig.width=8, fig.height=5--------------------------
ff.m$time <- as.numeric(ff.m$time)
ggplot(data=ff.m, aes(x=time, y=rating, colour=type)) +
geom_point(size=.75) +
geom_smooth() +
facet_wrap(~type)

## ------------------------------------------------------------------------
genes <- read_csv("../data/genes.csv")

## ----compute group means--------------------------------
gmean <- gtidy %>%
  group_by(id, trt, time) %>%
  summarise(expr = mean(expr))
## ----plot the genes data overlais with group means, echo=FALSE, fig.width=5, fig.height = 5----
gtidy %>%
  ggplot(aes(x = trt, y = expr, colour=time)) +
  geom_point() +
  geom_line(data = gmean, aes(group = time)) +
  facet_wrap(~id)

## ----models and model output---------------------------------------------
ff_long <- gather(french_fries, key = type, value =
rating, potato:painty)
ff_lm <- lm(rating~type+treatment+time+subject,
data=ff_long)

## ----examine the model fit-----------------------------------------------
summary(ff_lm)

## ----goodness of fit statistics------------------------------------------
glance(ff_lm)

## ----model estimates-----------------------------------------------------
ff_lm_tidy <- tidy(ff_lm)
glimpse(ff_lm_tidy)

## ----model diagnostics---------------------------------------------------
ff_lm_all <- augment(ff_lm)
glimpse(ff_lm_all)

## ----residual plot-------------------------------------------------------
ggplot(ff_lm_all, aes(x=.fitted, y=.resid)) + geom_point()

## ----add random intercepts for each subject, results='hide'--------------
library(lme4)
fries_lmer <- lmer(rating~type+treatment+time+subject + ( 1 | subject ),
data = ff_long)

## the model is pretty bad:
ff_lmer_all <- augment(fries_lmer)

ggplot(ff_lmer_all, aes(x=.fitted, y=.resid)) + geom_point() +
  coord_equal()

ggplot(ff_lmer_all, aes(x=.fitted, y=rating)) + geom_point() +
  coord_equal()


################################################################
## Title: Data Science For Database Professionals
## Description:: Data Exploration
## Author: Microsoft
################################################################

####################################################################################################
##Compute context
####################################################################################################
connection_string <- "Driver=SQL Server;Server=.;Database=telcoedw2;Trusted_Connection=yes;"
sql <- RxInSqlServer(connectionString = connection_string, autoCleanup = FALSE, consoleOutput = TRUE)
local <- RxLocalParallel()
rxOptions(reportProgress = 0)

####################################################################################################
##Connect to the data
####################################################################################################
rxSetComputeContext(local)

##SQL data source
myDataTb <- RxSqlServerData(
  connectionString = connection_string,
  table = "edw_cdr",
  colInfo = col_info)
rxGetInfo(myDataTb, getVarInfo = T, numRows = 3)

##Data frame
myData <- rxDataStep(myDataTb, overwrite = TRUE)
str(myData)

####################################################################################################
##Data exploration and visualization on the data frame myData
####################################################################################################

#pie chart of customer churn
library(ggplot2)
ggplot(data = myData,
       aes(x = factor(1), fill = churn)) +
       geom_bar(width = 1) +
       coord_polar(theta = "y")

#density plot of age
ggplot(data = myData,
       aes(x = age)) +
  geom_density(fill = "salmon",
               bw = "SJ",
               colour = NA) +
  geom_rug(colour = "salmon") +
  theme_minimal()

#boxplot of age by churn
ggplot(data = myData,
       aes(x = reorder(churn, - age),
           y = age,
           colour = churn)) +
  geom_boxplot() +
  labs(x = "churn",
       y = "age") +
  theme_minimal() +
  theme(legend.position = "none")

#density plot of annualincome
  ggplot(data = myData,
         aes(x = annualincome)) +
    geom_density(fill = "salmon",
                 bw = "SJ",
                 colour = NA) +
    geom_rug(colour = "salmon") +
    theme_minimal()

#boxplot of annualincome by churn
ggplot(data = myData,
       aes(x = reorder(churn, - annualincome),
           y = annualincome,
           colour = churn)) +
  geom_boxplot() +
  labs(x = "churn",
       y = "annualincome") +
  theme_minimal() +
  theme(legend.position = "none")

#impact of education level on churn
library(dplyr)
myData %>%
    group_by(month, education) %>%
    summarize(countofchurn = sum(as.numeric(churn))) %>%
    ggplot(aes(x = month,
               y = countofchurn,
               group = education,
               fill = education)) +
    geom_bar(stat = "identity", position = position_dodge()) +
    labs(x = "month",
         y = "Counts of churn") +
    theme_minimal()

#impact of callfailure rate (%) on churn
myData %>%
   group_by(month, callfailurerate) %>%
   summarize(countofchurn = sum(as.numeric(churn)) ) %>%
   ggplot(aes(x = month,
              y = countofchurn,
              group = factor(callfailurerate),
              fill = factor(callfailurerate))) +
  geom_bar(stat = "identity", position = position_dodge()) +
  labs(x = "month",
       y = "Counts of churn") +
  theme_minimal()

#count of customers by % callsoutsidenetwork
myData %>%
  group_by(percentagecalloutsidenetwork) %>%
  summarize(countofcustomer = length(unique(customerid))) %>%
  ggplot(aes(x = percentagecalloutsidenetwork,
             y = countofcustomer)) +
  geom_bar(stat = "identity", fill = "orange") +
  labs(x = "% callsoutsidenetwork",
       y = "Counts of Customerid") +
  theme_minimal()

#count of customers by calldroprate
myData %>%
  group_by(calldroprate) %>%
  summarize(countofcustomer = length(unique(customerid))) %>%
  ggplot(aes(x = calldroprate,
             y = countofcustomer)) +
  geom_bar(stat = "identity", fill = "steelblue") +
  labs(x = "% calldroprate",
       y = "Counts of Customerid") +
  theme_minimal()

# Comparing the proportions of customer churn at individual state for several education levels
library(GGally)
  proportions <- myData %>%
    group_by(state, education) %>%
    summarise(countofchurn = sum(as.numeric(churn))) %>%
    ungroup() %>%
    group_by(state) %>%
    summarise(Prop_BA = sum(countofchurn[education == "Bachelor or equivalent"]) / sum(countofchurn),
              Prop_HS = sum(countofchurn[education == "High School or below"]) / sum(countofchurn),
              Prop_MA = sum(countofchurn[education == "Master or equivalent"]) / sum(countofchurn))

ggpairs(proportions, columns = 2:ncol(proportions)) + theme_bw()

####################################################################################################
##Data exploration and visualization on the SQL data source myDataTb
####################################################################################################
rxSetComputeContext(sql)

#Counts(Percentages) of customers churned or non-churned (Pareto Chart)
tmp <- rxCube( ~ churn, myDataTb, means = FALSE)
Results_df <- rxResultsDF(tmp)
library(qcc)
CountOfChurn <-
  setNames(as.numeric(Results_df[, 2]), Results_df[, 1])
par(oma = c(2, 2, 2, 2))
pareto <- pareto.chart(CountOfChurn,
                     xlab = "Churn", ylab = "Counts",
                     ylab2 = "Cumulative Percentage", cex.names = 0.5, las = 1,
                     col = heat.colors(length(CountOfChurn)), plot = TRUE)

#Counts of customer over age/annualincome by churn
rxHistogram( ~ age | churn, myDataTb)
rxHistogram(~ annualincome | churn, myDataTb)

#Counts of churned customer by age and state (Interactive HeatMap)
tmp <- rxCrossTabs(N(churn) ~ F(age):state, myDataTb, means = FALSE)
Results_df <- rxResultsDF(tmp, output = "sums")
colnames(Results_df) <- substring(colnames(Results_df), 7)
library(Rcpp)
library(d3heatmap)
d3heatmap(data.matrix(Results_df[, -1]), scale = "none", labRow = Results_df[, 1], dendrogram = "none",
          color = cm.colors(255))


library(ggvis)

# Scatter plot with loess model line
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  compute_smooth(mpg ~ wt, se = F) %>%
  layer_paths(x = ~pred_, y = ~resp_, stroke := "red")

# Or with shorthand layer_smooth
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_smooths(stroke := "red")

# With confidence region
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_smooths(stroke := "red", se = TRUE)

# Scatter plot with lm model line
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_model_predictions(stroke := "red", model = "lm")

# Scatterplot with lm and loess
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  layer_points() %>%
  layer_smooths(stroke := "blue") %>%
  layer_model_predictions(stroke := "red", model = "lm")

# Scatter plot with smooth for each level of cyl
mtcars %>% ggvis(x = ~wt, y = ~mpg, stroke = ~factor(cyl)) %>%
  group_by(cyl) %>%
  layer_points() %>%
  layer_smooths()

# Scatter plot with smooth for each level of cyl, but only points coloured
mtcars %>% ggvis(x = ~wt, y = ~mpg) %>%
  group_by(cyl) %>%
  layer_points(fill = ~factor(cyl)) %>%
  layer_smooths()


library(ggplot2)
library(reshape2)
library(RColorBrewer)
library(gridExtra)

printvar <- function(v) {
  	name <- deparse(substitute(v))
  	print(paste(name, ":", v))
}

mine <- function(L){
    if (length(L) == 2) {
        ctr <<- ctr + 1
        masterlist[[ctr]] <<- L[[2]]
        mine(L[[1]])
    } else {
        ctr <<- ctr + 1
        masterlist[[ctr]] <<- L
    }
}

## to write out
writefile <- source(paste(getwd(), "../../cuIF2", "writedata.r", sep = "/"))
datdir <- paste("../../cuIF2/data")

dir <- paste(getwd(), "../../../../Thesis_data/spatial-varimages", sep = "/")
filelist <- list.files(dir)

nTrials <- length(filelist)
first <- TRUE
fctr <- 0

for (filenum in 1:length(filelist)) {

    filename <- filelist[filenum]
    filepath <- paste(dir, filename, sep = "/")

    if (filename != "thread-0.RData") {

        fctr <- fctr + 1
        print(paste(fctr, filename))

        e <- new.env()
        load(filepath, e)

        ## get sizing info from first file
        if (first) {

            stepsAhead  <- get("stepsAhead", e)
            T           <- get("T", e)
            Tlim        <- get("Tlim", e)
            nloc        <- get("nloc", e)
            nTraj       <- get("nTraj", e)

            truetraj    <- array(NA, c(length(filelist), nloc, stepsAhead) )
            if2traj     <- array(NA, c(length(filelist), nloc, stepsAhead) )
            hmctraj     <- array(NA, c(length(filelist), nloc, stepsAhead) )
            smaptraj    <- array(NA, c(length(filelist), nloc, stepsAhead) )

            countmeans   <- matrix(NA, nloc, T-Tlim+1)
            parabootdata <- array(NA, c(nTraj, nloc, T-Tlim+1))

            if2times    <- numeric(nTrials)
            hmctimes    <- numeric(nTrials)
            smaptimes   <- numeric(nTrials)

            if2fittimes <- numeric(nTrials)
            hmcfittimes <- numeric(nTrials)
            cuIF2times  <- numeric(nTrials)

            if2covdata <- data.frame(matrix(NA, nTrials, 6))
			names(if2covdata) <- c("mean2", "lower2", "upper2", "mean10", "lower10", "upper10")
			hmccovdata <- data.frame(matrix(NA, nTrials, 6))
			names(hmccovdata) <- c("mean2", "lower2", "upper2", "mean10", "lower10", "upper10")

            first <- FALSE

        }

        ## True trajectory
        trueproj <- get("ssdeout_true", e)[,'I',(Tlim+2):(T+1)]
        truetraj[fctr,,] <- trueproj

        # write data out for cuIF2
        data <- get("ssdeout_true", e)[,'I',1:(Tlim+1)]
        neinum <- get("neinum", e)
        neibmat <- get("neibmat", e)
        trial <- get("trial", e)
        writedata(data, neinum, neibmat, datdir, trial)

        ## IF2 extract data
        masterlist <- list()
        ctr <- 0
        if2_paraboot_data <- get("if2_paraboot_data", e)
        mine(if2_paraboot_data)
        # get mean of trajectories
        for (i in 1:nTraj) {
            datalist <- masterlist[[i]]
            trajectories <- datalist$counts
            parabootdata[i,,] <- trajectories
        }
        for (i in 1:nloc) {
            locslice <- parabootdata[,i,]
            locslice <- locslice[complete.cases(locslice),]
            locslice[locslice < 0] <- 0
            countmeans[i,] <- colMeans(locslice)
        }
        if2traj[fctr,,] <- countmeans[,-1]
        if2times[fctr] <- get("if2time", e)[['user.self']]
        if2fittimes[fctr] <- get("if2time1", e)[['user.self']]
        # coverage
        # location 8, times 2 and 10
        real2 	 <- trueproj[8,2]
		real10 	 <- trueproj[8,10]
		quants2 <- quantile(parabootdata[,8,2], probs = c(0.05, 0.95), na.rm = TRUE)
		quants10 <- quantile(parabootdata[,8,10], probs = c(0.05, 0.95), na.rm = TRUE)
		mean2   <- countmeans[8,3] - real2
		diff2 	 <- quants2 - real2
		mean10 	 <- countmeans[8,11] - real10
		diff10 	 <- quants10 - real10
		if2covdata[fctr,] <- c(mean2, diff2, mean10, diff10)

        ## HMCMC
        hmcbootdata <- get("bootstrapdata", e)[,,(Tlim+2):(T+1)]
        meanTraj <- matrix(NA, nloc, T-Tlim)
        # in case of explosion
        for (loc in 1:nloc) {
            locdata <- hmcbootdata[,loc,]
            locdata <- locdata[complete.cases(locdata),]
            locdata[locdata < 0] <- 0
            meanTraj[loc,] <- colMeans(locdata)
        }
        hmctraj[fctr,,] <- meanTraj
        hmctimes[fctr] <- get("hmctime", e)[['user.self']]
        hmcfittimes[fctr] <- get("hmctime1", e)[['user.self']]
        # coverage
        # location 8, times 2 and 10
        real2 	 <- trueproj[8,2]
		real10 	 <- trueproj[8,10]
		quants2 <- quantile(hmcbootdata[,8,2], probs = c(0.05, 0.95), na.rm = TRUE)
		quants10 <- quantile(hmcbootdata[,8,10], probs = c(0.05, 0.95), na.rm = TRUE)
		mean2   <- meanTraj[8,2] - real2
		diff2 	 <- quants2 - real2
		mean10 	 <- meanTraj[8,10] - real10
		diff10 	 <- quants10 - real10
		hmccovdata[fctr,] <- c(mean2, diff2, mean10, diff10)

        ## S-map
        smapproj <- get("predictions", e)
        smapproj[smapproj < 0] <- 0
        smaptraj[fctr,,] <- smapproj
        smaptimes[fctr] <- get("smaptime", e)[['user.self']]

    }
}

## cuIF2 get data
cudir 	<- paste(getwd(), "../../cuIF2/log", sep = "/")
cufiles <- list.files(cudir)

for (filenum in 1:length(cufiles)) {
	filepath <- paste(cudir, cufiles[filenum], sep = "/")
	sysout <- system( paste("cat ", filepath, " | grep Rawtime  | sed -e s/[^0-9.]//g" , sep = ""), intern = TRUE)
	cuIF2times[filenum] <- as.numeric(sysout)
}

## trim
if2traj   <- if2traj[1:fctr,,]
hmctraj   <- hmctraj[1:fctr,,]
smaptraj  <- smaptraj[1:fctr,,]
truetraj  <- truetraj[1:fctr,,]
if2times  <- if2times[1:fctr]
hmctimes  <- hmctimes[1:fctr]
smaptimes <- smaptimes[1:fctr]

## average times
if2meantime <- mean(if2times)
hmcmeantime <- mean(hmctimes)
smapmeantime <- mean(smaptimes)

printvar( if2meantime )
printvar( hmcmeantime )
printvar( smapmeantime )

## average fitting times
if2fitmeantime <- mean(if2fittimes)
hmcfitmeantime <- mean(hmcfittimes)
cuIF2meantime <- mean(cuIF2times)

printvar( if2fitmeantime )
printvar( hmcfitmeantime )
printvar( cuIF2meantime )

if2sses <- matrix(NA, nloc, stepsAhead)
hmcsses <- matrix(NA, nloc, stepsAhead)
smapsses <- matrix(NA, nloc, stepsAhead)

for (loc in 1:nloc) {
    if2sses[loc,] <- colMeans((abs(if2traj[,loc,] - truetraj[,loc,])^2))
    hmcinds <- complete.cases(hmctraj[,loc,])
    hmcsses[loc,] <- colMeans((abs(hmctraj[hmcinds,loc,] - truetraj[hmcinds,loc,])^2))
    smapsses[loc,] <- colMeans((abs(smaptraj[,loc,] - truetraj[,loc,])^2))
}

if2ssecollapse <- colMeans(if2sses)
hmcssecollapse <- colMeans(hmcsses)
smapssecollapse <- colMeans(smapsses)

## SSE plot
##########################################################################################

df <- data.frame(time = 1:(T-Tlim), if2 = log10(if2ssecollapse), hmc = log10(hmcssecollapse), smap = log10(smapssecollapse))
plotdata <- melt(df, id = "time")

q <- qplot(data = plotdata, x = time, y = value, geom = "line", color = variable, xlab = "Weeks ahead", ylab = expression(SSE~(log[10]))) +
		scale_color_grey(labels = c("IF2","HMCMC","S-map")) +
		theme_bw() +
		theme(legend.title=element_blank())

ggsave(q, filename = "sseplot.pdf", width = 6.5, height = 4)

## times plot
##########################################################################################

timedf <- data.frame(if2 = if2times, hmc = hmctimes, smap = smaptimes)
timedata <- melt(timedf)
timeplot <- ggplot(timedata, aes(factor(variable, ordered = TRUE), value)) +
				geom_boxplot() +
				scale_x_discrete(labels = c("IF2", "HMCMC", "S-map")  ) +
				labs(x = "", y = "Time (seconds)") +
				coord_flip() +
				theme_bw()

ggsave(timeplot, filename = "timeplot.pdf", width = 6.5, height = 4)

## second times plot with cuIF2

timedf2 <- data.frame(if2 = log10(if2fittimes), hmc = log10(hmcfittimes), cuif2 = log10(cuIF2times))
timedata2 <- melt(timedf2)
timeplot2 <- ggplot(timedata2, aes(factor(variable, ordered = TRUE), value)) +
				geom_boxplot() +
				scale_x_discrete(labels = c("IF2", "HMCMC", "cuIF2")  ) +
				labs(x = "", y = expression(Time~(log[10]~seconds)) )  +
				coord_flip() +
				theme_bw()

ggsave(timeplot2, filename = "timeplot2.pdf", width = 6.5, height = 4)

#save.image("fsim.RData")

## Let's try this coverage plot thing
##########################################################################################

inds <- complete.cases(hmccovdata)
nCovSets <- sum(inds)

if2pdraw <- if2covdata[inds,][1:nCovSets,]
hmcpdraw <- hmccovdata[inds,][1:nCovSets,]

## 10 weeks ahead
##

pd2if2 <- data.frame(setnum = 1:nCovSets, method = rep("if2",nCovSets), if2pdraw[order(if2pdraw[,"mean2"]),])
pd2hmc <- data.frame(setnum = 1:nCovSets, method = rep("hmc",nCovSets), hmcpdraw[order(if2pdraw[,"mean2"]),])
cnames <- names(pd2if2)
pd2if2melted <- melt(pd2if2, id = cnames)
pd2hmcmelted <- melt(pd2hmc, id = cnames)
pd2 <- rbind(pd2if2melted, pd2hmcmelted)

pd <- position_dodge(0.5)
cov2plot <- ggplot(pd2, aes(x = setnum, color = method)) +
					geom_hline(aes(yintercept = 0)) +
					geom_errorbar(aes(ymin = lower2, ymax = upper2), width = 0, position = pd) +
					geom_point(aes(y = mean2), position = pd) +
					labs(x = "", y = "Estimate - True") +
					theme_bw() +
					scale_color_grey() +
					theme(axis.ticks.x=element_blank(),
					      axis.text.x=element_blank(),
					      legend.position='none')

## 45 weeks ahead
##

pd10if2 <- data.frame(setnum = 1:nCovSets, method = rep("if2",nCovSets), if2pdraw[order(if2pdraw[,"mean10"]),])
pd10hmc <- data.frame(setnum = 1:nCovSets, method = rep("hmc",nCovSets), hmcpdraw[order(if2pdraw[,"mean10"]),])
cnames <- names(pd10if2)
pd10if2melted <- melt(pd10if2, id = cnames)
pd10hmcmelted <- melt(pd10hmc, id = cnames)
pd10 <- rbind(pd10if2melted, pd10hmcmelted)

pd <- position_dodge(0.5)
cov10plot <- ggplot(pd10, aes(x = setnum, color = method)) +
					geom_hline(aes(yintercept = 0)) +
					geom_errorbar(aes(ymin = lower10, ymax = upper10), width = 0, position = pd) +
					geom_point(aes(y = mean10), position = pd) +
					labs(x = "Data set", y = "Estimate - True") +
					theme_bw() +
					scale_color_grey() +
					theme(axis.ticks.x=element_blank(),
					      axis.text.x=element_blank(),
					      legend.position='none')

## save combined plot
##
pdf("coverage.pdf", width = 6.5, height = 4)
grid.arrange(cov2plot, cov10plot, ncol = 1, nrow = 2)
dev.off()


#' Compute metacell manifold graph using logistic distances and balanced K-nn
#'
#' @param mgraph_id id of new object
#' @param mc_id meta cell id to work with
#' @param ignore_edges provide a data frame with mc1,mc2 pairs of edges to delete manually
#' @param feats_gset gene set name for use for computing distances
#' @param feats_exclude list of genes to exclude from the features gene set
#' @param logist_loc the "location" parametr of the logistic function used to determine parametric distances between metacelles
#' @param logist_scale the "lscale" parametr of the logistic function used to determine parametric distances between metacelles
#'
#' @export
mcell_mgraph_logistic = function(mgraph_id, mc_id,
			feats_gset,
			ignore_edges = NULL,
			feats_exclude =NULL,
			logist_loc = 1, logist_scale = 0.2,
			logist_eps = 4e-5, max_d_fold = 3)
{
	mc = scdb_mc(mc_id)
	if (is.null(mc)) {
		stop(sprintf("mc %s not found"), mc_id)
	}
	feat_genes = NULL
	gset = scdb_gset(feats_gset)
	if(is.null(gset)) {
		stop("Unkown gset ", feats_gset, " defined in mgraph logist construction")
	}
	feat_genes = names(gset@gene_set)
	if(!is.null(feat_genes)) {
		feat_genes = setdiff(feat_genes, feats_exclude)
	}
	message("got ", length(feat_genes), " feat genes for mc graph construction")

	mgraph = mgraph_comp_logist(mc, feat_genes,
					logist_loc, logist_scale, logist_eps, max_d_fold)

	if(!is.null(ignore_edges)) {
		all_e = paste(mgraph$mc1, mgraph$mc2, sep="-")
		ig_e = paste(ignore_edges$mc1, ignore_edges$mc2, sep="-")
		ig_re = paste(ignore_edges$mc2, ignore_edges$mc1, sep="-")
		f = all_e %in% c(ig_e,ig_re)
		mgraph= mgraph[!f,]
		message("igoring ", sum(f), " edges")
	}
	scdb_add_mgraph(mgraph_id, tgMCManifGraph(mc_id, mgraph))
}

#' @export
mgraph_comp_logist= function(mc, genes, loc, scale, eps, max_d_fold)
{
	max_deg = get_param("mcell_mgraph_max_confu_deg")
	legc = log2(mc@e_gc[genes,] + eps)

	logist_d = function(x) {
		d = abs(legc - x)
		d = plogis(d, loc, scale)
		return(colSums(d))
	}
	a = apply(legc, 2, logist_d)

#connect - d-best outgoing. filter by d_best_ratio < 2
	diag(a) = 1000;
	d_T = apply(a, 1, function(x) sort(x,partial=2)[2])
	a_n = a/d_T
	diag(a) = 0;
	diag(a_n) = 0;

   rank_fr = t(apply(a, 1, rank))
   rank_fr_m = rank_fr
   rank_fr_m[a_n > max_d_fold] = 1000
   rank_fr_m2 = rank_fr_m
   rank_fr_m2[t(a_n) > max_d_fold] = 1000

   edges = apply(rank_fr_m2, 1, function(x) {
                        mc2 = which(x > 0 & x <= max_deg+1);
                        mc1 = rep(which.min(x), length(mc2));
                        return(data.frame(mc1 = mc1, mc2=mc2)) })
   ed_df = as.data.frame(do.call(rbind, edges))
	ed_df$dist = apply(ed_df, 1, function(x) 1+a[x[1],x[2]])
	return(ed_df)
}


#script resamples original slope data and converts to values neeed for moistureMap.r (etc)

rm(list=ls())
library(raster)

#read munis.r as latlong
unzip(zipfile="Data/sim10_BRmunis_latlon_5km.zip",exdir="Data")  #unzip
munis.r <- raster("Data/sim10_BRmunis_latlon_5km.asc") #spatial resolution is 5000m
latlong <- "+proj=longlat +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +no_defs "
crs(munis.r) <- latlong

#note decliv_class.asc in zip file is 1.8GB!
unzip(zipfile="Data/decliv_class.zip",exdir="Data")  #unzip
vslope<-raster("Data/decliv_class.asc")  #decliv has spatial resolution 250m

vslope.m10 <- aggregate(vslope, fact=20, fun=mean)  #fact=20 as 5000m / 250m = 20
vslope.m10 <- resample(vslope.m10, munis.r, method='ngb')
vslope.m10 <- mask(x=vslope.m10, mask=munis.r)

plot(vslope.m10)

vslope.sd <- aggregate(vslope, fact=20, fun=sd)

#use reclassify() method below https://www.rdocumentation.org/packages/raster/versions/2.6-7/topics/reclassify
#proof of concept
#a <- c(0,1)
#a <- rbind(a,(c(1,2)))
#r <- raster(ncol=10, nrow=10)
#values(r) <- rbinom(ncell(r), size = 1, prob = 0.5)
#plot(r)
#r <- reclassify(r, a)
#plot(r)

a <- c(1,0)
a <- rbind(a,(c(2,1)))
a <- rbind(a,(c(3,2)))
a <- rbind(a,(c(4,3)))
a <- rbind(a,(c(5,4)))
a <- rbind(a,(c(6,4)))

reclassify(vslope.m, a)

writeRaster(vslope.m, "Data/vslope_unclassified_2019-06-07", "ascii", "overwrite"=T)

unlink("Data/decliv_class.asc")  #large file so delete!
unlink("Data/sim10_BRmunis_latlon_5km.asc")


library(rstan)

options(mc.cores = min(parallel::detectCores(),10))
rstan_options(auto_write = TRUE)
Sys.setenv(LOCAL_CPPFLAGS = '-march=native')

## transform data to fit anxHard.stan
stanDat <- list()

dat$id <- as.numeric(as.factor(dat$StudyId))

stopifnot(max(dat$id)==n_distinct(dat$StudyId))
stanDat$N <- max(dat$id)

dat$time <- dat$time+1

stanDat$T <- 12

anxDat <- dat%>%select(id,time,anxlevel)%>%filter(is.finite(anxlevel))

stanDat$nobsAnx <- nrow(anxDat)
stanDat$anxObs <- anxDat$anxlevel
stanDat$subjAnx <- anxDat$id
stanDat$timeAnx <- anxDat$time

subDat <- dat%>%select(id,time,anyHard)%>%filter(is.finite(anyHard))

stanDat$nobsSub <- nrow(subDat)
stanDat$subObs <- subDat$anyHard
stanDat$subjSub <- subDat$id
stanDat$timeSub <- subDat$time

## fill in missing values by assumption
dat$race <- as.factor(dat$Race_R)
dat$race[is.na(dat$race)] <- 1
levels(dat$race) <- names(attr(datO$Race_R,'labels'))

dat$Hispanic_R[is.na(dat$Hispanic_R)] <- 2
dat$hisp <- ifelse(dat$Hispanic_R==1,1,0)

dat$gender[is.na(dat$gender)] <- 1

X <- model.matrix(~age+gender+race+hisp+Site,
  data=dat%>%group_by(id)%>%summarize_all(function(x) x[1]))

stanDat$X <- scale(X[,-1])

stanDat$p <- ncol(X)-1

mod <- stan('anxHard.stan',data=stanDat,chains=1,iter=100)


library(tensorflow)
library(tfestimators)
library(tfdatasets)
library(tfdeploy)
library(tfruns)
library(cloudml)
library(dplyr)
#library(tidyverse)
library(keras)
library(corrplot)

c(c(x_train , y_train), c(x_test, y_test)) %<-% dataset_mnist()

x_train <- array_reshape(x_train, c(nrow(x_train), 784))
x_test <- array_reshape(x_test , c(nrow(x_test) , 784))
x_train <- x_train / 255
x_test <- x_test / 255

y_train <- to_categorical(y_train, 10)
y_test <- to_categorical(y_test ,10)

model<- keras_model_sequential()%>%
  layer_dense(units = 128, activation = 'relu',input_shape = c(784))%>%
  layer_dropout(rate = 0.4)%>%
  layer_dense(units = 128 ,activation = 'relu')%>%
  layer_dropout(rate = 0.3) %>%
  layer_dense(units = 10, activation = 'softmax')

model %>% compile(
  loss = 'categorical_crossentropy',
  optimizer = optimizer_rmsprop(),
  metrics = c('accuracy')

)

history <-model %>% fit(
  x_train,
  y_train,
  epochs = 20,
  batch_size = 5,
  validation_split = 0.2
)

# x_train = iris.training
# y_train = iris.trainLabels

#
# history <- model %>%fit(
#   x_train,y_train,
#   batch_size = 128,
#   epochs = 10,
#   validation_split =0.2
#
#
# )

summary(model)

plot(history)

model %>% evaluate(x_test,y_test)

model %>% predict_classes(x_test[1:100,])

# Print a summary of a model
summary(model)

# Get model configuration
get_config(model)

# Get layer configuration
get_layer(model, index = 1)

# List the model's layers
model$layers

# List the input tensors
model$inputs

# List the output tensors
model$outputs


#cut values from CompareToManual.printComparisonsCSV() to make input file

file <- "recallValues.txt"
x <- t(read.csv(file))
x <- x[,]

max <- max(x)

h<-hist(x)

hist(x, breaks = 20, main="Recall per experiment", xlab="Recall", ylab="Experiment Frequency")

png("RecallHistogram.png", width=800, height = 800)
hist(x, breaks = 20, main="Recall per experiment", xlab="Recall", ylab="Experiment Frequency")
dev.off()


require(raster)
require(reshape2)
require(maps)
require(mapdata)
require(ncdf4) # for reading netCDF files
require(abind) # for combining arrays
source('scripts/image.scale.r') # for plotting color bar on image
require(RColorBrewer)

############
# Functions
############

# Returns maximum non-NA value if present, otherwise returns NA (instead of -Inf)
maxNA <- function(x) ifelse( !all(is.na(x)), max(x, na.rm=T), NA)

######################
# Prep (do once)
######################
	###################################################
	# Average into 0.5x0.5° grid and combine all files
	###################################################

	# find files
	files <- list.files('temp', full.names=TRUE, pattern='oisst[[:digit:]]{4}_[[:digit:]]{4}\\.rdata')

	# read in first array and average into 0.5x0.5
	# approach is to overlap the 4 grid cells to be combined, and then average (in 3D array space)
	load(files[1])
	ds <- dim(tempsarray)
	t1 <- tempsarray[seq(1,ds[1]-1,by=2), seq(1,ds[2]-1,by=2),] # top left corner of each new grid cell (across all times)
	t2 <- tempsarray[seq(2,ds[1],by=2), seq(1,ds[2]-1,by=2),] # bottom left corner
	t3 <- tempsarray[seq(1,ds[1]-1,by=2), seq(2,ds[2],by=2),] # top right
	t4 <- tempsarray[seq(2,ds[1],by=2), seq(2,ds[2],by=2),] # bottom right
	toaverage <- abind(t1, t2, t3, t4, along=4) # bind them along a new dimension
	tempsarray0.5 <- apply(toaverage, MARGIN=1:3, FUN=mean) # average the 4 grid cells together. 5-10 min. slow!
		dim(tempsarray0.5)

	newlats <- colMeans(rbind(as.numeric(dimnames(t1)$lat), as.numeric(dimnames(t2)$lat)))
	newlons <- colMeans(rbind(as.numeric(dimnames(t1)$lon), as.numeric(dimnames(t3)$lon)))
	dimnames(tempsarray0.5) <- list(lat=newlats, lon=newlons, time=dimnames(t1)$time)

	# read in next arrays
	for(i in 2:length(files)){
		load(files[i])
		ds <- dim(tempsarray)
		t1 <- tempsarray[seq(1,ds[1]-1,by=2), seq(1,ds[2]-1,by=2),] # top left corner of each new grid cell
		t2 <- tempsarray[seq(2,ds[1],by=2), seq(1,ds[2]-1,by=2),] # bottom left corner
		t3 <- tempsarray[seq(1,ds[1]-1,by=2), seq(2,ds[2],by=2),] # top right
		t4 <- tempsarray[seq(2,ds[1],by=2), seq(2,ds[2],by=2),] # bottom right
		toaverage <- abind(t1, t2, t3, t4, along=4) # bind them along a new dimension

		temp <- apply(toaverage, MARGIN=1:3, FUN=mean) # 5-10 min. slow!
			dim(temp)
		dimnames(temp) <- list(lat=newlats, lon=newlons, time=dimnames(t1)$time)

		temp <- round(temp, digits=1) # average to 0.1 precision like Udel

		tempsarray0.5 <- abind(tempsarray0.5, temp, along=3)
	}

	# get years
	yrs <- as.numeric(gsub('_[[:digit:]]{1,2}$', '', dimnames(tempsarray0.5)[[3]]))

	# change name for saving
	tempsarray <- tempsarray0.5

	# Write out
	save(tempsarray, file=paste('temp/oisst0.5deg_', min(yrs), '_', max(yrs), '.rdata', sep=''))

#################################################
# Calculate annual climatology on 0.25x0.25° grid
#################################################

# Read in
load('temp/oisst1986_1990.rdata') # tempsarray at 0.25x0.25
	oisst <- tempsarray
load('temp/oisst1991_1995.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst1996_2000.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst2001_2005.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
dim(oisst) # 720 x 140 x 240

# Average
sstclim <- apply(oisst, MARGIN=c(1,2), FUN=mean)

	image(sstclim)

# rotate so columns 0 -> 360 lon, rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(colnames(sstclim)) # good

lats <- as.numeric(rownames(sstclim))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

sstclim <- sstclim[newlatord, ]

	image(sstclim)

# save
save(sstclim, file='temp/sstclimatology.rdata')

# Plot climatologies
	image(sstclim)

# Nicer plot of sstclim
	lonrng <- c(0,360) # really 0 358
	latrng <- round(range(as.numeric(rownames(sstclim))))

	quartz(width=5, height=3)
	# png(width=5, height=3, filename='figures/climatology_map_OISST.png', units='in', res=300)
	par(mai=c(0.7, 0.7, 0.1, 0.2), mgp=c(2, 0.5, 0), las=1, tcl=-0.3)
	image(t(sstclim), xlab='Longitude (°E)', ylab='Latitude (°N)', xaxt='n', yaxt='n', col=rev(heat.colors(20)))
	axis(1, at=seq(0,1, length.out=9), labels=seq(lonrng[1], lonrng[2], length.out=9), cex=0.8)
	axis(2, at=seq(0,1, length.out=9), labels=seq(latrng[1], latrng[2], length.out=9), cex=0.8)

	dev.off()

#################################################
# Calculate annual climatology on CMIP5 grid
#################################################
# need sstclim from previous section

# create new grid
	ngrd2 <- expand.grid(lat=seq(-89.375,89.375,by=1.25), lon=seq(0.625,359.375,by=1.25)) # the grid to interpolate for ocean (1.25)

# interpolate
	# raster query approach with points
	ngrd.sp2 <- ngrd2[,c('lon', 'lat')]
	coordinates(ngrd.sp2) <- ~lon + lat
	proj4string(ngrd.sp2) <- '+proj=longlat +datum=WGS84'

	sstclimr <- raster(sstclim[nrow(sstclim):1,], xmn=0, xmx=360, ymn=-89, ymx=89, crs='+proj=longlat +datum=WGS84') # make a raster object from sstclim data
	newvalss <- extract(sstclimr, ngrd.sp2, method='bilinear')
	sstngrdr <- rasterFromXYZ(cbind(ngrd2[,c('lon', 'lat')], newvalss))

# examine
	par(mfrow=c(1,2))
	plot(sstclimr)
	plot(sstngrdr)

# convert to matrix: n for new grid
sstclimn <- as.matrix(sstngrdr)
	rownames(sstclimn) <- yFromRow(sstngrdr)
	colnames(sstclimn) <- xFromCol(sstngrdr)

# write out
save(sstclimn, file='temp/sstclimatology_cmip5grid.rdata')

#####################################
# Calculate summer climatology on 0.25x0.25
#####################################
# Read in
load('temp/oisst1986_1990.rdata') # tempsarray at 0.25x0.25
	oisst <- tempsarray
load('temp/oisst1991_1995.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst1996_2000.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst2001_2005.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
dim(oisst) # 720 x 140 x 240

# Reshape so month has a dimension
nms <- dimnames(oisst)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(oisst)
tempsarraybymo <- array(oisst, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

# average within months
sstclimbymo <- apply(tempsarraybymo, MARGIN=c(1,2,3), FUN=mean) # climatology for each month

	image(sstclimbymo[,,1])

# Using "summer" months
	sstclimwarm3N <- apply(sstclimbymo[,,6:8], MARGIN=c(1,2), FUN=mean) # temperature of summer 3-month period in each cell for northern hemisphere
	sstclimwarm3S <- apply(sstclimbymo[,,c(1,2,12)], MARGIN=c(1,2), FUN=mean) # temperature of summer 3-month period in each cell for northern hemisphere
	sstclimwarm3 <- rbind(sstclimwarm3S[as.character(seq(-89.875,-0.125,by=0.25)),], sstclimwarm3N[as.character(seq(0.125,89.875,by=0.25)),])

		# maps
		zlims <- range(c(sstclimwarm3N, sstclimwarm3S), na.rm=TRUE)
		par(mfrow=c(3,1))
		image(y=as.numeric(row.names(sstclimwarm3N)), x=as.numeric(colnames(sstclimwarm3N)), t(sstclimwarm3N), zlim=zlims)
		image(t(sstclimwarm3S), zlim=zlims)
		image(t(sstclimwarm3), zlim=zlims)

# rotate so columns 0 -> 360 lon, rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(colnames(sstclimwarm3)) # good

lats <- as.numeric(rownames(sstclimwarm3))
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

sstclimwarm3 <- sstclimwarm3[newlatord, ]

	image(sstclimwarm3)

# save
save(sstclimwarm3, file='temp/sstclimatology_warm3.rdata')

#################################################
# Calculate summer climatology on CMIP5 grid
#################################################
# need sstclimwarm3 from previous section

# create new grid
	ngrd2 <- expand.grid(lat=seq(-89.375,89.375,by=1.25), lon=seq(0.625,359.375,by=1.25)) # the grid to interpolate for ocean (1.25)

# interpolate
	# raster query approach with points
	ngrd.sp2 <- ngrd2[,c('lon', 'lat')]
	coordinates(ngrd.sp2) <- ~lon + lat
	proj4string(ngrd.sp2) <- '+proj=longlat +datum=WGS84'

	sstclimr <- raster(sstclimwarm3, xmn=0, xmx=360, ymn=-89, ymx=89, crs='+proj=longlat +datum=WGS84') # make a raster from sstclim data
	newvalss <- extract(sstclimr, ngrd.sp2, method='bilinear') # interpolated sst from summer
	sstngrdr <- rasterFromXYZ(cbind(ngrd2[,c('lon', 'lat')], newvalss))

# examine
	par(mfrow=c(2,1))
	plot(sstclimr)
	plot(sstngrdr)

# convert to array: n for new grid
sstclimwarm3n <- as.matrix(sstngrdr)
	rownames(sstclimwarm3n) <- rev(yFromRow(sstngrdr))
	colnames(sstclimwarm3n) <- xFromCol(sstngrdr)

	image(t(sstclimwarm3n), xaxt='n', yaxt='n')
		axis(side=2, at=seq(0,1,length=nrow(sstclimwarm3n)), labels=rownames(sstclimwarm3n))
		axis(side=1, at=seq(0,1,length=ncol(sstclimwarm3n)), labels=colnames(sstclimwarm3n))

# flip to match cmip5
sstclimwarm3n <- sstclimwarm3n[nrow(sstclimwarm3n):1,]

	image(sstclimwarm3n, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstclimwarm3n)), labels=rownames(sstclimwarm3n))
		axis(side=2, at=seq(0,1,length=ncol(sstclimwarm3n)), labels=colnames(sstclimwarm3n))

# write out
save(sstclimwarm3n, file='temp/sstclimatology_warm3_cmip5grid.rdata')

#####################################
# Calculate monthly climatology on 0.25x0.25
#####################################
# Read in
load('temp/oisst1986_1990.rdata') # tempsarray at 0.25x0.25
	oisst <- tempsarray
load('temp/oisst1991_1995.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst1996_2000.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst2001_2005.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
dim(oisst) # 720 x 140 x 240

nms <- dimnames(oisst)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(oisst)
tempsarraybymo <- array(oisst, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

sstclimbymo <- apply(tempsarraybymo, MARGIN=c(1,2,3), FUN=mean) # climatology for each month

# rotate so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(dimnames(sstclimbymo)[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(dimnames(sstclimbymo)[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

sstclimbymo <- sstclimbymo[newlatord, newlonord,]
dimnames(sstclimbymo)[[2]] <- newcolnms

	image(sstclimbymo[,,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstclimbymo)), labels=rownames(sstclimbymo), cex.axis=0.4)
		axis(side=2, at=seq(0,1,length=ncol(sstclimbymo)), labels=colnames(sstclimbymo), cex.axis=0.4)

# save
save(sstclimbymo, file='temp/sstclimatology_bymonth.rdata')

#################################################
# Calculate monthly climatology on CMIP5 grid
#################################################
# need sstclimbymo from previous section

# create new grid
	ngrd2 <- expand.grid(lat=seq(-89.375,89.375,by=1.25), lon=seq(0.625,359.375,by=1.25)) # the grid to interpolate for ocean (1.25)

# interpolate
	# raster query approach with points
	ngrd.sp2 <- ngrd2[,c('lon', 'lat')]
	coordinates(ngrd.sp2) <- ~lon + lat
	proj4string(ngrd.sp2) <- '+proj=longlat +datum=WGS84'

	sstclimr <- brick(sstclimbymo, xmn=0, xmx=360, ymn=-89, ymx=89, crs='+proj=longlat +datum=WGS84') # make a raster brick from sstclim data
	newvalss <- extract(sstclimr, ngrd.sp2, method='bilinear') # interpolated sst by month
	sstngrdr <- rasterFromXYZ(cbind(ngrd2[,c('lon', 'lat')], newvalss))

# examine
	par(mfrow=c(2,1))
	plot(subset(sstclimr,1))
	plot(subset(sstngrdr,1))

# convert to array: n for new grid
sstclimbymon <- as.array(sstngrdr)
	dimnames(sstclimbymon)[[1]] <- yFromRow(sstngrdr)
	dimnames(sstclimbymon)[[2]] <- xFromCol(sstngrdr)
	dimnames(sstclimbymon)[[3]] <- 1:12

	image(sstclimbymon[,,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstclimbymon)), labels=rownames(sstclimbymon))
		axis(side=2, at=seq(0,1,length=ncol(sstclimbymon)), labels=colnames(sstclimbymon))

# write out
save(sstclimbymon, file='temp/sstclimatology_bymonth_cmip5grid.rdata')

#############################################
# Calculate warmest month on the 0.25x0.25 grid
#############################################
# need sstclimbymon from previous section
load('temp/sstclimatology_bymonth.rdata') # sstclimbymo

sstclimwarmestmo <- apply(sstclimbymo, MARGIN=c(1,2), FUN=max)

	image(sstclimwarmestmo, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstclimwarmestmo)), labels=rownames(sstclimwarmestmo))
		axis(side=2, at=seq(0,1,length=ncol(sstclimwarmestmo)), labels=colnames(sstclimwarmestmo))

# write out
save(sstclimwarmestmo, file='temp/sstclimatology_warmestmonth.rdata')

#############################################
# Calculate warmest month on the CMIP5 grid
#############################################
# need sstclimbymon from previous section
load('temp/sstclimatology_bymonth_cmip5grid.rdata')  # sstclimbymon (note "n")

sstclimwarmestmon <- apply(sstclimbymon, MARGIN=c(1,2), FUN=max)

	image(sstclimwarmestmon, xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstclimwarmestmon)), labels=rownames(sstclimwarmestmon))
		axis(side=2, at=seq(0,1,length=ncol(sstclimwarmestmon)), labels=colnames(sstclimwarmestmon))

# write out
save(sstclimwarmestmon, file='temp/sstclimatology_warmestmonth_cmip5grid.rdata')

#####################################
# Calculate each month's warmest average daily high from 1986-2005 on 0.25x0.25
# Add 0.5*HadDTR to warmest example of each month in 1986-2005
#####################################
# Read in OISST
load('temp/oisst1986_1990.rdata') # tempsarray at 0.25x0.25
	oisst <- tempsarray
load('temp/oisst1991_1995.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst1996_2000.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
load('temp/oisst2001_2005.rdata') # tempsarray at 0.25x0.25
	oisst <- abind(oisst, tempsarray, along=3)
dim(oisst) # 720 x 140 x 240

# Read in DTR interpolated to 0.25 and filled in
load('temp/dtrclimatology_interp0.25.rdata') # dtr025 at 0.25x0.25, interpolated to match oisst

# Reshape oisst to lat x lon x month x year
nms <- dimnames(oisst)
mos <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(2,length(nms[[3]])*2,by=2)]) # months
yrs <- as.numeric(unlist(strsplit(nms[[3]], split='_'))[seq(1,length(nms[[3]])*2,by=2)]) # years
dm <- dim(oisst)
oisstbymo <- array(oisst, dim=c(dm[1], dm[2], 12, dm[3]/12), dimnames=list(lat=nms[[1]], lon=nms[[2]], mo=1:12, year=sort(unique(yrs)))) # add a month dimension (3rd dimension)

# rotate sst monthly temps 1986-2005 so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
lons <- as.numeric(nms[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(nms[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

sstbymo <- oisstbymo[newlatord, newlonord,,] # lat x lon (0-360) x month x year
dimnames(sstbymo)[[2]] <- newcolnms

	image(sstbymo[,,1,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstbymo)), labels=rownames(sstbymo), cex.axis=0.4)
		axis(side=2, at=seq(0,1,length=ncol(sstbymo)), labels=colnames(sstbymo), cex.axis=0.4)

# expand dtr to 20 years
dtrlong <- abind(list(dtr025)[rep(1,20)], along=4)
	dim(dtrlong)
	dim(sstbymo)

# add daily temperature range to monthly temperatures to get average daily highs in every month
tosmaxbymobyyr <- sstbymo + dtrlong*0.5 # assume average daily high is 50% of DTR above monthly mean
	dim(tosmaxbymobyyr)

	image(tosmaxbymobyyr[,,1,1], xaxt='n', yaxt='n')
		axis(side=1, at=seq(0,1,length=nrow(sstbymo)), labels=rownames(sstbymo), cex.axis=0.4)
		axis(side=2, at=seq(0,1,length=ncol(sstbymo)), labels=colnames(sstbymo), cex.axis=0.4)

# find highest average daily high across years for each month
tosmaxbymo <- apply(tosmaxbymobyyr, MARGIN=c(1,2,3), FUN=max)
	dim(tosmaxbymo)
	range(tosmaxbymo, na.rm=TRUE)

# save
save(tosmaxbymo, file='temp/tosmax_bymonth.rdata')

#############################################
# Calculate warmest daily high on the 0.25x0.25 grid
# Add 0.5*HadDTR to warmest day in 1986-2005
#############################################
# Load warmest day
load('temp/tosmaxday.rdata') # tosmaxday from climatology_OISST_maxday.r. 1986-2005.

# Read in DTR interpolated to 0.25 and filled in
load('temp/dtrclimatology_interp0.25.rdata') # dtr025 at 0.25x0.25, interpolated to match oisst

# Find widest DTR
dtrmax <- apply(dtr025, MARGIN=c(1,2), FUN=maxNA)

# Check dimensions
	dim(dtrmax)
	dim(tosmaxday)

# add daily temperature range to warmest day
tosmax <- tosmaxday + dtrmax*0.5 # assume daily high is 50% of DTR above
	dim(tosmax)

	zlims <- range(tosmax, na.rm=TRUE)
	bks <- seq(zlims[1], zlims[2],length.out=30)
	cols <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks)-1)

	layout(matrix(c(1,2), nrow=1, ncol=2), widths=c(10,1))
	image(tosmax, xaxt='n', yaxt='n', zlim=zlims, breaks=bks, col=cols)
		axis(side=1, at=seq(0,1,length=nrow(tosmax)), labels=rownames(tosmax))
		axis(side=2, at=seq(0,1,length=ncol(tosmax)), labels=colnames(tosmax))
	image.scale(zlim=zlims, col=cols, breaks=bks, horiz=FALSE, ylab='°C')

# write out
save(tosmax, file='temp/tosmax.rdata')

#############################################
# Calculate 95% warmest daily high on the 0.25x0.25 grid
# Add 0.5*HadDTR to 95% warmest day in 1986-2005
#############################################
# Load warmest day
load('temp/tos95day.rdata') # tosmaxbymo

# Read in DTR interpolated to 0.25 and filled in
load('temp/dtrclimatology_interp0.25.rdata') # dtr025 at 0.25x0.25, interpolated to match oisst

# Find widest DTR across the months
dtrmax <- apply(dtr025, MARGIN=c(1,2), FUN=maxNA)

# Check dimensions
	dim(dtrmax)
	dim(tos95day)

# add daily temperature range to 95% warmest day
tos95max <- tos95day + dtrmax*0.5 # assume average daily high is 50% of DTR above daily mean
	dim(tos95max)

	zlims <- range(tos95max, na.rm=TRUE)
	bks <- seq(zlims[1], zlims[2],length.out=30)
	cols <- colorRampPalette(brewer.pal(9, "OrRd"))(length(bks)-1)

	layout(matrix(c(1,2), nrow=1, ncol=2), widths=c(10,1))
	image(tos95max, xaxt='n', yaxt='n', zlim=zlims, breaks=bks, col=cols)
		axis(side=1, at=seq(0,1,length=nrow(tos95max)), labels=rownames(tos95max))
		axis(side=2, at=seq(0,1,length=ncol(tos95max)), labels=colnames(tos95max))
	image.scale(zlim=zlims, col=cols, breaks=bks, horiz=FALSE, ylab='°C')

# write out
save(tos95max, file='temp/tos95max.rdata')


#Code for Figure 4B,4C: Compares neoantigen depletion rates between subtypes and timepoints
#Code for Extended Data Figure 12B: Hypermutator analyses
#Also performs other exploratory analyses and statistical tests between groups
#Code making Figures is labelled clearly
#Query at the top joins analysis.neoantigen_depletion materialized view with other tables to get timepoint, hypermutator, and subtype information
#All samples in these analyses were required to have at least 3 missense mutations in their initial and recurrent tumors (avoid overfitting ratio)
#-----------------------------------------------------

library(odbc)
library(DBI)
library(ggplot2)
library(ggpubr)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")

q <- "SELECT gs.* , nd1.rneo AS nd_a, nd2.rneo AS nd_b, clin.idh_codel_subtype AS subtype,
CASE WHEN mf1.coverage_adj_mut_freq >= 10 THEN 1 WHEN mf1.coverage_adj_mut_freq < 10 THEN 0 END AS hm_a,
CASE WHEN mf2.coverage_adj_mut_freq >= 10 THEN 1 WHEN mf2.coverage_adj_mut_freq < 10 THEN 0 END AS hm_b
FROM analysis.gold_set gs
LEFT JOIN analysis.neoantigen_depletion nd1 ON gs.tumor_barcode_a = nd1.aliquot_barcode
LEFT JOIN analysis.neoantigen_depletion nd2 ON gs.tumor_barcode_b = nd2.aliquot_barcode
LEFT JOIN analysis.mut_freq mf1 ON mf1.aliquot_barcode = gs.tumor_barcode_a
LEFT JOIN analysis.mut_freq mf2 ON mf2.aliquot_barcode = gs.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = gs.case_barcode
WHERE nd1.rneo IS NOT NULL AND nd2.rneo IS NOT NULL AND (nd1.nobs >= 3 AND nd2.nobs >= 3)
ORDER BY nd1.rneo"

res <- dbGetQuery(con, q)

tmp <- res[,"subtype"]
tmp <- tmp[order(tmp)]
rle(tmp)
#Scatterplot of primary vs recurrent correlations with depletion
cor.test(res[,"nd_a"],res[,"nd_b"])
cor.test(res[,"nd_a"],res[,"nd_b"])$p.value

summary(aov(c(res[,"nd_a"],res[,"nd_b"])~rep(res[,"subtype"],2))) #P = 0.09

#******************************
#Figure 4C
#******************************
gtsize = 7/(14/5)
pdf("/projects/varnf/GLASS/Figures/resubmission/Figure4C.pdf",width=2,height=2)
ggplot(res, aes(x = nd_a, y = nd_b,colour=subtype)) +
	geom_point(size=1.5,alpha=0.4) +
	geom_abline(intercept=0, slope=1, color = "gray50", size=0.5) +
 	geom_text(aes(x=1.75, y=0, label = "R = 0.73"), size=gtsize, group = NA, colour = "black") +
	labs(x="Observed/expected neoantigens\n(initial)", y="Observed/expected neoantigens\n(recurrent)") +
	theme_classic() +
	theme(axis.title=element_text(size=7),
	axis.text=element_text(colour="black",size=7),
	legend.position="none") +
	coord_cartesian(ylim=c(0,2),xlim=c(0,2))
dev.off()

gtsize = 7/(14/5)
pdf("/projects/varnf/GLASS/Figures/resubmission/Figure4C_bigger.pdf",width=2,height=2)
ggplot(res, aes(x = nd_a, y = nd_b,colour=subtype)) +
	geom_point(size=1.5,alpha=0.4) +
	geom_abline(intercept=0, slope=1, color = "gray50", size=0.5) +
 	geom_text(aes(x=1.75, y=0, label = "R = 0.73"), size=gtsize, group = NA, colour = "black") +
	labs(x="Observed/expected neoantigens (initial)", y="Observed/expected neoantigens (recurrent)") +
	theme_classic() +
	theme(axis.title=element_text(size=7),
	axis.text=element_text(colour="black",size=7),
	legend.position="none") +
	coord_cartesian(ylim=c(0,2),xlim=c(0,2))
dev.off()

#Examine differences in the residuals
difs <- res[,"nd_b"] - res[,"nd_a"]
wilcox.test(difs[which(res[,"subtype"]=="IDHwt")],difs[which(res[,"subtype"]=="IDHmut-noncodel")])
wilcox.test(difs[which(res[,"subtype"]=="IDHwt")],difs[which(res[,"subtype"]=="IDHmut-codel")])
wilcox.test(difs[which(res[,"subtype"]=="IDHmut-noncodel")],difs[which(res[,"subtype"]=="IDHmut-codel")])
wilcox.test(difs[which(res[,"subtype"]=="IDHwt")],difs[which(res[,"subtype"]=="IDHmut-codel")])
wilcox.test(difs[which(res[,"subtype"]!="IDHmut-codel")],difs[which(res[,"subtype"]=="IDHmut-codel")])
wilcox.test(difs[which(res[,"subtype"]!="IDHwt")],difs[which(res[,"subtype"]!="IDHwt")])

#Compare primary vs recurrent irrespective of subtype:
t.test(res[,"nd_a"],res[,"nd_b"],paired=TRUE)		#Initial vs recurrent:	0.77
t.test(res[,"nd_a"], mu=1)							#Initial: 				0.47
t.test(res[,"nd_b"], mu=1)							#Recurrent:				0.59

#Compare subtypes irrespective of timepoint:
idhwt <- res[which(res[,"subtype"]=="IDHwt"),]
idhmutnoncodel <- res[which(res[,"subtype"]=="IDHmut-noncodel"),]
idhmutcodel <- res[which(res[,"subtype"]=="IDHmut-codel"),]
idhmut <- res[which(res[,"subtype"]!="IDHwt"),]

t.test(c(idhwt[,"nd_a"],idhwt[,"nd_b"]),c(idhmutnoncodel[,"nd_a"],idhmutnoncodel[,"nd_b"]))						#0.04
t.test(c(idhwt[,"nd_a"],idhwt[,"nd_b"]),c(idhmutcodel[,"nd_a"],idhmutcodel[,"nd_b"]))							#0.39
t.test(c(idhmutnoncodel[,"nd_a"],idhmutnoncodel[,"nd_b"]),c(idhmutcodel[,"nd_a"],idhmutcodel[,"nd_b"]))			#0.61
t.test(c(idhwt[,"nd_a"],idhwt[,"nd_b"]),c(idhmut[,"nd_a"],idhmut[,"nd_b"]))										#0.04

#Compare primary depletion in each subtype:
g1 <- res[which(res[,"subtype"]=="IDHwt"),"nd_a"]
g2 <- res[which(res[,"subtype"]=="IDHmut-noncodel"),"nd_a"]
g3 <- res[which(res[,"subtype"]=="IDHmut-codel"),"nd_a"]

t.test(g1, mu=1)					#IDHwt:									0.66
t.test(g2, mu=1)					#IDHmut-noncodel:						0.22
t.test(g3, mu=1)					#IDHmut-codel:							0.32
t.test(c(g2,g3), mu=1)				#IDHmut:								0.12

t.test(g1,g2)						#IDHwt vs IDHmut-noncodel:				0.20
t.test(g1,g3)						#IDHwt vs IDHmut-codel:					0.28
t.test(g2,g3)						#IDHmut-noncodel vs IDHmut-codel:		0.89
t.test(g1,c(g2,g3))				#IDHwt vs IDHmut:							0.13

#Compare recurrent depletion in each subtype:
g4 <- res[which(res[,"subtype"]=="IDHwt"),"nd_b"]
g5 <- res[which(res[,"subtype"]=="IDHmut-noncodel"),"nd_b"]
g6 <- res[which(res[,"subtype"]=="IDHmut-codel"),"nd_b"]

t.test(g4, mu=1)					#IDHwt:									0.62
t.test(g5, mu=1)					#IDHmut-noncodel:						0.09
t.test(g6, mu=1)					#IDHmut-codel:							0.98
t.test(c(g5,g6), mu=1)				#IDHmut:								0.17

t.test(g4,g5)						#IDHwt vs IDHmut-noncodel:				0.09
t.test(g4,g6)						#IDHwt vs IDHmut-codel:					0.88
t.test(g5,g6)						#IDHmut-noncodel vs IDHmut-codel:		0.41
t.test(g4,c(g5,g6))				#IDHwt vs IDHmut:							0.16

#Compare primary vs recurrent depletion in each subtype
t.test(g1,g4,paired=TRUE)				#IDHwt:								0.92
t.test(g2,g5,paired=TRUE)				#IDHmut-noncodel:					0.75
t.test(g3,g6,paired=TRUE)				#IDHmut-codel:						0.09
t.test(c(g2,g3),c(g5,g6),paired=TRUE)	#IDHmut:							0.77

#Compare hypermutators at recurrence vs non-hypermutators at recurrence
t.test(res[which(res[,"hm_b"]==1),"nd_b"],res[which(res[,"hm_b"]==0),"nd_b"])	#0.54

#Subtype and timepoint figures
#-----------------------------------------------------

pair <- c(rep(res[,"tumor_pair_barcode"],2))
samp <- c(res[,"tumor_barcode_a"],res[,"tumor_barcode_b"])
rneo <- c(res[,"nd_a"],res[,"nd_b"])
subtype <- rep(res[,"subtype"],2)
timepoint <- c(rep("Initial",nrow(res)),rep("Recurrent",nrow(res)))
plot_res <- data.frame(pair,samp,rneo,subtype,timepoint)

#Old figure don't use
pdf("/projects/varnf/GLASS/Figures/resubmission/depletion_subtype_timepoint_box.pdf",width=2,height=2)
ggplot(plot_res, aes(y = rneo, x = timepoint,fill=subtype)) +
	geom_hline(yintercept=1, color = "gray50", size=1) +
	geom_boxplot(lwd=0.5,outlier.size=0.1,fatten=2) +
	labs(y="observed/expected neoantigens") +
	theme_classic() +
	theme(strip.text.x = element_text(size=7),strip.background = element_blank(),
	axis.title.y=element_text(size=7),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=7), axis.text.x=element_text(hjust=0.5,size=7),
	legend.position="none")
dev.off()

#******************************
#Figure 4B
#******************************
t.test(plot_res[which(plot_res[,"subtype"]=="IDHwt"),"rneo"],plot_res[which(plot_res[,"subtype"]=="IDHmut-noncodel"),"rneo"]) #0.04
pdf("/projects/varnf/GLASS/Figures/resubmission/Figure4B.pdf",width=3.75,height=2)
ggplot(plot_res, aes(y = rneo, x = subtype,colour=subtype)) +
	geom_boxplot(lwd=0.5,outlier.size=0.1,fatten=2,colour="black",fill="white") +
	geom_jitter(size=1,width=0.05) +
	labs(y="Observed/expected neoantigens") +
 	geom_text(aes(x=2.5, y=1.8, label = "P = 0.04"), size=gtsize, group = NA, color = "black") +
	theme_classic() +
	theme(strip.text.x = element_text(size=7),strip.background = element_blank(),
	axis.title.x=element_text(size=7),axis.title.y=element_blank(),
	axis.text=element_text(colour="black",size=7), axis.text.x=element_text(hjust=0.5,size=7),
	legend.position="none") +
	coord_flip(ylim=c(0,2.5))
dev.off()

#Old figure, replaced with correlation plot
pval <- rep("",nrow(plot_res))
pval[which(plot_res[,"subtype"]=="IDHwt")] <- "P = 0.70"
pval[which(plot_res[,"subtype"]=="IDHmut-noncodel")] <- "P = 0.77"
pval[which(plot_res[,"subtype"]=="IDHmut-codel")] <- "P = 0.14"
p_text <- cbind(plot_res,pval)
pdf("/projects/varnf/GLASS/Figures/resubmission/depletion_subtype_timepoint_ladder.pdf",width=4,height=2)
ggplot(plot_res, aes(x = timepoint, y = rneo, group = pair,colour=subtype)) +
	geom_line(size=0.45) +
	geom_point(size=1,colour="black") +
	labs(y="Observed/expected neoantigens") +
 	geom_text(data=p_text, aes(x=1.5, y=2, label = pval), size=gtsize, color = "black") +
	facet_grid(.~subtype) +
	theme_classic() +
	theme(strip.text.x = element_text(size=7),strip.background = element_blank(),
	axis.title.y=element_text(size=7),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=7), axis.text.x=element_text(hjust=0.5,size=7),
	legend.position="none")
dev.off()

#**********************************************************
#Extended Data Figure 12B: Hypermutator figures (two panels)
#**********************************************************

samp <- res[,"tumor_barcode_b"]
rneo <- res[,"nd_b"]
subtype <- res[,"subtype"]
hm <- as.factor(res[,"hm_b"])
plot_res_hm <- data.frame(samp,rneo,subtype,hm)
t.test(plot_res_hm[which(plot_res_hm[,"hm"]==1),"rneo"],plot_res_hm[which(plot_res_hm[,"hm"]==0),"rneo"]) #0.54

pdf("/projects/varnf/GLASS/Figures/resubmission/EDF12_depletion_hypermutator_recur_box.pdf",width=2,height=2)
ggplot(plot_res_hm, aes(y = rneo, x = hm, colour=hm)) +
	geom_boxplot(lwd=0.5,outlier.size=0.1,fatten=2,colour="black",fill="white") +
	geom_jitter(size=1,width=0.05) +
	labs(y="Observed/expected neoantigens") +
 	geom_text(aes(x=1.5, y=2, label = "P = 0.54"), size=gtsize, group = NA, color = "black") +
	scale_colour_manual(values=c("royalblue4","tomato3")) +
	theme_classic() +
	theme(strip.text.x = element_text(size=7),strip.background = element_blank(),
	axis.title.y=element_text(size=7),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=7), axis.text.x=element_text(hjust=0.5,size=7),
	legend.position="none")
dev.off()

tmp <- res[which(res[,"hm_b"]==1),]
pair <- c(rep(tmp[,"tumor_pair_barcode"],2))
samp <- c(tmp[,"tumor_barcode_a"],tmp[,"tumor_barcode_b"])
rneo <- c(tmp[,"nd_a"],tmp[,"nd_b"])
subtype <- rep(tmp[,"subtype"],2)
hm <-  c(tmp[,"hm_a"],tmp[,"hm_b"])
timepoint <- c(rep("Initial",nrow(tmp)),rep("Recurrent",nrow(tmp)))
plot_res_hmtp <- data.frame(pair,samp,rneo,hm,subtype,timepoint)

t.test(plot_res_hmtp[which(plot_res_hmtp[,"timepoint"]=="Initial"),"rneo"],plot_res_hmtp[which(plot_res_hmtp[,"timepoint"]=="Recurrent"),"rneo"],paired=TRUE) #P = 0.32
#P = 0.24

pdf("/projects/varnf/GLASS/Figures/resubmission/EDF12_depletion_hypermutator_timepoint_box.pdf",width=2,height=2)
ggplot(plot_res_hmtp, aes(y = rneo, x = timepoint, group=pair, colour=subtype)) +
	geom_line(size=0.45) +
	geom_point(size=1,colour="black") +
	labs(y="Observed/expected neoantigens") +
 	geom_text(aes(x=1.5, y=2, label = "P = 0.32"), size=gtsize, group = NA, color = "black") +
	theme_classic() +
	theme(strip.text.x = element_text(size=7),strip.background = element_blank(),
	axis.title.y=element_text(size=7),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=7), axis.text.x=element_text(hjust=0.5,size=7),
	legend.position="none")
dev.off()


#' Feature extraction: percentage of missing values
#'
#' A good quality of 3d scans is crucial for an assessment of similarity of
#' striation marks between different bullets.
#' Here, we measure the percentage of missing values in the scan. Generally,
#' a higher percentage of missing values is associated with a lower scan quality.
#' @param x3p scan in x3p format
#' @return percentage of missing values in the surface matrix of the scan
#' @export
#' @examples
#' data(fau277_bb_l2)
#' extract_na(fau277_bb_l2) # this scan has a particularly high percentage of missing values
#' extract_na(fau001_ba_l1) # good scan
extract_na <- function(x3p) {
  stopifnot(class(x3p) == "x3p")

  dims <- dim(x3p$surface.matrix)
  nas <- sum(is.na(x3p$surface.matrix))

  return(nas/prod(dims)*100)
}


#  James Rekow

##  A basic example to show how to chain some common functions together.

library(igraph)
source("abdListCreator.r")
source("DOCProcedure.r")
source("DOCNSSelector.r")

#  create a scale free connectivity graph with 40 vertices
conGraph = sample_pa(n = 40, power = 1, directed = FALSE)

#  create a list of integrated and interacted abundance vectors
#  there are 40 samples (M) and 20 bacterial species in each sample (N)
#  the rate parameter for the exponential wait time is 0.1 (lambda)
#  uses the connectivity graph created above when determining which samples can interact with each other
abdList = abdListCreator(M = 40, N = 20, lambda = 0.1, conGraph = conGraph)

#  create a list of two vectors: overlap values (x) and dissimilarity values (y) by applying DOCProcedure
#  to the created list of abundance vectors
doc = DOCProcedure(abdList = abdList)

#  remove points from doc that are not in the NS region
docNS = DOCNSSelector(doc)


setwd('~/Code/SMAI/BayesianNets')
library(plyr)

naive_bayes_opt <- function(data,test) {
  mask <- data[,ncol(data)] == " - 50000."
  negative <- data[mask,]
  positive <- data[!mask,]
  mistake = 0
  total = 0
  vec <- test[1,]
  data_list <- list()
  positive_list <- list()
  negative_list <- list()
  for(j in 1:(length(vec)-1)) {
    data_list[[capture.output(cat('V',j))]] <- count(data[,j])
    positive_list[[capture.output(cat('V',j))]] <- count(positive[,j])
    negative_list[[capture.output(cat('V',j))]] <- count(negative[,j])
  }
  for(i in 9000:10000) {
    vec <- test[i,]
    predict <- test[i,length(vec)]
    pos_score = 1
    neg_score = 1
    for(j in 1:(length(vec)-1)) {
      index <- capture.output(cat('V',j))
      num_total = data_list[[index]][data_list[[index]]$x == vec[1,j],]$freq
      num_pos = positive_list[[index]][positive_list[[index]]$x == vec[1,j],]$freq
      num_neg = negative_list[[index]][negative_list[[index]]$x == vec[1,j],]$freq
      pos_score = pos_score + log(num_pos) - log(nrow(positive))
      neg_score = neg_score + log(num_neg) - log(nrow(negative))
    }
    pos_score = pos_score + log(nrow(positive)) - log(nrow(data))
    neg_score = neg_score + log(nrow(negative)) - log(nrow(data))

    if(length(pos_score) == 0) {
      naive_predict = " - 50000."
    } else {
      if(pos_score  <= neg_score) {
        naive_predict = " - 50000."
      } else {
        naive_predict = " 50000+."
      }
    }
    if(naive_predict != predict) {
      mistake = mistake + 1
    }
    total = total +1
  }
  print(mistake/total)
}

naive_bayes <- function(data, test) {
  mask <- data[,ncol(data)] == " - 50000."
  negative <- data[mask,]
  positive <- data[!mask,]
  mistake = 0
  total = 0
  for(i in 1:100) {
    vec <- test[i,]
    predict <- test[i,length(vec)]
    pos_score = 1
    neg_score = 1
    #print(vec)
    for(j in 1:(length(vec)-1)) {
        a <- data.frame(table(data[,j]))
        b <- data.frame(table(positive[,j]))
        c <- data.frame(table(negative[,j]))
        num_total = a[a[,1] == vec[1,j],2]
        num_pos = b[b[,1] == vec[1,j],2]
        num_neg = c[c[,1] == vec[1,j],2]
        pos_score = pos_score + log(num_total/num_pos)
        neg_score = neg_score + log(num_total/num_neg)
    }
    pos_score = pos_score + log(nrow(data)/nrow(positive))
    neg_score = neg_score + log(nrow(data)/nrow(negative))

    if(length(pos_score) == 0) {
      naive_predict = " - 50000."
    } else {
      if((pos_score - neg_score)  >= 0.01) {
        naive_predict = " - 50000."
      } else {
        naive_predict = " 50000+."
      }
    }

    if(naive_predict != predict) {
      mistake = mistake + 1
    }
    total = total +1
  }
  print(mistake/total)
}
data <- read.table("Datasets/census-income.data",header = FALSE,stringsAsFactors=FALSE, sep = ",")
data <- data[,!sapply(data, is.numeric)]

test <- read.table("Datasets/census-income.test",header = FALSE, stringsAsFactors=FALSE, sep = ",")
test <- test[,!sapply(test, is.numeric)]
naive_bayes_opt(data,test)


stats_pca(TRUE, TRUE, x, s)
test = s$to_robj()
truth = prcomp(xr, scale.=TRUE, retx=FALSE)$sdev
cmp(test, truth)


#-----------------------------------------------------------------------------------------------------------------------------

discret_data_normalized <- function(x, inter){
  re <- rep((1/(length(inter)-1)),length(inter)-1)
  for(i in 2:length(inter)){
    re[i-1] <- (re[i-1] + length(which(x >= inter[i-1] & x < inter[i])))/(length(x)+1)
  }
  return(re)

}

#-----------------------------------------------------------------------------------------------------------------------------
discret_data <- function(x, inter){
  re <- NULL
  for(i in 2:length(inter)){
    re <- c(re, length(which(x >= inter[i-1] & x < inter[i]))/length(x) )
  }
  return(re)

}

#-----------------------------------------------------------------------------------------------------------------------------
getHist <- function(sc_1, sc_2, sc_t, measure, nbins){

  dist_corr <- c("harmonic_mean", "pearson", "neyman", "squared_chi", "prob_symm", "divergence", "clark", "additive_symm", "taneja", "kumar-johnson",
                 "kullback-leibler", "jeffreys", "k_divergence", "topsoe", "jensen-shannon", "jensen_difference", "topsoe.D")

  breaks <- seq(0,1,length.out = nbins+1)
  breaks <- c(breaks[-length(breaks)], 1.1)

  Sty_1 <- discret_data(sc_1,breaks)
  Sty_2 <- discret_data(sc_2,breaks)
  Uy    <- discret_data(sc_t,breaks)

  if(length(which(dist_corr%in%measure))){
      Sty_1 <- discret_data_normalized(sc_1,breaks)
      Sty_2 <- discret_data_normalized(sc_2,breaks)
      Uy    <- discret_data_normalized(sc_t,breaks)
  }

  return(list(Sty_1, Sty_2, Uy))

}
#-----------------------------------------------------------------------------------------------------------------------------
discret_data_percentil <- function(x, inter){

  re <- NULL

  re <- c(re, length(which(x <= inter[1]))/length(x))

  for(i in 2:length(inter)) re <- c(re, length(which(x > inter[i-1] & x <= inter[i]))/length(x) )

  re <- c(re, length(which(x > inter[length(inter)]))/length(x))
  return(re)

}
#-----------------------------------------------------------------------------------------------------------------------------
getHist_percentil <- function(sc_1, sc_2, sc_t, measure, nbins ){
  nbins <- nbins-1

  dist_corr <- c("harmonic_mean", "pearson", "neyman", "squared_chi", "prob_symm", "divergence", "clark", "additive_symm", "taneja", "kumar-johnson",
                 "kullback-leibler", "jeffreys", "k_divergence", "topsoe", "jensen-shannon", "jensen_difference")

  sc_t    <- sc_t+t(rand(n=length(sc_t),m=1))*0.001

  breaks  <- as.numeric(quantile(sc_t, probs = seq(0,1,length.out = nbins)))

  #breaks  <- c(breaks[-length(breaks)],1.1)

  Sty_1   <- discret_data_percentil(sc_1,breaks)

  Sty_2   <- discret_data_percentil(sc_2,breaks)

  Uy      <- discret_data_percentil(sc_t,breaks)

  return(list(Sty_1, Sty_2, Uy))
}


#'@title calcSpeedUnitConversion
#'
#'@description Convert speed in knots to m/s.
#'
#'@param shipSpeed Ship speed (vector of numericals, knots)
#'
#'@return speed (vector of numericals, m/s)
#'
#'@examples
#'calcSpeedUnitConversion(seq(10,15,1))
#'
#'@export

calcSpeedUnitConversion<- function(shipSpeed){

  speed<- shipSpeed*0.5144

  return(speed)
}


# Taken from: https://github.com/dmlc/xgboost/blob/master/R-package/vignettes/xgboostPresentation.Rmd

require(xgboost)
data(agaricus.train, package='xgboost')
data(agaricus.test, package='xgboost')
train <- agaricus.train
test <- agaricus.test
str(train)
dim(train$data)
dim(test$data)
class(train$data)[1]
class(train$label)

bstSparse <- xgboost(data = train$data, label = train$label, max_depth = 2, eta = 1, nthread = 2, nrounds = 2, objective = "binary:logistic")
bstDense <- xgboost(data = as.matrix(train$data), label = train$label, max_depth = 2, eta = 1, nthread = 2, nrounds = 2, objective = "binary:logistic")
dtrain <- xgb.DMatrix(data = train$data, label = train$label)
bstDMatrix <- xgboost(data = dtrain, max_depth = 2, eta = 1, nthread = 2, nrounds = 2, objective = "binary:logistic")
bst <- xgboost(data = dtrain, max_depth = 2, eta = 1, nthread = 2, nrounds = 2, objective = "binary:logistic", verbose = 2)
pred <- predict(bst, test$data)
print(length(pred))
print(head(pred))
prediction <- as.numeric(pred > 0.5)
print(head(prediction))
err <- mean(as.numeric(pred > 0.5) != test$label)
print(paste("test-error=", err))
dtrain <- xgb.DMatrix(data = train$data, label=train$label)
dtest <- xgb.DMatrix(data = test$data, label=test$label)
watchlist <- list(train=dtrain, test=dtest)
bst <- xgb.train(data=dtrain, max_depth=2, eta=1, nthread = 2, nrounds=2, watchlist=watchlist, objective = "binary:logistic")
bst <- xgb.train(data=dtrain, max_depth=2, eta=1, nthread = 2, nrounds=2, watchlist=watchlist, eval_metric = "error", eval_metric = "logloss", objective = "binary:logistic")


library("tikzDevice")

tikz('teste.tex')
u=seq(-3,3,by=.01)
plot(u,dnorm(u),type="l",axes=FALSE,xlab="z-score",ylab="Densidade de Probabilidade",col="white")
axis(1)
axis(2)
I=which((u<=1))
#polygon(c(u[I],rev(u[I])),c(dnorm(u)[I],rep(0,length(I))),col="gray",border=NA)
lines(u,dnorm(u),lwd=2,col="black")
text(.01, dnorm(20)+.25, "teste", cex = 1.5)
dev.off()


#' utci
#'
#' Calculate Universal Thermal Climate Index ( UTCI) in degC.
#'
#' @param t  numeric Air temperature in degC.
#' @param rh numeric Air Relative humidity.
#' @param wind numeric Windspeed in meters per second.
#' @param tr  numeric  Mean radiant temperature in degC.
#' @return UTCI index n degC
#' @references Brode P, Jendritzky G, Fiala D and Havenith G, 2011, The Universal Thermal Climate Index UTCI in Operational Use, International Journal of Biometeorology.
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  UTCI
#'
#' @export
#'
#'
#'
#'
utci <-function(t,rh,wind,tr=NULL) {
                         if(is.null(tr)) {tr=t}
                         ct$assign("ta", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$assign("tmrt", as.array(tr))
                         ct$eval("var res=[]; for(var i=0, len=ta.length; i < len; i++){ res[i]=UTCI(ta[i],rh[i],wind[i],tmrt[i])};")
                         res=ct$get("res")
                         res=ifelse(is.na(t),NA,res)
                         return(ifelse(res==9999,NA,res))
}