#################################################################
library(Hmisc)
library(readxl)
library(htmlwidgets)
library(DT)
library(psych)
library(summarytools)
library(skimr)
library(countrycode)
#################################################################
library(forcats)
library(tibble)
library(magrittr)
library(purrr)
library(dplyr)
library(ggplot2)
library(MASS)
library(fitdistrplus)
library(rlist)
library(vcd)
library(vcdExtra)
library(pastecs)
library(psych)
library(pheatmap)
library(RColorBrewer)
library(dendextend)
library(reshape2)
library(ggpubr)

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


library(plyr)
library(ggplot2)
library(RColorBrewer)
library(grid)
library(RSQLite)

setwd(dirname(sys.frame(1)$ofile))
theme_update(plot.margin = unit(c(0,0,0,0), "cm"))

outdir = "G:/tmp"

drv = dbDriver("SQLite")
con = dbConnect(drv, dbname=paste(outdir, "combined.db", sep="/"))

dta = dbGetQuery(con, paste("select vpath, vsize, npoints from meta",
  "where vpath in (",
  "'G:/tmp\\noisy_logisticsurrogate_data_set\\logisticTrainSignal.txt/vs/31',",
  "'G:/tmp\\many_small_datasets\\ERP_data.dat/vs/3699',",
  "'G:/tmp\\2DTimeSeries\\ASL_clean\24.dat/vs/2',",
  "'G:/tmp\\DanceGestureData\\Franck_Trajs\\Fra_EnrBass_Moy_Rot.san/vs/36_leftfootz',",
  "'G:/tmp\\dataset_kalpakis\\Population\\population.txt/vs/39_sd',",
  "'G:/tmp\\shape_mixed_bag\\time_series.txt/vs/208',",
  "'G:/tmp\\long_time_series\\tao.dat/vs/3045',",
  "'G:/tmp\\Mallat_technometrics\\dbtime_train.txt/vs/400')"))

deltafy = function(arr) {
  arr[2:length(arr)] - arr[1:length(arr)-1]
}

stopifnot( deltafy(c(10, 4, 6, 6, 2, 30)) == c(-6, 2, 0, -4, 28) )

toplot = NULL

dbyfile = ddply(dta, .(vpath), function(r) {
  fp = file(r$vpath, "rb")
  print(paste("path was", r$vpath, "size was", r$vsize))
  ints = as.numeric(readBin(fp, integer(), size=r$vsize, n=r$npoints))

  #print("deltas")
  #print(length(deltas))
  #print("unique")
  #print(length(unique(deltas)))
  #toplot <<- ints

  close(fp)
  data.frame(v = diff(ints))
})

#ggplot(data.frame(v=toplot), aes(x=v)) + geom_histogram()
#ggplot(data.frame(v=deltafy(toplot)), aes(x=v)) + geom_histogram()

#what's up with G:/tmp/DATA_from_SIGMOD04_Cai_Ng/stocks/table(18).csv/vs/1_open?

dbynamed = adply(dbyfile, 1, transform,
                 vpathren=(strsplit(vpath,"\\\\")[[1]][3]))
ggplot(dbynamed, aes(x=floor(log2(abs(v))))) + geom_histogram(binwidth=1) +
  facet_wrap(~ vpathren, ncol=1, scales="free") +
  scale_y_continuous("number of values") +
  scale_x_continuous("log base 2 of delta")
ggsave("figs/exponent-distribution.pdf", width=4, height=10)

dbDisconnect(con)


library(devtools)
load_all()
library(TwoSampleMR)

ss <- try(create_system(
	nidx=sample(20000:500000, 1),
	nidy=sample(20000:500000, 1),
	nidu=0,
	nu=sample(0:10, 1),
	na=0,
	nb=0,
	var_x.y=sample(c(0, runif(5, 0.001, 0.1)), 1),
	nsnp_x=sample(1:200, 1),
	nsnp_y=sample(1:200, 1),
	var_gx.x=runif(1, 0.01, 0.1),
	var_gy.y=runif(1, 0.01, 0.1),
	var_gx.y=runif(1, 0.001, 0.01),
	mu_gx.y=runif(1, -0.005, 0.005),
	prop_gx.y=runif(1, 0, 1),
	var_gy.x=runif(1, 0.001, 0.01),
	mu_gy.x=runif(1, -0.005, 0.005),
	prop_gy.x=runif(1, 0, 1)
))

nop <- try(create_system(
	nidx=100000,
	nidy=100000,
	nidu=0,
	nu=0,
	na=0,
	nb=0,
	var_x.y=0,
	nsnp_x=100,
	nsnp_y=100,
	var_gx.x=0.15,
	var_gy.y=0.15,
	var_gx.y=0,
	mu_gx.y=0,
	prop_gx.y=0,
	var_gy.x=0,
	mu_gy.x=0,
	prop_gy.x=0
))

withu <- try(create_system(
	nidx=10000,
	nidy=10000,
	nidu=10000,
	nu=2,
	na=2,
	nb=2,
	var_x.y=0,
	nsnp_x=100,
	nsnp_y=100,
	var_gx.x=0.15,
	var_gy.y=0.15,
	var_gx.y=0,
	mu_gx.y=0,
	prop_gx.y=0,
	var_gy.x=0,
	mu_gy.x=0,
	prop_gy.x=0
))

a <- make_dat(withu$x$x, withu$y$y) %>% filter(pval.exposure < 1e-8)
b <- make_dat(nop$x$x, nop$y$y) %>% filter(grepl("x", SNP), pval.exposure < 1e-8)

mr_scatter_plot(mr(a), a)
mr_scatter_plot(mr(b), b)
mr_heterogeneity(a)
mr_heterogeneity(b)

nop1 <- try(create_system(
	nidx=10000,
	nidy=10000,
	nidu=0,
	nu=0,
	na=0,
	nb=0,
	var_x.y=0.1,
	nsnp_x=100,
	nsnp_y=100,
	var_gx.x=0.15,
	var_gy.y=0.15,
	var_gx.y=0,
	mu_gx.y=0,
	prop_gx.y=0,
	var_gy.x=0,
	mu_gy.x=0,
	prop_gy.x=0
))

withu1 <- try(create_system(
	nidx=10000,
	nidy=10000,
	nidu=10000,
	nu=2,
	na=2,
	nb=2,
	var_x.y=0.1,
	nsnp_x=100,
	nsnp_y=100,
	var_gx.x=0.15,
	var_gy.y=0.15,
	var_gx.y=0,
	mu_gx.y=0,
	prop_gx.y=0,
	var_gy.x=0,
	mu_gy.x=0,
	prop_gy.x=0
))

a <- make_dat(withu1$x$x, withu1$y$y) %>% filter(pval.exposure < 1e-8)
b <- make_dat(nop1$x$x, nop1$y$y) %>% filter(grepl("x", SNP), pval.exposure < 1e-8)

mr_scatter_plot(mr(a), a)
mr_scatter_plot(mr(b), b)
mr_heterogeneity(a)
mr_heterogeneity(b)


## examine results from site reshuffled FST from ANGSD genotypes
## run after angsd_fst_siteshuffle_null.sh

#################
# parameters
#################
minloci <- 2 # should match angsd_fst_siteshuffle_null.r
winsz <- 50000 # window size
winstp <- 10000 # window step

###########################
# load functions
###########################
require(data.table)
#require(plyr)
require(ggplot2)
require(RColorBrewer)

calcp <- function(fst, null) return((sum(null > fst)+1)/(length(null)+1)) # equation from North et al. 2002 Am J Hum Gen

#####################
# read in and prep data
#####################

# max FST per genome from reshuffling (all sites)
# nullcan <- fread('analysis/Can_40.Can_14.fst.siteshuffle.csv.gz')
# nulllof0711 <- fread('analysis/Lof_07.Lof_11.fst.siteshuffle.csv.gz')
# nulllof0714 <- fread('analysis/Lof_07.Lof_14.fst.siteshuffle.csv.gz')
# nulllof1114 <- fread('analysis/Lof_11.Lof_14.fst.siteshuffle.csv.gz')

# max FST per genome from reshuffling (GATK nodam2 sites, combined in linkage blocks, >1 SNP per window)
nullcangatk <- fread('analysis/Can_40.Can_14.gatk.nodam.fst.siteshuffle.csv.gz')
nulllof0711gatk <- fread('analysis/Lof_07.Lof_11.gatk.nodam.fst.siteshuffle.csv.gz')
nulllof0714gatk <- fread('analysis/Lof_07.Lof_14.gatk.nodam.fst.siteshuffle.csv.gz')
nulllof1114gatk <- fread('analysis/Lof_11.Lof_14.gatk.nodam.fst.siteshuffle.csv.gz')

# sliding window FST A and B components from ANGSD, after collapsing to unlinked loci
# header is missing the fst column, so have to skip and make our own
# need to make the all loci AB files
# can <- fread('analysis/Can_40.Can_14.slide', skip = 1, header = FALSE, col.names = c('region', 'chr', 'midPos', 'Nsites', 'fst')) # all sites
# lof0711 <- fread('analysis/Lof_07.Lof_11.slide', skip = 1, header = FALSE, col.names = c('region', 'chr', 'midPos', 'Nsites', 'fst'))
# lof0714 <- fread('analysis/Lof_07.Lof_14.slide', skip = 1, header = FALSE, col.names = c('region', 'chr', 'midPos', 'Nsites', 'fst'))
# lof1114 <- fread('analysis/Lof_11.Lof_14.slide', skip = 1, header = FALSE, col.names = c('region', 'chr', 'midPos', 'Nsites', 'fst'))

cangatk <- fread('analysis/Can_40.Can_14.gatk.nodam.ldtrim.fst.AB.csv.gz', drop = 1) # gatk sites
lof0711gatk <- fread('analysis/Lof_07.Lof_11.gatk.nodam.ldtrim.fst.AB.csv.gz', drop = 1)
lof0714gatk <- fread('analysis/Lof_07.Lof_14.gatk.nodam.ldtrim.fst.AB.csv.gz', drop = 1)
lof1114gatk <- fread('analysis/Lof_11.Lof_14.gatk.nodam.ldtrim.fst.AB.csv.gz', drop = 1)

# nucleotide position for the whole genome (start position for each chr)
chrmax <- fread('data/lg_length.csv')
chrmax$start=c(0,cumsum(chrmax$len)[1:(nrow(chrmax)-1)])
setkey(chrmax, chr)

# merge nucleotide position into the frequency files
# setkey(can, chr)
# can <- can[chrmax[, .(chr, start)], ]
# can[, posgen := midPos + start]
# can[,start := NULL]
#
# setkey(lof0711, chr)
# lof0711 <- lof0711[chrmax[, .(chr, start)], ]
# lof0711[, posgen := midPos + start]
# lof0711[,start := NULL]
#
# setkey(lof0714, chr)
# lof0714 <- lof0714[chrmax[, .(chr, start)], ]
# lof0714[, posgen := midPos + start]
# lof0714[,start := NULL]
#
# setkey(lof1114, chr)
# lof1114 <- lof1114[chrmax[, .(chr, start)], ]
# lof1114[, posgen := midPos + start]
# lof1114[,start := NULL]

setkey(cangatk, CHROM)
cangatk <- cangatk[chrmax[, .(CHROM = chr, start)], ]
cangatk[, posgen := POS + start]
cangatk[,start := NULL]

setkey(lof0711gatk, CHROM)
lof0711gatk <- lof0711gatk[chrmax[, .(CHROM = chr, start)], ]
lof0711gatk[, posgen := POS + start]
lof0711gatk[,start := NULL]

setkey(lof0714gatk, CHROM)
lof0714gatk <- lof0714gatk[chrmax[, .(CHROM = chr, start)], ]
lof0714gatk[, posgen := POS + start]
lof0714gatk[,start := NULL]

setkey(lof1114gatk, CHROM)
lof1114gatk <- lof1114gatk[chrmax[, .(CHROM = chr, start)], ]
lof1114gatk[, posgen := POS + start]
lof1114gatk[,start := NULL]

######################
# Calc genome-wide FST
######################

# already removes unplaced
cangatk[!is.na(A), sum(A)/sum(B)]
lof0711gatk[!is.na(A), sum(A)/sum(B)]
lof0714gatk[!is.na(A), sum(A)/sum(B)]
lof1114gatk[!is.na(A), sum(A)/sum(B)]

######################
# Calc windowed FST
######################

# create new columns as indices for windows
for(j in 1:(winsz/winstp)){
  cangatk[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
  lof0711gatk[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
  lof0714gatk[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
  lof1114gatk[, (paste0('win', j)) := floor((POS - (j-1)*winstp)/winsz)*winsz + winsz/2 + (j-1)*winstp]
}

# calc fst and # snps per window
for(j in 1:(winsz/winstp)){
  if(j ==1){
    canfstsgatk <- cangatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))]
    lof0711fstsgatk <- lof0711gatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))]
    lof0714fstsgatk <- lof0714gatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))]
    lof1114fstsgatk <- lof1114gatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))]
  }
  if(j > 1){
    canfstsgatk <- rbind(canfstsgatk, cangatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))])
    lof0711fstsgatk <- rbind(lof0711fstsgatk, lof0711gatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))])
    lof0714fstsgatk <- rbind(lof0714fstsgatk, lof0714gatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))])
    lof1114fstsgatk <- rbind(lof1114fstsgatk, lof1114gatk[, .(fst = sum(A)/sum(B), nloci = length(POS)), by = .(CHROM, midPos = get(paste0('win', j)))])
  }
}

#######################
## null model stats
#######################

# nullcan[, .(max = max(x), u95 = quantile(x, probs = 0.95))]
# nulllof0711[, .(max = max(x), u95 = quantile(x, probs = 0.95))]
# nulllof0714[, .(max = max(x), u95 = quantile(x, probs = 0.95))]
# nulllof1114[, .(max = max(x), u95 = quantile(x, probs = 0.95))]

nullcangatk[, .(max = max(x), u95 = quantile(x, probs = 0.95))]
nulllof0711gatk[, .(max = max(x), u95 = quantile(x, probs = 0.95))]
nulllof0714gatk[, .(max = max(x), u95 = quantile(x, probs = 0.95))]
nulllof1114gatk[, .(max = max(x), u95 = quantile(x, probs = 0.95))]

###########################
# calc p-values per window
###########################

# can[, p := calcp(fst, nullcan$x), by = .(chr, midPos)]
# lof0711[, p := calcp(fst, nulllof0711$x), by = .(chr, midPos)]
# lof0714[, p := calcp(fst, nulllof0714$x), by = .(chr, midPos)]
# lof1114[, p := calcp(fst, nulllof1114$x), by = .(chr, midPos)]

canfstsgatk[, p := calcp(fst, nullcangatk$x), by = .(CHROM, midPos)]
lof0711fstsgatk[, p := calcp(fst, nulllof0711gatk$x), by = .(CHROM, midPos)]
lof0714fstsgatk[, p := calcp(fst, nulllof0714gatk$x), by = .(CHROM, midPos)]
lof1114fstsgatk[, p := calcp(fst, nulllof1114gatk$x), by = .(CHROM, midPos)]

######################
# combine the datasets
######################
# all loci
# lof0711[, pop := 'lof0711']
# lof0714[, pop := 'lof0714']
# lof1114[, pop := 'lof1114']
# can[, pop := 'can']
#
# dat <- rbind(lof0711, lof0714, lof1114, can)
# nrow(dat)
# dat
#
# dat[, pop := factor(pop, levels = c('can', 'lof0711', 'lof0714', 'lof1114'))]

# gatk loci
canfstsgatk[, pop := 'can']
lof0711fstsgatk[, pop := 'lof0711']
lof0714fstsgatk[, pop := 'lof0714']
lof1114fstsgatk[, pop := 'lof1114']

datgatk <- rbind(canfstsgatk, lof0711fstsgatk, lof0714fstsgatk, lof1114fstsgatk)
nrow(datgatk)
datgatk

datgatk[, pop := factor(pop, levels = c('can', 'lof0711', 'lof0714', 'lof1114'))]

# remove NAs and negative windows
datgatk <- datgatk[!is.na(fst) & midPos > 0, ]

# sort by window
setkey(datgatk, pop, CHROM, midPos)

##############
# Write out
##############

# write.csv(dat, file = gzfile('output/fst_siteshuffle.angsd.csv.gz'), row.names = FALSE)
write.csv(datgatk, file = gzfile('output/fst_siteshuffle.angsd.gatk.csv.gz'), row.names = FALSE)

##############
# plots
##############

# plot p-value vs. position (all loci)
# cols <- brewer.pal(4, 'Paired')[rep(1:2,12)]
# p1 <- ggplot(dat, aes(posgen, -log10(p), color = chr)) +
#   geom_point(size = 0.2, alpha = 0.3) +
#   facet_wrap(~pop, ncol = 1) +
#   scale_color_manual(values = cols) +
#   geom_hline(yintercept = -log10(0.05), linetype = 'dashed', color = 'grey')
# p1
#
# ggsave(plot = p1, device = 'png', filename = 'figures/fst.siteshuffle.p_vs_pos.png', width = 7.5, height = 6, units = 'in', dpi = 300)
#

# plot p-value vs. position (gatk loci)
# only where nloci >= minloci
cols <- brewer.pal(4, 'Paired')[rep(1:2,12)]
p2 <- ggplot(datgatk[nloci >= minloci, ], aes(midPos, -log10(p), color = CHROM)) +
  geom_point(size = 0.2, alpha = 0.3) +
  facet_wrap(~pop, ncol = 1) +
  scale_color_manual(values = cols) +
  geom_hline(yintercept = -log10(0.05), linetype = 'dashed', color = 'grey')
p2

ggsave(plot = p2, device = 'png', filename = 'figures/fst.siteshuffle.p_vs_pos.gatk.png', width = 7.5, height = 6, units = 'in', dpi = 300)

# plot p-value vs. nloci (gatk loci)
ggplot(datgatk, aes(nloci, -log10(p), color = pop)) +
  geom_point(size = 0.2, alpha = 0.3) +
  geom_hline(yintercept = -log10(0.05), linetype = 'dashed', color = 'grey') +
  scale_x_log10()

#################
# print outliers
#################

datgatk[p < 0.05, ]


## ---------------------------
##
## Script name: 600 CORONA JENA - Reproduktionszahl.r
##
## Purpose of script: Berechnet die CReproduktionszahl der COVID-19 Patienten in Jena
##
## Author: Volker Holzendorf
##
## Date Created: 2020-04-30
##
## Email: statistik@jena.de
##
## ---------------------------
##
## Notes:
##
##
## --------------------------
## load up the packages we will need
library(tidyverse)
library(EpiEstim)
library(JenaR)

#library(OurTools)
## --------------------------

dfepiweeksdays <- dfepiweeks %>%
  #group_by(row_number()) %>%
  complete(weekkstartdat = seq.Date(min(weekkstartdat), max(max(weekkstartdat,today())), by="day")) %>%
  #  complete(weekkstartdat = seq.Date(min(weekkstartdat), max(weekkstartdat), by="day")) %>%
  mutate(weeknr = na.locf0(weeknr),
         daygrp = rep(1:ceiling(length(weeknr)/4),each = 4)[1:length(weeknr)]
  )

dfJ_I <- dfJ_corona %>% dplyr::select(FALL,datI) %>% group_by(datI) %>% count() %>% rename(i = n)

Ipday <- dfepiweeksdays %>% rename(datI = weekkstartdat) %>% left_join(dfJ_I) %>%
  mutate(i = if_else(is.na(i),"0",as.character(i)),
         i = as.numeric(i),
         ip = i/sum(i)) %>%
  filter(datI > "2020-03-10")

dim(Ipday)

# Reproduktionszahl für 4 Tage Intervalle
T <- length(Ipday$i)
t_start <- seq(2, T-4) # starting at 2 as conditional on the past observations
t_end <- t_start + 4 # adding 6 to get 7-day windows as bounds included in window

res_parametric_si <- estimate_R(Ipday$i,
                                method="parametric_si",
                                config = make_config(list(
                                  t_start = t_start,
                                  t_end = t_end,
                                  mean_si = 10,
                                  std_si = 4))
)

res_parametric_si$R

p<-plot(res_parametric_si, legend = FALSE,what = "incid", options_I = list(col = "darkblue"))
p

p + theme_minimal() +
  guides(color = FALSE, fill = FALSE) +
  theme(axis.text = element_text(size = 16),
        axis.title = element_text(size = 20),
        plot.title = element_text(size = 25,face = "bold")

        ) +
  labs(y = "Anzahl Neuerkrankte pro Tag",
       title = "COVID-19 in Jena",
       x = "Tage seit erstem Fall")
mkr.saveplotCORONA("601 COVID-19 in Jena pro Tag",datendat)
print("601 COVID-19 in Jena pro Tag - done")

p<-plot(res_parametric_si, legend = FALSE,what = "R", options_R = list(col = "darkred",size = 2))

p + theme_minimal() +
  guides(color = FALSE, fill = FALSE) +
  theme(axis.text = element_text(size = 16),
        axis.title = element_text(size = 20),
        plot.title = element_text(size = 25,face = "bold")
  ) +
  labs(y = "Reproduktionszahl, geschätzt",
       title = "Reproduktionszahl in Jena",
       x = "Tage seit erstem Fall")
mkr.saveplotCORONA("602 Kurve der Reproduktionszahl",datendat)
print("602 Kurve der Reproduktionszahl - done")

res_parametric_si$R


#############################################################################
# confidence interval of M2  calculated from mean and standard deviations

tmp<-Read.SMS.std()

if (SMS.control@no.species==3)  tmp<-subset(tmp,select=c(-species,-prey,-predator))

# plot the result
X11()
plotConfM2<-function(M2age=0) {
  var.name<-c("M2_sd0","M2_sd1")
  a<-subset(tmp,name %in% var.name & age==M2age)
  a$Species=sp.names[a$species]
  a$minus<-a$value-2*a$std
  a$plus<-a$value+2*a$std
  print(xyplot(minus+ value+plus~year|Species, type='l', ylab='Predation mortality, M2', xlab=NULL,
    lwd=c(2,2.5,2),col=c(4,1,4),lty=c(2,1,2),scales = "free",layout = c(1,3),   data=a))
}
 plotConfM2(0)
plotConfM2(1)


#Title: phastcons_score_heatmap
#Auther: Naoto Imamachi
#ver: 1.0.0
#Date: 2015-06-10

#library
library(pheatmap)

#file_path
setwd("C:/Users/Naoto/Documents/github/MIRAGE/data/PhyloP/")
input_file_path = "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/phastCons46way_miRBase_v21_hg38Tohg19_f1_f23.txt"

#output_text.km4 <- "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/PhastCons46Ways_miRBase_v21_hg38Tohg19_kmeans4.txt"
output_text.km5 <- "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/PhastCons46Ways_miRBase_v21_hg38Tohg19_kmeans5.txt"
#output_text.km6 <- "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/PhastCons46Ways_miRBase_v21_hg38Tohg19_kmeans6.txt"
#output_text.km7 <- "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/PhastCons46Ways_miRBase_v21_hg38Tohg19_kmeans7.txt"

output_file_path = "C:/Users/Naoto/Documents/github/MIRAGE/data/PhastCons46Ways/PhastCons46Ways46way_miRBase_v21_hg38Tohg19_heatmap.png"

data <- read.table(input_file_path,row.names=1,header=F)
colnames(data) <- c('1','2','3','4','5','6','7','8','9','10',
                    '11','12','13','14','15','16','17','18','19',
                    '20','21','22')

#d.km4 <- kmeans(as.matrix(data),centers=4)
d.km5 <- kmeans(as.matrix(data),centers=5)
#d.km6 <- kmeans(as.matrix(data),centers=6)
#d.km7 <- kmeans(as.matrix(data),centers=7)

#result.km4 <- cbind(d.km4$cluster,data)
result.km5 <- cbind(d.km5$cluster,data)
#result.km6 <- cbind(d.km6$cluster,data)
#result.km7 <- cbind(d.km7$cluster,data)

#o<- order(result.km4[,1]) # order the last column
#result.km4 <- result.km4[o,] # order the matrix according to the order of the last column
#pheatmap( result.km4[,2:23], cluster_rows = F, cluster_cols = F)

o<- order(result.km5[,1])
result.km5 <- result.km5[o,]
pheatmap( result.km5[,2:23], cluster_rows = F, cluster_cols = F)

#o<- order(result.km6[,1])
#result.km6 <- result.km6[o,]
#pheatmap( result.km6[,2:23], cluster_rows = F, cluster_cols = F)

#o<- order(result.km7[,1])
#result.km7 <- result.km7[o,]
#pheatmap( result.km7[,2:23], cluster_rows = F, cluster_cols = F)

#write.table(file=output_text.km4,result.km4,sep="\t",quote=F)
write.table(file=output_text.km5,result.km5,sep="\t",quote=F)
#write.table(file=output_text.km6,result.km6,sep="\t",quote=F)
#write.table(file=output_text.km7,result.km7,sep="\t",quote=F)


isOutOfTime = function(testTimeLimit, testTimeLeft, itemTimeLimit, itemTimeFullRequired) {
  if(testTimeLimit > 0) {
    if(testTimeLeft <= 1) { return(T) }
    if(testTimeLeft < itemTimeLimit && itemTimeFullRequired) { return(T) }
  }
  return(F)
}

getStopReason = function(testTimeLimit, itemTimeLimit, itemTimeFullRequired, itemNumLimit, minAccuracy, minAccuracyMinItems, itemsNum, excludedItems) {
  outOfTime = isOutOfTime(
    testTimeLimit,
    testTimeLeft,
    itemTimeLimit,
    itemTimeFullRequired
  )

  if(outOfTime) {
    return("timeOut")
  }

  maxItems = dim(items)[1]
  itemNumLimit = as.numeric(settings$itemNumLimit)
  if(itemNumLimit > 0) { maxItems = min(maxItems, itemNumLimit) }
  totalPages = ceiling(maxItems / as.numeric(settings$itemsPerPage))

  if(itemNumLimit > 0 && length(itemsAdministered) >= itemNumLimit || length(itemsAdministered) - length(excludedItems) >= itemsNum) {
    if(direction > 0 && totalPages == page) {
      return("maxItems")
    }
  }

  if(minAccuracy != 0 && minAccuracy >= sem && minAccuracyMinItems <= length(itemsAdministered)) {
    return("minAccuracy")
  }

  return(NULL)
}

stopReason = getStopReason(
  as.numeric(settings$testTimeLimit),
  as.numeric(settings$itemTimeLimit),
  settings$itemTimeFullRequired == "1",
  as.numeric(settings$itemNumLimit),
  as.numeric(settings$minAccuracy),
  as.numeric(settings$minAccuracyMinItems),
  dim(items)[1],
  excludedItems
)
if(!is.na(settings$stopCheckModule) && settings$stopCheckModule != "") {
  stopReason = concerto.test.run(settings$stopCheckModule, params=list(
    stopReason = stopReason,
    settings = settings,
    theta = theta,
    sem = sem,
    itemsAdministered = itemsAdministered,
    session = session,
    responses = responses,
    scores = scores,
    items = items,
    templateResponse = templateResponse,
    excludedItems = excludedItems
  ))$stopReason
}

concerto.log(stopReason, "stopReason")

if(is.null(stopReason)) {
  .branch = "continue"
} else {
  .branch = "stop"
}


#Map of locations of NEON sites used in forecast.
rm(list=ls())
source('paths.r')
library(ggplot2)
library(ggalt)

#set output path.----
out.path <- 'map.png'

#load location data and format.----
d <- readRDS(ITS_site_dates.path)
location <- readRDS(dp1.10086.00_output.path)
sites <- unique(location$siteID)
ted <- readRDS(tedersoo_ITS_clean_map.path)

#load NEON data mapping file for sites actually used in forecast.
neon.map <- readRDS(hierarch_filled.path)
neon.map <- neon.map$site.site.mu
location <- location[location$siteID %in% neon.map$siteID,]

#within eah site get mean latitude, longitude and elevation.
lat <- aggregate(decimalLatitude  ~ siteID, data = location, FUN = mean)
lon <- aggregate(decimalLongitude ~ siteID, data = location, FUN = mean)
neo.lat <- lat[,2]
neo.lon <- lon[,2]
ted.lat <- ted$latitude
ted.lon <- ted$longitude

#setup save routine.----
png(filename=out.path,width=7,height=5,units='in',res=300)

#build map.----
#Slightly cutting off right edge of x-axis.
world <- map_data('world')
map <- ggplot() + geom_cartogram(data = world, map = world, aes(x=long, y = lat, group = group, map_id=region))
map <- map + coord_proj("+proj=wintri", ylim = c(23.5, 66.5))
map <- map + geom_point(aes(x = neo.lon, y = neo.lat), color = "yellow"    , size = 2)
map <- map + geom_point(aes(x = ted.lon, y = ted.lat), color = "#FF33CC", size = 2)
map <- map + labs(x='longitude', y='latitude')
map

#end plot.----
dev.off()


#
# Copyright (c) 2016 10x Genomics, Inc. All rights reserved.
#

#' Analysis functions
#'

#' Run principal components analysis to reduce the dimensionality of a gene-barcode matrix
#'
#' @param gbm a GeneBCMatrix to run PCA on
#' @param n_pcs The number of principal components to compute
#' @return A list containing \itemize{
#' \item "x" - The rotated data matrix where rows are barcodes and columns are PCs
#' \item "rotation" - The loadings (eigenvectors) where each column is a PC
#' \item "use_genes" - The list of gene indices that were used
#' \item "normalized_mat" - The matrix that was used as input to the PCA
#' }
#' @export
#' @examples
#' pca <- run_pca(gbm1, n_pcs=2)
#' plot(PC2 ~ PC1, pca$x)
#'
run_pca <- function(gbm, n_pcs=10) {
  use_genes <- get_nonzero_genes(gbm)
  gbm_bcnorm <- normalize_barcode_sums_to_median(gbm[use_genes,])
  gbm_log <- log_gene_bc_matrix(gbm_bcnorm)

  pca <- sparse_pca(t(exprs(gbm_log)), n_pcs)

  pc_names <- sprintf("PC%d", 1:ncol(pca$x))
  rownames(pca$x) <- colnames(gbm)
  colnames(pca$x) <- pc_names

  rownames(pca$rotation) <- rownames(gbm)[use_genes]
  colnames(pca$rotation) <- pc_names
  cat('Variance explained by PCs',pca$var_explained,'\n')
  return(list(x=pca$x,
              rotation=pca$rotation,
              use_genes=use_genes,
              normalized_mat=exprs(gbm_log),
              var_explained=pca$var_explained))
}

#' Project dimensionally reduced gene-barcode matrix into a visualizable space via t-SNE
#'
#' @param pca A PCA result from run_pca()
#' @param ... parameters to pass to Rtsne
#' @return See ?Rtsne in the Rtsne package. The item of interest is the 'Y' element which contains the coordinates.
#' @importFrom Rtsne Rtsne
#' @export
#' @examples
#' \dontrun{
#' pca <- run_pca(gbm1, n_pcs=10)
#' tsne_res <- run_tsne(pca)
#' plot(tsne_res$Y[,1], tsne_res$Y[,2])
#'}
run_tsne <- function(pca, ...) {
  return(Rtsne(pca$x, ...))
}

#' Run k-means clustering
#'
#' @param pca A PCA result from run_pca()
#' @param k number of clusters
#' @param ... parameters to pass to kmeans
#' @return See ?kmeans. The item of interest is the 'cluster' element
#' @export
#' @seealso kmeans
#' @examples
#' pca <- run_pca(gbm1, n_pcs=10)
#' km_res <- run_kmeans_clustering(pca, k=5)
#'
run_kmeans_clustering <- function(pca, k, ...) {
  return(kmeans(pca$x, k, ...))
}

#' Run a fast PCA algorithm while maintaining sparsity
#'
#' @param x a sparse matrix to run PCA on
#' @param n_pcs number of principal components to compute
#' @param mu column means
#' @param s column standard deviations
#' @param center_scale perform centering and scaling
#' @return a list containing the rotated matrix ('x') and the principal component vectors ('rotation')
#' @importFrom irlba irlba
#' @examples
#' \dontrun{
#' pca <- sparse_pca(x, n_pcs=10)
#' plot(pca$x[,1], pca$x[,2], xlab='PC1', ylab='PC2')
#' }
sparse_pca <- function(x, n_pcs, mu=NULL, s=NULL, center_scale=TRUE) {
  if (is.null(mu) && center_scale) mu <- colMeans(x)
  if (is.null(s) && center_scale) s <- apply(x, 2, sd, na.rm=TRUE)

  if (center_scale) {
    s[s == 0] <- min(s[s > 0])
    svd_res <- irlba::irlba(x, n_pcs, center=mu, scale=s)
  } else {
    svd_res <- irlba::irlba(x, n_pcs)
  }
  # compute explained variance
  variance_sum <- sum(apply(x,2,var,na.rm=TRUE)) # sample variance sum
  pca_sum <- sum(svd_res$d^2)/(dim(x)[1]-1)
  var_explained <- pca_sum / variance_sum

  return(list(x=svd_res$u %*% diag(svd_res$d), rotation=svd_res$v, var_explained=var_explained))
}

#' Get ordered gene list by mean difference between clusters
#'
#' @param gbm A GeneBCMatrix
#' @param cluster_labels An array of integer labels from 1 to k (length = number of cells)
#' @param test_ID A label between 1 to k to be tested
#' @return an array of genes sorted by the mean differential expression between testID and the rest
#'
get_ordered_gene_list_mean_diff <- function(gbm,cluster_labels,test_ID) {
  # return gene list sorted by mean difference between a cluster verse the rest
  cat('Comparing Cluster',test_ID, 'against the other clusters...\n')
  mean_0 <- rowMeans(gbm[,cluster_labels!=test_ID])
  mean_1 <- rowMeans(gbm[,cluster_labels==test_ID])
  mean_diff <- mean_1 - mean_0
  sort_index <- sort(mean_diff,index.return = TRUE, decreasing=TRUE)$ix
  return(sort_index)
}

#' Get ordered gene list by gene uniqueness
#'
#' @param gbm A GeneBCMatrix
#' @param cluster_labels An array of integer labels from 1 to k (length = number of cells)
#' @param test_ID A label between 1 to k to be tested
#' @return an array of genes sorted by the mean differential expression between testID and the rest
#'
get_ordered_gene_list_unique <- function(gbm,cluster_labels,test_ID) {
  # return gene list sorted by mean difference between a cluster verse the rest
  cat('Comparing Cluster',test_ID, 'against the other clusters...\n')
  mean_0 <- rowMeans(exprs(gbm[,cluster_labels!=test_ID]) > 0 )
  mean_1 <- rowMeans(exprs(gbm[,cluster_labels==test_ID]) > 0 )
  mean_diff <- mean_1 - mean_0
  sort_index <- sort(mean_diff,index.return = TRUE, decreasing=TRUE)$ix
  return(sort_index)
}

#' Order cells based on clusters
#'
#' @param gbm A GeneBCMatrix
#' @param clu An array of integer labels from 1 to k (length = number of cells)
#' @return A list of (n_top_genes * number of clusters) genes (may include duplicates)
#' @import Biobase
#' @export
#' @examples
#' \dontrun{
#'  order_cell_by_clusters(gbm_log,clu)
#' }
order_cell_by_clusters <- function(gbm,clu) {
  uni_labels <- sort(unique(clu))
  sorted_clu_id <- sort(clu,index.return=TRUE)
  index_list <- lapply(uni_labels, function(x) sorted_clu_id$ix[sorted_clu_id$x==x])
  cell_info <- as.character(pData(gbm)$barcode)
  ordered_cells <- lapply(index_list, function(x) {
                          list(barcode=cell_info[x],ix=x)} )
  names(ordered_cells) <- uni_labels
  return(ordered_cells)
}

#' Prioritize genes that are most significant markers for each cluster
#'
#' @param gbm A GeneBCMatrix (recommended to be normalized by UMI counts and log-transformed)
#' @param clu An array of integer labels from 1 to k (length = number of cells)
#' @param n_top_genes Number of top genes for each cluster group to consider
#' @param method Method to priortize genes: currently only supports mean difference
#' @import Biobase
#' @export
#' @examples
#' \dontrun{
#'  prioritize_top_genes(gbm_log,clu,3,'mean_diff')
#' }
prioritize_genes<-function(gbm,clu,method) {
  uni_labels <- sort(unique(clu))
  if (method == 'mean_diff') {
    index_list <- lapply(uni_labels, function(x) get_ordered_gene_list_mean_diff(gbm,clu,x))
  } else if (method == 'unique') {
    index_list <- lapply(uni_labels, function(x) get_ordered_gene_list_unique(gbm,clu,x))
  } else {
    stop('Method: ',method,' not recognized\n')
  }
  genes <- fData(gbm)
  ordered_genes <- lapply(index_list, function(x) {
                          list(id=genes$id[x],symbol=genes$symbol[x],ix=x)} )
  names(ordered_genes) <- uni_labels
  return(ordered_genes)
}

#' Tabulate the proportion of each cell type in respective classes
#'
#' @param clu An array of integer labels from 1 to k (length = number of cells)
#' @param anno Annotation for the k classes (can be an array of strings)
#' @param n_digits Number of digits for to display
#' @return A table of the break down of the numbers of each label (with optional annotation)
#' @export
#' @examples
#' \dontrun{
#'  cell_composition(clu)
#' }
cell_composition <- function(clu,anno=NULL,n_digits=5) {
  cat("Cell composition: \n")
  num_cells <- table(factor(clu,levels=min(clu):max(clu)))
  num_cells <- round(num_cells, 0)
  proportion <- num_cells / sum(num_cells)
  proportion <- round(proportion, n_digits)
  out <- rbind(num_cells,proportion)
  if (!is.null(labels)) {
    # colnames(out) <- anno
    annotation <- anno
    out <- rbind(annotation,out)
  }
  return(out)
}


###############################################################################
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Collection of routines to examine and compare proxies and data
# Copyright (C) 2013  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

###############################################################################
#' Compute correlations
#'
#' @param data matrix with data
#' @param method method used to compute correlations, please see \code{\link{cor}} for more details
#'
#' @return correlation matrix
#'
#' @export
###############################################################################
compute.cor <- function
(
	data, 		# matrix with data
	method = c("pearson", "kendall", "spearman")
)
{
	cor(data, use='complete.obs',method=method[1])
}

###############################################################################
#' Plot proxies and create summary table over common period
#'
#' @param data.all list or enviroment that holds proxy time series
#' @param names names or indexs of time series, \strong{defaults to all time series}
#' @param price.fn name of price function, \strong{defaults to Ad}
#'
#' @return nothing
#'
#' @examples
#' \dontrun{
#' tickers = spl('HYG,VWEHX')
#' data = new.env()
#'   getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
#'
#' proxy.test(data)
#' }
#' @export
###############################################################################
proxy.test <- function(data.all, names = ls(data.all), price.fn=Ad)
{
	#*****************************************************************
	# Prepare data
	#******************************************************************
	data = new.env()
		data$symbolnames = names
	for(n in data$symbolnames)
		data[[n]] = make.stock.xts( price.fn( data.all[[n]] ) )
	bt.prep(data, align='remove.na', fill.gaps=T)

	#*****************************************************************
	# Prepare data
	#******************************************************************
	prices = data$prices

	# Plot side by side
#	layout(1:2, heights=c(4,1))
layout(1)
		plota.matplot(scale.one(prices))

	rets = (prices/mlag(prices)-1)[-1,]

	# compute correlations
	temp = cor(rets, use='complete.obs', method='pearson')
		diag(temp) = NA
		temp[lower.tri(temp)] = NA
		#temp = temp[-nrow(temp),-1,drop=F]
		temp = temp[-nrow(temp),,drop=F]
		temp[] = plota.format(100 * temp, 0, '', '%')
	out = temp

	# compute stats
	temp = compute.stats( as.list(rets),
			list(
				Mean=function(x) 252*mean(x,na.rm=T),
				StDev=function(x) sqrt(252)*sd(x,na.rm=T)
				)
			)
	temp[] = plota.format(100 * temp, 1, '', '%')

	# plot
	out = rbind(out,NA,temp)
#	plot.table(out)
  print(out)
}

###############################################################################
#' Plot 12 Month Spread for 2 symbols over common period
#'
#' @param data.all list or enviroment that holds proxy time series
#' @param names names or indexs of time series, \strong{defaults to all time series}
#' @param price.fn name of price function, \strong{defaults to Ad}
#'
#' @return nothing
#'
#' @examples
#' \dontrun{
#' tickers = spl('HYG,VWEHX')
#' data = new.env()
#'   getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
#'
#' proxy.spread(data)
#' }
#' @export
###############################################################################
plot12month.rolling.spread <- function(data.all, names = ls(data.all), price.fn=Ad)
{
	#*****************************************************************
	# Prepare data
	#******************************************************************
	data = new.env()
		data$symbolnames = names[1:2]
	for(n in data$symbolnames)
		data[[n]] = make.stock.xts( price.fn( data.all[[n]] ) )
	bt.prep(data, align='remove.na', fill.gaps=T)

	#*****************************************************************
	# Prepare data
	#******************************************************************
	prices = data$prices
	rets.12m.rolling = 100 * (prices / mlag(prices, 252) - 1)
	spread.12m.rolling = rets.12m.rolling[,1] - rets.12m.rolling[,2]

	# Plot side by side
	layout(1)
	plota(spread.12m.rolling, type='l',
		main = paste('12 Month Rolling Returns Spread % for', names[1], 'and', names[2]))
		abline(h=0, col='gray')
}

###############################################################################
#' Plot all proxies overlaying the longest one
#'
#' @param data.all list or enviroment that holds proxy time series
#' @param names names or indexs of time series, \strong{defaults to all time series}
#' @param price.fn name of price function, \strong{defaults to Ad}
#'
#' @return nothing
#'
#' @examples
#' \dontrun{
#' tickers = spl('HYG,VWEHX')
#' data = new.env()
#'   getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
#'
#' proxy.overlay.plot(data)
#' }
#' @export
###############################################################################
proxy.overlay.plot <- function(data.all, names = ls(data.all), price.fn=Ad)
{
	#*****************************************************************
	# Prepare data
	#******************************************************************
	data = new.env()
		data$symbolnames = names
	for(n in data$symbolnames)
		data[[n]] = make.stock.xts( price.fn( data.all[[n]] ) )

	bt.prep(data, align='keep.all', fill.gaps=T)

	#*****************************************************************
	# Prepare data
	#******************************************************************
	prices = data$prices
		prices = scale.one(prices, T)

	# Plot side by side
	layout(1)
	plota.matplot(prices)
}

###############################################################################
#' Plot complete history for each index for Close and Adjusted, and create summary table
#'
#' @param data list or enviroment that holds proxy time series
#' @param names names or indexs of time series, \strong{defaults to all time series}
#'
#' @return nothing
#'
#' @examples
#' \dontrun{
#' tickers = spl('HYG,VWEHX')
#' data = new.env()
#'   getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
#'
#' proxy.prices(data)
#' }
#' @export
###############################################################################
proxy.prices <- function(data, names = ls(data)) {
	n.names = len(names)
	temp = list()

#	layout(1:(n.names+1))
	layout(1:n.names)
	for(n in names) {
		plota.matplot(cbind(Cl(data[[n]]),Ad(data[[n]])),main=n)
		temp[[ paste(n, 'Price') ]] = Cl(data[[n]])
		temp[[ paste(n, 'Total') ]] = Ad(data[[n]])
	}

	# compute stats
	temp = compute.stats( lapply(temp, function(x) ifna(x/mlag(x) -1,NA)),
			list(
				Mean=function(x) 252*mean(x,na.rm=T),
				StDev=function(x) sqrt(252)*sd(x,na.rm=T)
				)
			)

	# plot
	temp[] = plota.format(100 * temp, 1, '', '%')
#	plot.table(temp)
	print(temp)
}

#' @export
proxy.map <- function(raw.data, tickers)
{
	#*****************************************************************
	# Prepare data
	#******************************************************************
  data <- new.env()
  tickers = spl(tickers)
  tickers = tickers[order(sapply(tickers, nchar),decreasing =T)]

  getSymbols.extra(tickers, src = 'yahoo', from = '1980-01-01', env = data, raw.data = raw.data, set.symbolnames = T, auto.assign = T)
    for(i in data$symbolnames) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)
  bt.prep(data, align='keep.all', fill.gaps=T)

  layout(1)
  plota.matplot(data$prices)
}

proxy.example.test <- function() {
    #*****************************************************************
    # Load historical data
    #******************************************************************
    load.packages('quantmod')

    tickers = spl('GSG,DBC')
    data = new.env()
    getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
        for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)

    # "TRJ_CRB" file was downloaded from the http://www.jefferies.com/Commodities/2cc/389
    # for "TRJ/CRB Index-Total Return"
    temp = extract.table.from.webpage( join(readLines("TRJ_CRB")), 'EODValue' )
    temp = join( apply(temp, 1, join, ','), '\n' )
    data$CRB_1 = make.stock.xts( read.xts(temp, format='%m/%d/%y' ) )

    # "prfmdata.csv" file was downloaded from the http://www.crbequityindexes.com/indexdata-form.php
    # for "TR/J CRB Global Commodity Equity Index", "Total Return", "All Dates"
    data$CRB_2 = make.stock.xts( read.xts("prfmdata.csv", format='%m/%d/%Y' ) )

    #*****************************************************************
    # Compare
    #******************************************************************
jpeg(filename = 'plot1.jpg', width = 500, height = 500, units = 'px', pointsize = 12)
    proxy.test(data)
dev.off()
jpeg(filename = 'plot2.jpg', width = 500, height = 500, units = 'px', pointsize = 12)
    proxy.overlay.plot(data)
dev.off()

    #*****************************************************************
    # Load historical data
    #******************************************************************
    load.packages('quantmod')

    tickers = spl('IYR,VGSIX,RWO')
    data = new.env()
    getSymbols(tickers, src = 'yahoo', from = '1970-01-01', env = data, auto.assign = T)
        for(i in ls(data)) data[[i]] = adjustOHLC(data[[i]], use.Adjusted=T)

    #*****************************************************************
    # Compare
    #******************************************************************
jpeg(filename = 'plot3.jpg', width = 500, height = 500, units = 'px', pointsize = 12)
    proxy.test(data)
dev.off()
jpeg(filename = 'plot4.jpg', width = 500, height = 500, units = 'px', pointsize = 12)
    proxy.overlay.plot(data)
dev.off()

# VGSIX,VEIEX,VBMFX,VWEHX,PEBIX,VIPSX,VTSMX,VGTSX,VFISX,VUSTX
#
#    Equity Market
#        Vanguard Total Stock Mkt (VTSMX)
#        Vanguard Total Intl Stock (VGTSX)
#        Vanguard 500 Index (VFINX)
#        Vanguard Emerging Mkts (VEIEX)
#    Fixed Income Market
#        Vanguard Short-Term Treasury (VFISX)
#        Vanguard Long-Term Treasury (VUSTX)
#        Vanguard Total Bond Market (VBMFX)
#        Vanguard High-Yield Corporate (VWEHX)
#        PIMCO Emerging Markets Bond (PEBIX)
#        Vanguard Inflation-Protected (VIPSX)
#        PIMCO Total Return (PTTRX)
#    Vanguard REIT (VGSIX)
#
}


###############################################################################
# Negative Binomial GLM fitting
#------------------------------------------------------------------------------
# The DESeq {DESeq2} package allows negative binomial GLM fitting and Wald
# statistics for abundance data. You can use this script as an alternative to
# KW.R to find taxa that are significantly different between different
# conditions.
#------------------------------------------------------------------------------
# based on Umer Zeeshan Ijaz (http://userweb.eng.gla.ac.uk/umer.ijaz)
# and https://github.com/MadsAlbertsen/ampvis/blob/master/R/amp_test_species.R
###############################################################################

# install.packages('DESeq2') # Install package.

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(ggplot2)
library(DESeq2)

#==============================================================================
# Let's rock'n'roll!
#==============================================================================

#Load the abundance table
abund_table <- read.csv("SPE_pitlatrine.csv", row.names=1, check.names=FALSE)

#Transpose the data to have sample names on rows
abund_table <- t(abund_table)

#Get grouping information
grouping_info <- data.frame(row.names=rownames(abund_table), t(as.data.frame(strsplit(rownames(abund_table), "_"))))
# > head(grouping_info)

#We will convert our table to DESeqDataSet object
countData = round(as(abund_table,  "matrix"),  digits = 0)
# We will add 1 to the countData otherwise DESeq will fail with the error:
# estimating size factors
# Error in estimateSizeFactorsForMatrix(counts(object),  locfunc = locfunc,   :
# every gene contains at least one zero,  cannot compute log geometric means
countData <- (t(countData+1))

dds  <-  DESeqDataSetFromMatrix(countData,  grouping_info,  as.formula(~ X1))

#Reference:https://github.com/MadsAlbertsen/ampvis/blob/master/R/amp_test_species.R

#Differential expression analysis based on the Negative Binomial (a.k.a. Gamma-Poisson) distribution
#Some reason this doesn't work: data_deseq_test = DESeq(dds,  test="wald",  fitType="parametric")
data_deseq_test = DESeq(dds)

## Extract the results
res = results(data_deseq_test,  cooksCutoff = FALSE)
res_tax = cbind(as.data.frame(res),  as.matrix(countData[rownames(res),  ]),  OTU = rownames(res))

sig = 0.001
fold = 0
plot.point.size = 2
label=T
tax.display = NULL
tax.aggregate = "OTU"

res_tax_sig = subset(res_tax,  padj < sig & fold < abs(log2FoldChange))

res_tax_sig  <-  res_tax_sig[order(res_tax_sig$padj), ]

## Plot the data
### MA plot
res_tax$Significant  <-  ifelse(rownames(res_tax) %in% rownames(res_tax_sig) ,  "Yes",  "No")
res_tax$Significant[is.na(res_tax$Significant)]  <-  "No"
p1  <-  ggplot(data = res_tax,  aes(x = baseMean,  y = log2FoldChange,  color = Significant)) +
  geom_point(size = plot.point.size) +
  scale_x_log10() +
  scale_color_manual(values=c("black",  "red")) +
  labs(x = "Mean abundance",  y = "Log2 fold change")+theme_bw()
if(label == T){
  if (!is.null(tax.display)){
    rlab  <-  data.frame(res_tax,  Display = apply(res_tax[, c(tax.display,  tax.aggregate)],  1,  paste,  collapse="; "))
  } else {
    rlab  <-  data.frame(res_tax,  Display = res_tax[, tax.aggregate])
  }
  p1  <-  p1 + geom_text(data = subset(rlab,  Significant == "Yes"),  aes(label = Display),  size = 4,  vjust = 1)
}
pdf("NB_MA.pdf")
print(p1)
dev.off()

res_tax_sig_abund = cbind(as.data.frame(countData[rownames(res_tax_sig),  ]),  OTU = rownames(res_tax_sig),  padj = res_tax[rownames(res_tax_sig), "padj"])

#Apply normalisation (either use relative or log-relative transformation)
#data <- abund_table/rowSums(abund_table)
data <- log((abund_table+1)/(rowSums(abund_table)+dim(abund_table)[2]))
data <- as.data.frame(data)

#Now we plot taxa significantly different between the categories
df <- NULL
for(i in res_tax[rownames(res_tax_sig), "OTU"]){
  tmp <- data.frame(data[, i], groups, rep(paste(i, " padj = ", round(res_tax[i, "padj"], 5), sep=""), dim(data)[1]))
  if(is.null(df)){df <- tmp} else { df <- rbind(df, tmp)}
}
colnames(df) <- c("Value", "Type", "Taxa")

#==============================================================================
# Plots
#==============================================================================
p <- ggplot(df, aes(Type, Value, colour=Type))+ylab("Log-relative normalised")
p <- p+geom_boxplot()+geom_jitter()+theme_bw()+
  facet_wrap( ~ Taxa ,  scales="free",  ncol=3)
p <- p+theme(axis.text.x=element_text(angle=90, hjust=1, vjust=0.5))
pdf("NB_significant.pdf", width=10, height=14)
print(p)
dev.off()


> do.perms(names, test)
From bottom to top: -->  smith cooper baker fletcher miller

> system.time(do.perms(names, test))
From bottom to top: -->  smith cooper baker fletcher miller
   user  system elapsed
      0       0       0


# check trends and prinf pdfs in P:/is-wel/indus/message_indus/input/check
library(ggplot2)
#####
# check total runoff
runoff_by_admin.df = demand.par %>% filter(level == 'inflow') %>% mutate(time = as.numeric(time)) %>%
  left_join( ., data.frame( time = seq(1:12), days = c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
  left_join( ., data.frame( node = node, country = unlist( strsplit( node, '_' ) )[ seq( 1, 2*length(node), by = 2 ) ] ) ) %>%
  group_by(year_all, time, country) %>% summarise( value = sum( abs( value * days )/1e3 ) ) %>%
  ungroup() %>% data.frame()
runoff_by_admin.df = rbind( runoff_by_admin.df, runoff_by_admin.df %>%
                              group_by(year_all, time) %>% summarise( value = sum( value ) ) %>%
                              mutate( country = 'Indus' ) %>% ungroup() %>% data.frame() %>% select( year_all, time, country, value ) )
pdf( 'input/check/runoff.pdf', width = 7, height = 6 )
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par(mar=c(4,4,3,3), oma = c(1,1,1,1))
for( ccc in unique( runoff_by_admin.df$country ) ){
  runoff_by_admin.df %>% filter( country == ccc ) %>%
    select( year_all, time, value ) %>%
    reshape( ., idvar = 'time', timevar = 'year_all', direction = 'wide' ) %>%
    select( -time ) %>%
    as.matrix() %>%
    matplot( ., type = 'l', ylab = 'cubic kilometers', xlab = 'month of year', main = paste0( ccc, ' - Runoff' ), lty = 1, col = c('black','cyan','blue','purple','brown','red')  )
}
plot.new()
legend( 'left', legend = c(2015,seq(2020,2060,by=10) ), title = 'Decade', bty = 'n', cex = 1.2, seg.len = 3, col = c('black','cyan','blue','purple','brown','red'), lty = 1 )
dev.off()
###
runoff_by_admin_Yavg.df = inflow.df %>%
  left_join( ., data.frame( time = seq(1:12), days = c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
  group_by(year_all, time, node) %>% summarise( value = sum( abs( value * days )/1e3 ) ) %>%
  ungroup() %>% data.frame() %>%
  mutate(type = 'internal runoff')

tot_runoff1 = runoff_by_admin.df %>% ungroup() %>% group_by(year_all,country) %>% summarise(value= sum(value) )
tot_runoff2 = runoff_by_admin_Yavg.df %>% group_by(year_all) %>% summarise(value= sum(value) )

# Compare with Natural flow
natural_flow_Yavg.df = environmental_flow.df %>%
  left_join( data.frame( time = seq(1:12), days = c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
  mutate(country = gsub('_.*','',node)) %>%
  group_by(year_all,time, node) %>% summarise(value = sum(value * days)/1e3) %>% ungroup() %>%
  mutate(type = 'natual flow')

# also look at exogenous aquifer recharge
recharge_Yavg.df = recharge.df %>%
  left_join( data.frame( time = seq(1:12), days = c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
  mutate(country = gsub('_.*','',node)) %>%
  group_by(year_all,time, node) %>% summarise(value = sum(abs(value * days))/1e3) %>% ungroup() %>%
  mutate(type = 'aquifer recharge')

to_plot = rbind(runoff_by_admin_Yavg.df,natural_flow_Yavg.df,recharge_Yavg.df)
pdf( 'input/check/runoff_nat-flow_recharge.pdf', width = 10, height = 10 )
ggplot(to_plot,aes(x = time, y = value, group = interaction(year_all,type),color = type)) +
  geom_line(size = 0.1)+
  facet_wrap(~node)+
  theme_bw()+ylab('cubic kilometers')+xlab('months')+
  theme(legend.position = 'bottom')
dev.off()

###
# Check municipal and manufacturing water demands
demand_by_admin.df = demand.df %>% filter( level %in% c('urban_final','rural_final'), commodity == c('freshwater') ) %>%
  left_join( ., data.frame( time = as.character(c(seq(1:12)) ), days = c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
  left_join( ., data.frame( node = node, country = unlist( strsplit( node, '_' ) )[ seq( 1, 2*length(node), by = 2 ) ] ) ) %>%
  group_by(year_all, time, country) %>% summarise( value = sum( abs( value * days )/1e3 ) ) %>%
  ungroup() %>% data.frame()
demand_by_admin.df = rbind( demand_by_admin.df, demand_by_admin.df %>%
                              group_by(year_all, time) %>% summarise( value = sum( value ) ) %>%
                              mutate( country = 'Indus' ) %>% ungroup() %>% data.frame() %>% select( year_all, time, country, value ) )
pdf( 'input/check/nonirrigation_water_demand.pdf', width = 7, height = 6 )
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par(mar=c(4,4,3,3), oma = c(1,1,1,1))
for( ccc in unique( demand_by_admin.df$country ) ){
  demand_by_admin.df %>% filter( country == ccc ) %>%
    select( year_all, time, value ) %>%
    reshape( ., idvar = 'time', timevar = 'year_all', direction = 'wide' ) %>%
    select( -time ) %>%
    as.matrix() %>%
    matplot( ., type = 'l', ylab = 'cubic kilometers', xlab = 'month of year', main = paste0( ccc, ' - Withdrawal' ), lty = 1, col = c('black','cyan','blue','purple','brown','red')  )
}
plot.new()
legend( 'left', legend = c(2015,seq(2020,2060,by=10) ), title = 'Decade', bty = 'n', cex = 1.2, seg.len = 3, col = c('black','cyan','blue','purple','brown','red'), lty = 1 )
dev.off()

###
# Check municipal and manufacturing return flow
return_by_admin.df = demand.df %>% filter( level %in% c('urban_final','rural_final'), commodity == c('wastewater') ) %>%
  left_join( ., data.frame( time = as.character(c(seq(1:12)) ), days = c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ) ) %>%
  left_join( ., data.frame( node = node, country = unlist( strsplit( node, '_' ) )[ seq( 1, 2*length(node), by = 2 ) ] ) ) %>%
  group_by(year_all, time, country) %>% summarise( value = sum( abs( value * days )/1e3 ) ) %>%
  ungroup() %>% data.frame()
return_by_admin.df = rbind( return_by_admin.df, return_by_admin.df %>%
                              group_by(year_all, time) %>% summarise( value = sum( value ) ) %>%
                              mutate( country = 'Indus' ) %>% ungroup() %>% data.frame() %>% select( year_all, time, country, value ) )
pdf( 'input/check/nonirrigation_wastewater_demand.pdf', width = 7, height = 6 )
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par(mar=c(4,4,3,3), oma = c(1,1,1,1))
for( ccc in unique( return_by_admin.df$country ) ){
  return_by_admin.df %>% filter( country == ccc ) %>%
    select( year_all, time, value ) %>%
    reshape( ., idvar = 'time', timevar = 'year_all', direction = 'wide' ) %>%
    select( -time ) %>%
    as.matrix() %>%
    matplot( ., type = 'l', ylab = 'cubic kilometers', xlab = 'month of year', main = paste0( ccc, ' - Return' ), lty = 1, col = c('black','cyan','blue','purple','brown','red')  )
}
plot.new()
legend( 'left', legend = c(2015,seq(2020,2060,by=10) ), title = 'Decade', bty = 'n', cex = 1.2, seg.len = 3, col = c('black','cyan','blue','purple','brown','red'), lty = 1 )
dev.off()

###
# Check municipal / manufacturing consumption
consumption_by_admin.df	= left_join( demand_by_admin.df %>% rename( dem = value ), return_by_admin.df %>% rename( ret = value ) ) %>% mutate( value = dem - ret ) %>% select( -dem, -ret )
pdf( 'input/check/nonirrigation_consumption_demand.pdf', width = 7, height = 6 )
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par(mar=c(4,4,3,3), oma = c(1,1,1,1))
for( ccc in unique( consumption_by_admin.df$country ) ){
  return_by_admin.df %>% filter( country == ccc ) %>%
    select( year_all, time, value ) %>%
    reshape( ., idvar = 'time', timevar = 'year_all', direction = 'wide' ) %>%
    select( -time ) %>%
    as.matrix() %>%
    matplot( ., type = 'l', ylab = 'cubic kilometers', xlab = 'month of year', main = paste0( ccc, ' - Consumption' ), lty = 1, col = c('black','cyan','blue','purple','brown','red')  )
}
plot.new()
legend( 'left', legend = c(2015,seq(2020,2060,by=10) ), title = 'Decade', bty = 'n', cex = 1.2, seg.len = 3, col = c('black','cyan','blue','purple','brown','red'), lty = 1 )
dev.off()

## widthdrawals mcm/day
hist_withdrawals.df = read.csv( "input/historical_new_cap.csv", stringsAsFactors=FALSE ) %>%
  filter(grepl('sw_diversion|gw_diversion',tec)) %>% filter(year_all == 2015) %>%
  # mutate(type = gsub('_.*','',tec)) %>%
  group_by(year_all,tec) %>% summarise(value = sum(value)) %>% ungroup() %>%
  mutate(value = value *365/1e3) # in km3

hist_withdrawals_agg = hist_withdrawals.df
  group_by(year_all) %>% summarise(value = sum(value)) %>% ungroup()

hist_annual_inflow = runoff_by_admin.df %>% filter( country == 'Indus') %>%
  group_by(year_all) %>% summarise(value = sum(value)) %>% ungroup()

ggplot()+
  geom_bar(data = (hist_annual_inflow %>% filter(year_all == 2015) ),aes(x = year_all,y = value),
           stat = 'identity',width = 0.5, position = position_nudge(x = -0.5))+
  geom_bar(data = (hist_withdrawals_agg %>% filter(year_all == 2015) ),aes(x = year_all,y = value, fill = type),
           stat = 'identity',width = 0.5, position = position_nudge(x = 0.5))+
  scale_x_continuous(breaks = c(2015))+
  theme_bw()+ylab('km3')+xlab('Year')

 ###
# Check crop yield demand
yield_by_admin.df0 = demand.df %>%
  filter( level == 'raw' ) %>%
  mutate( commodity = unlist( strsplit( commodity, '_' ) )[seq(1,2*length(commodity),by=2)]) %>%
  select(node, commodity, year_all, value)
yield_by_admin.df = rbind( yield_by_admin.df0, yield_by_admin.df0 %>%
                             group_by( commodity, year_all ) %>%
                             summarise( value = sum( value ) ) %>%
                             ungroup() %>% data.frame() %>%
                             mutate( node = 'Indus' ) %>%
                             select(node, commodity, year_all, value) ) %>% rename( country = node )

ggplot()+
  geom_line(data = yield_by_admin.df,aes(year_all,value/1000,color = commodity))+
  facet_wrap(~country)+
  ggtitle('Yield demand')+ylab('Mton product demand')+
  theme_bw()
pdf( 'input/check/yield_demand.pdf', width = 7, height = 5 )
cols = data.frame( row.names = c('cotton', 'fodder', ' fruit', 'pulses','maize', 'rice', 'sugarcane','vegetables', 'wheat'),
                   col = c("#1b9e77", "#d95f02",'#b1b1b1', "#7570b3","#25bad9","#e7298a", "#66a61e",'#005ad1', '#e6ab02'))
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par( mar=c(4,4,3,3), oma = c(1,1,1,1) )
for( ccc in unique( yield_by_admin.df$country ) ){
  df = yield_by_admin.df %>% filter( country == ccc ) %>%
    filter( year_all %in% c(2015, seq(2020, 2060, by = 10) ) ) %>%
    select( year_all, commodity, value ) %>%
    mutate( value = value / 1e3 ) %>%
    reshape( ., idvar = 'commodity', timevar = 'year_all', direction = 'wide' )
  barplot( as.matrix( df %>% select( -commodity ) ), ylab = 'million tons', names.arg = c(2015, seq(2020, 2060, by = 10) ), las = 2, main = paste0( ccc ), col = as.character(cols[ df$commodity, ]) )
  abline( h = 0 )
}
plot.new()
legend( 'left', legend = row.names(cols), title = 'Crop', bty = 'n', cex = 1.25, fill = as.character(unlist(cols)) )
dev.off()

## energy exogeneous demand
en_demand0 = demand.df %>% filter(commodity == 'electricity') %>%
  mutate(level = gsub('_.*','',level) ) %>%
  mutate(country = gsub('_.*','',node) ) %>%
  mutate(value = (value * 30 *24* 1e-6)) %>%  # TWh
  group_by(level,year_all,country) %>%
  summarise(value = sum (value)) %>%
  ungroup() %>%
  select(country, level, year_all, value)

en_demand = rbind( en_demand0, en_demand0 %>%
                             group_by( level, year_all ) %>%
                             summarise( value = sum( value ) ) %>%
                             ungroup() %>%
                             mutate( country = 'Indus' )) %>%
                             select(country, level, year_all, value) %>%
  as.data.frame()

en_final_col = data.frame( row.names = c("industry","rural","urban"),
                           col = c( "#FF7F00",  "#4DAF4A", "#A65628" ))
pdf( 'input/check/ex_energy_demand.pdf', width = 7, height = 5 )
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par( mar=c(4,4,3,3), oma = c(1,1,1,1) )
for( ccc in unique( en_demand$country ) ){
  df = en_demand %>% filter( country == ccc ) %>%
    filter( year_all %in% c(2015, seq(2020, 2060, by = 10) ) ) %>%
    select( year_all, level, value ) %>%
    reshape( ., idvar = 'level', timevar = 'year_all', direction = 'wide' )
  barplot( as.matrix( df %>% select( -level ) ), ylab = 'TWh', names.arg = c(2015, seq(2020, 2060, by = 10) ), las = 2, main = paste0( ccc ), col = as.character(en_final_col[ df$level, ]) )
  abline( h = 0 )
}
plot.new()
legend( 'left', legend = row.names(en_final_col), title = 'sector', bty = 'n', cex = 1.25, fill = as.character(unlist(en_final_col)) )
dev.off()

#water
wat_demand0 = demand.df %>% filter(commodity == 'freshwater',level != 'inflow') %>%
  mutate(level = gsub('_.*','',level) ) %>%
  mutate(country = gsub('_.*','',node) ) %>%
  mutate(value = (value * 30 * 1e-3)) %>%  # km3/year
  group_by(level,year_all,country) %>%
  summarise(value = sum (value)) %>%
  ungroup() %>% filter(country != 'CHN') %>%
  select(country, level, year_all, value)

wat_demand = rbind( wat_demand0, wat_demand0 %>%
                     group_by( level, year_all ) %>%
                     summarise( value = sum( value ) ) %>%
                     ungroup() %>%
                     mutate( country = 'Indus' )) %>%
  select(country, level, year_all, value) %>%
  as.data.frame()

en_final_col = data.frame( row.names = c("industry","rural","urban"),
                           col = c( "#FF7F00",  "#4DAF4A", "#A65628" ))
pdf( 'input/check/ex_wat_demand.pdf', width = 7, height = 5 )
p1 = layout( matrix( c(1,2,3,4,5,6), 2,3, byrow=TRUE ), widths=c(0.24,0.24,0.24), heights=c(0.4,0.4) )
par( mar=c(4,4,3,3), oma = c(1,1,1,1) )
for( ccc in unique( wat_demand$country ) ){
  df = wat_demand %>% filter( country == ccc ) %>%
    filter( year_all %in% c(2015, seq(2020, 2060, by = 10) ) ) %>%
    select( year_all, level, value ) %>%
    reshape( ., idvar = 'level', timevar = 'year_all', direction = 'wide' )
  barplot( as.matrix( df %>% select( -level ) ), ylab = 'km3', names.arg = c(2015, seq(2020, 2060, by = 10) ), las = 1, main = paste0( ccc ), col = as.character(en_final_col[ df$level, ]) )
  abline( h = 0 )
}
plot.new()
legend( 'left', legend = row.names(en_final_col), title = 'sector', bty = 'n', cex = 1.25, fill = as.character(unlist(en_final_col)) )
dev.off()

###

#### check water supply>demand in 2015
## Run load_inputs first

inflow2015 = inflow.df %>% filter(year_all == 2015) %>%
  rename(inflow = value) %>% mutate(time = as.character(time)) %>%
  select(node,year_all,time,inflow)

return2015 = demand.df %>% filter(commodity == 'wastewater', year_all == 2015) %>%
  group_by(node, year_all , time) %>%
  summarize(return = sum(value)) %>%
  select(node,year_all,time,return)

# max groundwater that can be used

# demand, rural and urban
UR_demand2015 = demand.df %>% filter(commodity == 'freshwater', level %in% c('urban_final','rural_final'), year_all == 2015) %>%
  group_by(node,year_all,time) %>% summarise(URdem = sum(value)) %>%
  select(node,year_all,time,URdem)

#agriculture missing
total_node_time = inflow2015 %>% left_join(return2015) %>%
  left_join(UR_demand2015) %>%
  mutate(surplus = inflow + return + URdem)

#water scarcity without accounting for agriculture
total_node_time %>% filter(surplus >= 0) %>%
  ggplot()+
  geom_point(aes(x= node,y = surplus,shape = time))+
  ggtitle('Water scarcity, no river support, no agriculture')+
  ylab('decifit in demand [Mm3]')+
  theme_bw()

downs = basin.spdf@data %>% select(PID,DOWN) %>%
  rename(node = PID, node_dw = DOWN) %>% mutate(node_dw = if_else(is.na(node_dw),'SINK',as.character(node_dw)))
# it is quite tricky to calculate the max available water for each node, considering possible upstream flow from river.
# need to map upstream nodes first

#calculate

## Crop Yields per country
countr_avg_yield = crop_input_data.df %>%
  filter(par %in% c('irrigation_yield','rain-fed_yield')) %>%
  mutate(country = gsub('_.*','',node) ) %>%
  group_by(crop,par,country,unit) %>%
  summarise(value = mean (value)) %>%
  ungroup()

new_residue = countr_avg_yield %>%
  group_by(crop,par) %>% summarise(value = mean(value)) %>%
  spread(par,value) %>% mutate(ratio = `rain-fed_yield`/irrigation_yield) %>%
  select(crop,ratio) %>% left_join(residue_data %>% select(crop,res_yield)) %>%
  rename(irrigation_yield = res_yield) %>% mutate(`rain-fed_yield` = irrigation_yield*ratio) %>%
  gather(key ='par',value = 'value',3:4) %>% select(-ratio)

p1 = ggplot() +
  geom_bar(data = countr_avg_yield,aes(x = crop,y = value/1000,fill = country),
           stat = 'identity',position = position_dodge2(width = 1,preserve = c("single"),padding = 0.1 ) )+
  facet_wrap(~par,nrow = 2)+
  geom_point(data = new_residue,aes(x = crop,y = value/1000, color = ' '))+
  ylab('Average highest country crop yield [t/ha]')+
  scale_fill_brewer(type = 'qual',palette = 2)+
  scale_color_manual(name = "residue", values = c(" " = "black"))+
  theme_bw()

pdf( 'input/check/avg_crop_yields.pdf', width = 7, height = 6 )
p1
dev.off()

## check area requirements to meet crop demand
calc_land_crop = countr_avg_yield %>% filter(par == 'irrigation_yield') %>% rename(node = country,yield = value) %>% select(-par) %>%
  left_join(yield_by_admin.df0 %>% filter(year_all == 2020) %>% select(-year_all) %>%  rename(crop = commodity,demand = value)) %>%
  mutate(area_req = demand/yield) %>%
  mutate(area_req = if_else(is.na(area_req),0,area_req))

land_av = read.csv( 'input/land_availability_map.csv', stringsAsFactors=FALSE ) %>%
  mutate(node = gsub('_.*','',node)) %>% group_by(node,units) %>%
  summarise(area_av = sum(value))

check_land_av = calc_land_crop %>% group_by(node,unit) %>%
  summarise(area_req = sum(area_req)) %>%
  left_join(land_av) %>%
  mutate(LACK_LAND = area_req - area_av)

## check production trends and projections

maps_path = paste0(getwd(),'/input/land_maps_crop_yields')
national_trend.path = path.expand(paste0(maps_path,'/FAO_hist_national_prod'))
nat_trend.files = list.files(path = national_trend.path,pattern = '.csv')

prod_hist = NULL
for (jj in seq_along(nat_trend.files)){

  tmp_national = read.csv(paste0(national_trend.path,'/',nat_trend.files[jj])) %>%
    filter(Unit == 'tonnes', Year <= 2015 ) %>%
    mutate(Value = Value * 1E-6, Unit = 'mton') %>%
    left_join(data.frame(Area = c('Pakistan','Afghanistan','India'),country = c('PAK','AFG','IND'))) %>%
    left_join(data.frame(Item = c("Seed cotton","Sorghum",'Oranges','Fruit, citrus nes', "Maize" , "Pulses, nes" ,  "Rice, paddy", "Sugar cane" ,'Onions, dry','Potatoes', "Wheat" ),
                         crop = c('cotton', 'fodder',      'fruit', 'fruit',          'maize','pulses',       'rice',      'sugarcane',     'vegetables','vegetables','wheat' ))) %>%
    select(country,crop,Year,Unit,Value) %>%
    rename(year_all = Year, unit = Unit, value = Value)
  prod_hist = bind_rows(prod_hist,tmp_national)
}
prod_hist = prod_hist %>% group_by(country,crop,year_all,unit) %>% summarise(value = sum(value)) %>% ungroup()

yield_by_admin.df2 = yield_by_admin.df %>% mutate(unit = 'Mton') %>% filter(!country == 'Indus') %>% rename(crop = commodity) %>%
  select(country,crop,year_all,unit,value) %>% mutate(value = value/1000)
  # rbind(prod_hist) %>%
  # arrange(year_all)

# from crop_yield, take prod_out, production in 2000
prod_out_sum = prod_out %>% mutate(country = gsub('_.*','',node)) %>%
  group_by(country,crop,unit) %>%
  summarise(value = sum(value)/1000) %>% ungroup() %>%
  mutate(year_all = 2000,unit = 'Mton')

p11 = ggplot()+
  geom_line(data = yield_by_admin.df2 %>% filter(country == 'PAK'),aes(year_all,value,colour = crop))+
  geom_line(data = prod_hist %>% filter(country == 'PAK'),aes(year_all,value,colour = crop))+
  geom_point(data = prod_out_sum %>% filter(country == 'PAK'),aes(year_all,value,colour = crop),size = 2)+
  geom_vline(xintercept=2015)+
  ylab('PAK Production [Mton]')+
  theme_bw()+
  scale_x_continuous(limits = c(2000,2020))

p12 = ggplot()+
  geom_line(data = yield_by_admin.df2 %>% filter(country == 'IND'),aes(year_all,value,colour = crop))+
  geom_line(data = prod_hist %>% filter(country == 'IND'),aes(year_all,value,colour = crop))+
  geom_point(data = prod_out_sum %>% filter(country == 'IND'),aes(year_all,value,colour = crop),size = 2)+
  geom_vline(xintercept=2015)+
  ylab('IND Production [Mton]')+
  theme_bw()+
  scale_x_continuous(limits = c(2000,2020))

p13 = ggplot()+
  geom_line(data = yield_by_admin.df2 %>% filter(country == 'AFG'),aes(year_all,value,colour = crop))+
  geom_line(data = prod_hist %>% filter(country == 'AFG'),aes(year_all,value,colour = crop))+
  geom_point(data = prod_out_sum %>% filter(country == 'AFG'),aes(year_all,value,colour = crop),size = 2)+
  geom_vline(xintercept=2015)+
  ylab('AFG Production [Mton]')+
  theme_bw()+
  scale_x_continuous(limits = c(2000,2020))

library(gridExtra)
grid.arrange(p11,p12,p13,nrow = 3)
# the demand we impose is much higher that historical trends for pakistan, order matches
# for india it might make sense, has to be quite lover after 2015 because the portion of india we consider is small
# crop do not match in term of importance, but could be that sugarcane are mostly grown in other parts or india
# similar for AFG, prevalent crop also match

## check imports/exports
impo_exp = read.csv( "input/land_maps_crop_yields/FAO_prices/FAOSTAT_IMPORT_EXPORT.csv", stringsAsFactors=FALSE ) %>%
  select(Country,Item,Element,Year,Unit,Value)

names(impo_exp) = tolower(names(impo_exp))

impo_exp = impo_exp %>% mutate(unit = 'kton') %>%
  mutate(element =  gsub(' .*','',element) ) %>%
  mutate(item =  gsub(' .*','',item) ) %>%
  mutate(item =  gsub(',','',item) ) %>%
  filter(year >= 1990)

p1 = ggplot(impo_exp %>% filter(item %in% c('Rice', 'Wheat')))+
  geom_line(aes(x = year,y = value,color = item, linetype = element),size = 1)+
  facet_wrap(~country)+
  scale_color_brewer(type = 'qual',palette = 2)+
  theme_bw()

p2 = ggplot(impo_exp %>% filter(!item %in% c('Rice', 'Wheat')))+
  geom_line(aes(x = year,y = value,color = item, linetype = element),size = 1)+
  facet_wrap(~country)+
  scale_color_brewer(type = 'qual',palette = 6)+
  theme_bw()

grid.arrange(p1,p2,nrow = 2)

## storage

level_dams = read.csv("P:/is-wel/indus/message_indus/input/storage/wapda_indus_reservoir_levels.csv")

# from GRanD_Technical_Documentation_v1_1, V[Mm3] = 0.678 * ( A[km2] * h[m] )^0.9229
# maximum volumes from WAPDA
monthly_level = rbind(data.frame(month = level_dams$`PERIOD DATE 2017-18`,
                                 DAM_NAME = c('Tarbela'),
                                 node = 'PAK_8',
                                 h_max = c(max(level_dams$TARBELA_LEVELS_FEET)),
                                 h_avg = c(level_dams$TARBELA_LEVELS_FEET)/mean(c(level_dams$TARBELA_LEVELS_FEET))*470,
                                 A_avg = (dam_capacity.spdf@data %>% filter(DAM_NAME == 'Tarbela') %>% select(AREA_REP))[,1],
                                 V_max = (dam_capacity.spdf@data %>% filter(DAM_NAME == 'Tarbela') %>% select(CAP_REP))[,1],
                                 stringsAsFactors = F),
                      data.frame(month = level_dams$`PERIOD DATE 2017-18`,
                                 DAM_NAME = c('Mangla'),
                                 node = 'PAK_1',
                                 h_max = c(max(level_dams$MANGLA_LEVELS_FEET)),
                                 h_avg = c(level_dams$MANGLA_LEVELS_FEET)/mean(c(level_dams$MANGLA_LEVELS_FEET))*490,
                                 A_avg = (dam_capacity.spdf@data %>%  filter(DAM_NAME == 'Mangla') %>%  select(AREA_REP))[,1],
                                 V_max = (dam_capacity.spdf@data %>%  filter(DAM_NAME == 'Mangla') %>%  select(CAP_REP))[,1],
                                 stringsAsFactors = F) ) %>%
  mutate(h_avg2 = h_avg *0.3048) %>%
  mutate(V_avg = 0.678 * ( A_avg * h_avg2 )^0.9229) %>%
  mutate(V_avg2 = 30.684 * ( A_avg)^0.9578) %>%
  mutate(month = gsub('.*-','',month))

map_months = data.frame(month = c('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'),
                        time = seq(1,12,1) ,stringsAsFactors = F)

monthly_lvl_agg = monthly_level %>%
  left_join(map_months) %>% ungroup() %>%
  group_by(time,DAM_NAME,node) %>%
  summarise(h_avg2 = mean(h_avg2),V_max = mean(V_max),V_avg = mean(V_avg)) %>% ungroup() %>%
  group_by(DAM_NAME) %>% mutate(V_avg = V_avg - (max(V_avg) - V_max)) %>% ungroup()

ggplot(data = monthly_lvl_agg)+
  geom_line(aes(time,V_avg))+
  geom_line(aes(time,V_max),color = 'red',linetype="dashed")+
  facet_wrap(~DAM_NAME)+ylab('Mm^3')+xlab('month')+
  scale_x_continuous(expand = c(0,0),breaks=seq(1,12,1))+
  theme_bw()


subroutine swap(j,k1,k2,shdswp,nadj,madj,x,y,ntot,eps,nerror)

# The segment k1->k2 is a diagonal of a quadrilateral
# with a vertex at j (the point being added to the
# triangulation).  If the LOP is not satisfied, swap
# it for the other diagonal.
# Called by addpt.

implicit double precision(a-h,o-z)
dimension nadj(-3:ntot,0:madj), x(-3:ntot), y(-3:ntot)
dimension ntadj(1000)
logical shdswp, anticl

# If vertices k1 and k2 are not connected there is no diagonal to swap.
# This could happen if vertices j, k1, and k2 were colinear, but shouldn't.
call adjchk(k1,k2,shdswp,nadj,madj,ntot,nerror)
if(nerror > 0) {
    return
}
if(!shdswp) return

# Get the other vertex of the quadrilateral.
call pred(k,k1,k2,nadj,madj,ntot,nerror) # If these aren't the same, then
if(nerror > 0) return
call succ(kk,k2,k1,nadj,madj,ntot,nerror) # there is no other vertex.
if(nerror > 0) return
if(kk!=k) {
#    if(j==580) call intpr("no other vertex",-1,1,0)
        shdswp = .false.
        return
}

# Check whether the LOP is satisified; i.e. whether
# vertex k is outside the circumcircle of vertices j, k1, and k2
if(k==580) {
    call intpr("From swap; point being added =",-1,j,1)
# Adj. list of k1 ("now").
    nk1 = nadj(k1,0)
    do jc = 1,nk1 {
            ntadj(jc) = nadj(k1,jc)
    }
    call intpr("now =",-1,k1,1)
    call intpr("adjacency list of now:",-1,ntadj,nk1)
# Adj. list of k1 ("now").
    nk2 = nadj(k2,0)
    do jc = 1,nk2 {
            ntadj(jc) = nadj(k2,jc)
    }
    call intpr("nxt =",-1,k2,1)
    call intpr("adjacency list of nxt:",-1,ntadj,nk2)
# Adj. list of j ("point being added").
    nj = nadj(j,0)
    do jc = 1,nj {
            ntadj(jc) = nadj(j,jc)
    }
    call intpr("point being added =",-1,j,1)
    call intpr("adjacency list of point being added:",-1,ntadj,nj)
# j, now, nxt should be in anticlockwise order.
    call acchk(j,k1,k2,anticl,x,y,ntot,eps)
    if(anticl) {
        call intpr("anticlockwise",-1,1,0)
    } else {
        call intpr("clockwise",-1,1,0)
    }
#
# i = now = k1, k = nxt = k2, and j = other vertex = k:
}
call qtest(j,k1,k,k2,shdswp,x,y,ntot,eps,nerror)
if(nerror > 0) return

# Do the actual swapping.
if(shdswp) {
        call delet(k1,k2,nadj,madj,ntot,nerror)
	if(nerror > 0) return
	call insrt(j,k,nadj,madj,x,y,ntot,nerror,eps)
	if(nerror > 0) return
}
return
end


require(ggplot2)
require(xtable)

#Arbeitspfad setzen
setwd("/Volumes/cracker/data/nfs/thomas/experiments/noise-31.05.2011-nosynch-noise4-cca62-ofdmweak1-ch6/data/merged-trace/aggregation")

hft_ewma <- read.csv(file="hft-60-sec-ewma.csv", header=FALSE, sep = ",")
hft_histogram <- read.csv(file="hft-24h-histogram.csv", header=FALSE, sep = ",")
ma_histogram <- read.csv(file="ma-24h-histogram.csv", header=FALSE, sep = ",")
eb_histogram <- read.csv(file="eb-24h-histogram.csv", header=FALSE, sep = ",")
histo <- list(hft_histogram, ma_histogram, eb_histogram)

hft_register <- read.csv(file="hft-10-sec-aggregation.csv", header=TRUE, sep = ",")
ma_register <- read.csv(file="ma-10-sec-aggregation.csv", header=TRUE, sep = ",")
eb_register <- read.csv(file="eb-10-sec-aggregation.csv", header=TRUE, sep = ",")
tc_register <- read.csv(file="tc-10-sec-aggregation.csv", header=TRUE, sep = ",")
c_register <- read.csv(file="c-10-sec-aggregation.csv", header=TRUE, sep = ",")
en_register <- read.csv(file="en-10-sec-aggregation.csv", header=TRUE, sep = ",")
a_register <- read.csv(file="a-10-sec-aggregation.csv", header=TRUE, sep = ",")
af_register <- read.csv(file="af-10-sec-aggregation.csv", header=TRUE, sep = ",")
vws_register <- read.csv(file="vws-10-sec-aggregation.csv", header=TRUE, sep = ",")

#histogram
 ggplot(hft_histogram, aes(x = as.factor(V1), y=V2)) + geom_histogram(binwidth=1)
ggplot(hft_histogram, aes(x = as.factor(V1), y = V2)) + geom_histogram(binwidth=1) + scale_y_log10

m <- ggplot(hft_histogram)
m + geom_histogram(aes(x = V1, weight=V2), colour = "darkgreen", fill = "white", binwidth=1)
m + geom_density(aes(x=V1, y=..density..),binwidth=1) + ylim(0,1)

#good histogram
ggplot(hft_histogram, aes(x = V1, weight=V2/sum(V2))) + stat_bin(aes(y=..density..),binwidth=1)
ggplot(hft_histogram, aes(x = V1, weight=V2/sum(V2))) +
  geom_histogram(aes(y = ..density..), colour = "darkgreen", fill = "darkgray",binwidth=1) +
  geom_density(colour = "red")

#density plot for single node
m <- ggplot(hft_histogram) +
      geom_histogram(aes(x = V1, weight = V2/sum(V2), y = ..density..), colour = "darkgreen", fill = "darkgray",binwidth=1) +
      geom_density(aes(x = V1, weight = V2/sum(V2), y = ..density..), binwidth=1, colour="darkred") +
      ylim(0,0.5) + xlim(-100,-60) +
      labs(x = "noise in dB", y = "density") +
      opts(legend.position="none") +
      opts(title ="Noise densities from a kernel density estimator")
m

df <- data.frame(x = rnorm(10, 0, 1), y = rnorm(10, 0, 2), z = rnorm(10, 2, 1.5))
df.m <- melt(df)

ggplot() +
layer(
 data = hft_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color="skyblue"
) +
layer(
 data = ma_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "coral"
) +
layer(
 data = eb_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "cyan"
) +
layer(
 data = tc_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "darkblue"
) +
layer(
 data = c_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "darkgreen"
) +
layer(
 data = en_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "brown"
)+
layer(
 data = a_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "blueviolet"
) +
layer(
 data = af_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "line", stat = "smooth", color = "aquamarine"
) +
layer(
 data = vws_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "darkgoldenrod1"
)

#boxplots over time
ggplot(data = af_register) +
  layer(mapping = aes(x = timestamp/3600, y = mean[mean >-110] ),
        stat = "smooth", colour="blue") +
  layer(mapping = aes(x = timestamp/3600, y = mean[mean >-110], group = round_any(timestamp, 3600, floor)),
        geom = "boxplot", alpha = 0.3 ) +
  layer(mapping = aes(x = timestamp/3600, y = max[max >-110]),
        geom = "line", stat = "smooth", color="red", alpha = 0.5) +
  layer(mapping = aes(x = timestamp/3600, y = min[min >-110]),
        geom = "smooth", color="green", alpha = 0.5) +
    scale_y_continuous(breaks = seq(-120, -60, by = 10)) +
    scale_x_continuous(breaks = c(1,3,5,7,9,11,13,15,17,19,21,23),
      labels=c("24:00", "2:00", "4:00", "6:00", "8:00", "10:00", "12:00", "14:00", "16:00", "18:00", "20:00", "22:00")) +
    coord_cartesian(ylim = c(-105,-80), xlim = c(0,24)) +
      labs(x = "hour of the day [hh:mm]",
           y = "noisefloor [dB]") +
        opts(axis.text.y = theme_text(hjust = 1, size = 10, colour = "black"),
              axis.text.x = theme_text(hjust = 0.5, size = 10, colour = "black"),
              axis.title.y = theme_text(angle = 90, vjust = 0.2, hjust = 0.5, size = 17, colour = "black"),
              axis.title.x = theme_text(vjust = 0.2, hjust = 0.5, size = 17, colour = "black"),
              #legend.position="none",
              title ="Noisefloor distribution over 24h",
              plot.title=theme_text(colour="black", size=20, vjust = 1.5, hjust = 0.5),
              strip.text.x = theme_text(size=12, face='bold'),
              strip.background = theme_rect(colour='darkgray', fill='lightgray'))

+
      facet_wrap(~ node, ncol=3, scales = "free_y")

m <- ggplot(data = af_register, aes(x = timestamp/3600, y = mean[mean >-110]))
m + geom_smooth(stat="identity")
m + stat_smooth() + geom_point(alpha=I(0.2))

#test
af_register$disp_mean <- round_any(af_register$mean, 1800, ceiling)
p <- ggplot(data = af_register, mapping = aes(x = timestamp, y = mean[mean >-110] ), geom = "line", colour="red")
p  + facet_wrap(. ~ af_register$disp_mean, nrow = 1)

ggplot() +
layer(
 data = af_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "point", stat = "identity", alpha = 0.1
) +
layer(
 data = af_register, mapping = aes(x = timestamp, y = mean[mean >-110] ),
 geom = "smooth", stat = "smooth", color = "yellow"
) +
layer(
 data = af_register, mapping = aes(x = timestamp, y = max[max >-110]),
 geom = "line", stat = "identity", color="red", alpha = 0.1
) +
layer(
 data = af_register, mapping = aes(x = timestamp[min >-110], y = min[min >-110]),
 geom = "line", stat = "identity", color="green", alpha = 0.1
) +
layer(data = ma_register, mapping = aes(x = timestamp, y = std - 110),
 geom = "line", stat = "identity", color="blue"
)


#!/usr/bin/env Rscript

cargs = commandArgs(trailingOnly=TRUE)

infile = cargs[1]
outfile = cargs[2]

x = read.table(infile)
x[, 6] = x[sample(1:nrow(x), nrow(x), FALSE), 6]

write.table(x, outfile, sep=' ', col.names=FALSE, row.names=FALSE,
            quote=FALSE)


import_package('igraph', attach=TRUE)
b = import('base')
io = import('io')
aracne = import('.')

INFILE = commandArgs(TRUE)[1] %or% "../data/expr/LUAD/cancer.RData"
OUTFILE = commandArgs(TRUE)[2] %or% "aracne/LUAD/cancer.RData"

expr = io$load(INFILE)
tfs = io$read_table('./tfs.txt', header=FALSE)

net = aracne$aracne(mat = expr, tfs = tfs)

g = graph_from_data_frame(net, directed=FALSE)

g = set_vertex_attr(g, "tf", index=V(g), value=V(g)$name %in% tfs)

dg = decompose.graph(g)
if (length(dg) > 1) {
    warning("Graph is not connected, using only first component")
    message("Component size: ", paste(sapply(dg, function(x)
            length(V(x))), collapse=", "))

    g = dg[[1]]
}

save(g, file=OUTFILE)


model.matrix.ivmodel <- function(object, ...){
  ivmodel <- object

  if(is.null(dim(ivmodel$X))) {
    return(ivmodel$D)
  } else {
    intVector = rep(1,nrow(ivmodel$X))
    whichIntIndex = NA
    for(i in ncol(ivmodel$X)) {
      if(all(ivmodel$X[,i] == intVector)) {
        whichIntIndex = i
        break
      }
    }
    if(is.na(whichIntIndex)) {
      return(cbind(ivmodel$D,ivmodel$X))
    } else {
      if(ncol(ivmodel$X) == 1) {
        matOut = cbind(1,ivmodel$D)
        colnames(matOut)[1] = "(Intercept)"
      } else {
        matOut = cbind(1,ivmodel$D,ivmodel$X[,-whichIntIndex])
        colnames(matOut)[1] = "(Intercept)"
      }
      return(matOut)
    }
  }
}


################################################################
## Title: Data Science For Database Professionals
## Description: Data Preparation
## 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)

####################################################################################################
##Method 1: Prepare the raw, training and testing data sets all in SQL database
####################################################################################################
col_info <- list(age = list(type = "integer"),
                annualincome = list(type = "integer"),
                calldroprate = list(type = "numeric"),
                callfailurerate = list(type = "numeric"),
                callingnum = list(type = "numeric"),
                customerid = list(type = "integer"),
                customersuspended = list(type = "factor", levels = c("No", "Yes")),
                education = list(type = "factor", levels = c("Bachelor or equivalent", "High School or below", "Master or equivalent", "PhD or equivalent")),
                gender = list(type = "factor", levels = c("Female", "Male")),
                homeowner = list(type = "factor", levels = c("No", "Yes")),
                maritalstatus = list(type = "factor", levels = c("Married", "Single")),
                monthlybilledamount = list(type = "integer"),
                noadditionallines = list(type = "factor", levels = c("\\N")),
                numberofcomplaints = list(type = "factor", levels = as.character(0:3)),
                numberofmonthunpaid = list(type = "factor", levels = as.character(0:7)),
                numdayscontractequipmentplanexpiring = list(type = "integer"),
                occupation = list(type = "factor", levels = c("Non-technology Related Job", "Others", "Technology Related Job")),
                penaltytoswitch = list(type = "integer"),
                state = list(type = "factor"),
                totalminsusedinlastmonth = list(type = "integer"),
                unpaidbalance = list(type = "integer"),
                usesinternetservice = list(type = "factor", levels = c("No", "Yes")),
                usesvoiceservice = list(type = "factor", levels = c("No", "Yes")),
                percentagecalloutsidenetwork = list(type = "numeric"),
                totalcallduration = list(type = "integer"),
                avgcallduration = list(type = "integer"),
                churn = list(type = "factor", levels = as.character(0:1)),
                year = list(type = "factor", levels = as.character(2015)),
                month = list(type = "factor", levels = as.character(1:3)))

myDataTb <- RxSqlServerData(
  connectionString = connection_string,
  table = "edw_cdr",
  colInfo = col_info)
rxDataStep(inData = myDataTb, outFile = myDataTb, overwrite = TRUE)

trainDataTb <- RxSqlServerData(
    connectionString = connection_string,
    table = "edw_cdr_train",
    colInfo = col_info)
rxDataStep(inData = trainDataTb, outFile = trainDataTb, overwrite = TRUE)

testDataTb <- RxSqlServerData(
    connectionString = connection_string,
    table = "edw_cdr_test",
    colInfo = col_info)
rxDataStep(inData = testDataTb, outFile = testDataTb, overwrite = TRUE)

####################################################################################################
##Method 2: Prepare the training and testing data sets by feature engineering and spliting on raw data
####################################################################################################
rxSetComputeContext(local)

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

####################################################################################################
## Project Columns-exclude columns: year and month
## Metadata Editor-change column headers (no difference with original headers)
## Metadata Editor-change column types
####################################################################################################
rxSetComputeContext(local)
myVars <- rxGetVarNames(myDataTb)
myVars <- myVars[!myVars %in% c("year", "month")]
myVars <- paste(myVars, collapse = ", ")
sql_query <- paste("select", myVars, "from edw_cdr")
col_info <- list(age = list(type = "integer"),
                annualincome = list(type = "integer"),
                calldroprate = list(type = "numeric"),
                callfailurerate = list(type = "numeric"),
                callingnum = list(type = "numeric"),
                customerid = list(type = "integer"),
                customersuspended = list(type = "factor", levels = c("No", "Yes")),
                education = list(type = "factor", levels = c("Bachelor or equivalent", "High School or below", "Master or equivalent", "PhD or equivalent")),
                gender = list(type = "factor", levels = c("Female", "Male")),
                homeowner = list(type = "factor", levels = c("No", "Yes")),
                maritalstatus = list(type = "factor", levels = c("Married", "Single")),
                monthlybilledamount = list(type = "integer"),
                noadditionallines = list(type = "factor", levels = c("\\N")),
                numberofcomplaints = list(type = "integer"),
                numberofmonthunpaid = list(type = "integer"),
                numdayscontractequipmentplanexpiring = list(type = "integer"),
                occupation = list(type = "factor", levels = c("Non-technology Related Job", "Others", "Technology Related Job")),
                penaltytoswitch = list(type = "integer"),
                state = list(type = "factor"),
                totalminsusedinlastmonth = list(type = "integer"),
                unpaidbalance = list(type = "integer"),
                usesinternetservice = list(type = "factor", levels = c("No", "Yes")),
                usesvoiceservice = list(type = "factor", levels = c("No", "Yes")),
                percentagecalloutsidenetwork = list(type = "numeric"),
                totalcallduration = list(type = "integer"),
                avgcallduration = list(type = "integer"),
                churn = list(type = "factor", levels = c("1", "0")))

projectedMetaedData <- RxSqlServerData(sqlQuery = sql_query,
                               connectionString = connection_string,
                               colInfo = col_info)
rxGetInfo(projectedMetaedData, getVarInfo = T, numRows = 3)

####################################################################################################
## Clean Missing Data (no missing)
## Remove Duplicate Rows
####################################################################################################
cleanedData <- rxDataStep(inData = projectedMetaedData,
                              removeMissings = TRUE,
                              overwrite = TRUE)

rxGetInfo(cleanedData, getVarInfo = T)

cleanedUnduplicatedData <- cleanedData[!duplicated(cleanedData),]

rxGetInfo(cleanedUnduplicatedData, getVarInfo = T)

####################################################################################################
## Split Data
####################################################################################################
set.seed(1234)
splitFiles <- rxSplit(inData = cleanedUnduplicatedData,
                       outFilesBase = "trainTestData",
                       splitByFactor = "ind",
                       transforms = list(ind = factor(
                         sample(0:1, size = .rxNumRows, replace = TRUE, prob = c(0.3, 0.7)),
                         levels = 0:1, labels = c("Test", "Train"))),
                        overwrite = TRUE)
names(splitFiles)
trainFile <- splitFiles[[2]]
testFile <- splitFiles[[1]]
rxGetInfo(trainFile)$numRows
rxGetInfo(testFile)$numRows
rxGetVarInfo(trainFile)

####################################################################################################
## SMOTE on training data (using OSR)
####################################################################################################
trainData <- rxXdfToDataFrame(file = trainFile, varsToDrop = c("ind"))
testData <- rxXdfToDataFrame(file = testFile, varsToDrop = c("ind"))
table(trainData$churn)
table(testData$churn)

library(unbalanced)
myvars <- names(trainData) %in% c("churn")
SMOTEData <- ubSMOTE(X = trainData[!myvars], Y = trainData$churn, perc.over = 200, k = 3, perc.under = 500, verbose = TRUE)
newSMOTEData <- cbind(SMOTEData$X, SMOTEData$Y)
colnames(newSMOTEData)
names(newSMOTEData)[names(newSMOTEData) == "SMOTEData$Y"] <- "churn"
colnames(newSMOTEData)
trainData <- newSMOTEData
table(trainData$churn)

####################################################################################################
## Load final training data frame and test data frame into SQL
####################################################################################################
rxSetComputeContext(local)

trainDataTb <- RxSqlServerData(
  connectionString = connection_string,
  table = "edw_cdr_train",
  colInfo = col_info)
testDataTb <- RxSqlServerData(
  connectionString = connection_string,
  table = "edw_cdr_test",
  colInfo = col_info)
rxDataStep(inData = trainData, outFile = trainDataTb, overwrite = TRUE)
rxDataStep(inData = testData, outFile = testDataTb, overwrite = TRUE)
rxGetInfo(trainDataTb, getVarInfo = T, numRows = 3)
rxGetInfo(testDataTb, getVarInfo = T, numRows = 3)
rxSummary( ~ churn, data = trainDataTb)
rxSummary( ~ churn, data = testDataTb)


#' @title fm.m
#' @description fathoms to m
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
fm.m<-function(x) {
	m <- x*(6*12*2.54)/100
	return(m)
}


check_equal_length <- function(actual, predicted) {

    if (length(actual) != length(predicted)) {
        stop("`actual` and `predicted` must have equal length.", call. = FALSE)
    }

    invisible()
}

check_cutoff_range <- function(cutoff) {

    if (cutoff > 1 || cutoff < 0) {
        stop("`cutoff` values must be in range of [0,1].", call. = FALSE)
    }

    invisible()
}

check_binary <- function(actual) {

    if (!all(actual %in% c(0, 1))) {
        stop("`actual` only supports binary values: 0 & 1.", call. = FALSE)
    }

    invisible()
}

clip <- function(x, mi, ma) {
    clip_(x, mi, ma)
}

map_dbl <- function(.x, .f, ...) {
    vapply(X = .x, FUN = .f, FUN.VALUE = double(1), USE.NAMES = FALSE, ...)
}

## Trapezoidal rule
## https://en.wikipedia.org/wiki/Trapezoidal_rule
##' @importFrom stats complete.cases
trapezoid <- function(x, y) {
    ## assumes x is a partition and that x & y are the same length

    if (anyNA(x) || anyNA(y)) {
        comp <- complete.cases(x, y)
        x <- x[comp]
        y <- y[comp]
    }

    x_ord <- order(x)
    x <- x[x_ord]
    y <- y[x_ord]

    ## dx
    dx <- diff(x)
    ## mid height of y
    height <- (y[-1] + y[-length(y)]) / 2

    sum(dx * height)
}


#Code that makes boxplots of observed-to-expected neoantigen ratio by fraction and subtype
#Did not make it into the original manuscript, have not thoroughly reviewed this code
#May be useful as an Extended Data Figure down the road
#-----------------------------------------------------

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

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

q <- "SELECT gs.tumor_pair_barcode, nd.fraction, nd.rneo, clin.idh_codel_subtype AS subtype,
CASE WHEN mf.coverage_adj_mut_freq >= 10 THEN 1 WHEN mf.coverage_adj_mut_freq < 10 THEN 0 END AS hm_rec
FROM analysis.gold_set gs
INNER JOIN analysis.neoantigen_depletion_fraction nd ON gs.tumor_pair_barcode = nd.tumor_pair_barcode
LEFT JOIN analysis.mut_freq mf ON mf.aliquot_barcode = gs.tumor_barcode_b
LEFT JOIN clinical.subtypes clin ON clin.case_barcode = gs.case_barcode
WHERE rneo IS NOT NULL
ORDER BY nd.rneo DESC"

res <- dbGetQuery(con, q)

myp <- mye <- rep(0,12)

g1 <- res[which(res[,"fraction"]=="P"),"rneo"]
g2 <- res[which(res[,"fraction"]=="R"),"rneo"]
g3 <- res[which(res[,"fraction"]=="S"),"rneo"]

myp[1] <- wilcox.test(g1, mu=1)$p.value
myp[2] <- wilcox.test(g2, mu=1)$p.value
myp[3] <- wilcox.test(g3, mu=1)$p.value

mye[1] <- median(g1)
mye[2] <- median(g2)
mye[3] <- median(g3)

subtypes <- unique(res[,"subtype"])
mysub <- c(rep("all",3),rep(subtypes,each=3))
myfrac <- rep(c("P","R","S"),4)
for(i in 1:length(subtypes))
{
	subres <- res[which(res[,"subtype"]==subtypes[i]),]
	g1 <- subres[which(subres[,"fraction"]=="P"),"rneo"]
	g2 <- subres[which(subres[,"fraction"]=="R"),"rneo"]
	g3 <- subres[which(subres[,"fraction"]=="S"),"rneo"]

	myp[(i*3)+1] <- wilcox.test(g1, mu=1)$p.value
	myp[(i*3)+2] <- wilcox.test(g2, mu=1)$p.value
	myp[(i*3)+3] <- wilcox.test(g3, mu=1)$p.value

	mye[(i*3)+1] <- median(g1)
	mye[(i*3)+2] <- median(g2)
	mye[(i*3)+3] <- median(g3)
}
substats <- data.frame(mysub,myfrac,myp,mye)

pdf("/projects/varnf/GLASS/Figures/resubmission/depletion_subtype_fraction.pdf",width=3.5,height=2)
ggplot(res, aes(y = rneo, x = fraction, fill=fraction)) +
	geom_hline(yintercept=1, color = "gray50", size=1) +
	geom_boxplot(lwd=0.5,outlier.size=0.1,fatten=2) +
	labs(y="observed/expected neoantigens") +
	scale_fill_manual(values=c("#CA2F66","#2FB3CA","#CA932F")) +
	facet_grid(~subtype, scales = "free") +
	theme_classic() +
	theme(strip.text.x = element_text(size=8),strip.background = element_blank(),
	axis.title.y=element_text(size=8),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=8), axis.text.x=element_text(hjust=0.5,size=8),
	legend.position="none")
dev.off()

hm <- unique(res[,"hm_rec"])
myhm <- c(rep(0,3),rep(1,3))
myfrac <- rep(c("P","R","S"),2)
myp <- mye <- rep(0,6)
for(i in 1:length(hm))
{
	hmres <- res[which(res[,"hm_rec"]==hm[i]),]
	g1 <- res[which(res[,"fraction"]=="P"),"rneo"]
	g2 <- res[which(res[,"fraction"]=="R"),"rneo"]
	g3 <- res[which(res[,"fraction"]=="S"),"rneo"]

	myp[((i-1)*3)+1] <- wilcox.test(g1, mu=1)$p.value
	myp[((i-1)*3)+2] <- wilcox.test(g2, mu=1)$p.value
	myp[((i-1)*3)+3] <- wilcox.test(g3, mu=1)$p.value

	mye[((i-1)*3)+1] <- median(g1)
	mye[((i-1)*3)+2] <- median(g2)
	mye[((i-1)*3)+3] <- median(g3)
}
hmstats <- data.frame(myhm,myfrac,myp,mye)

pdf("/projects/varnf/GLASS/Figures/resubmission/depletion_hypermutation_fraction.pdf",width=2.45,height=2)
ggplot(res, aes(y = rneo, x = fraction, fill=fraction)) +
	geom_hline(yintercept=1, color = "gray50", size=1) +
	geom_boxplot(lwd=0.5,outlier.size=0.1,fatten=2) +
	labs(y="observed/expected neoantigens") +
	scale_fill_manual(values=c("#CA2F66","#2FB3CA","#CA932F")) +
	facet_grid(~hm_rec, scales = "free") +
	theme_classic() +
	theme(strip.text.x = element_text(size=8),strip.background = element_blank(),
	axis.title.y=element_text(size=8),axis.title.x=element_blank(),
	axis.text=element_text(colour="black",size=8), axis.text.x=element_text(hjust=0.5,size=8),
	legend.position="none")
dev.off()