#' @title hist_bivariate
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
hist_bivariate = function(x,y, method="fd", xrange=NULL, yrange=NULL) {

  xhist <- hist(x, plot=F, method )
  yhist <- hist(y, plot=F, method )

  layout(mat=matrix(c(2,0,1,3),2,2,byrow=TRUE), widths=c(3,1), heights=c(1,3), respect=TRUE)

  if (is.null(xrange)) xrange <- range(x, na.rm=T)
  if (is.null(yrange)) yrange <- range(y, na.rm=T)

  plot(x, y, xlim=xrange, ylim=yrange, xlab="", ylab="", axes=F)
  axis(1)
  axis(2)

  par(mar=c(0,3.5,3.5,1))
  barplot(xhist$counts, axes=F, space=0)

  par(mar=c(5,0,5,1))
  barplot(yhist$counts, axes=F, space=0, horiz=TRUE)
  return(NULL)
}


# Seurat v2
for(j in 0:8){
n=table(pbmc_c@ident)
ident=j
n[names(n) %in% c(0:ident)]=0
n=n[-1]
o=n[n>0]
ident2=names(o[1])
bim <- FindMarkers(pbmc_c, ident.1 = ident,  ident.2 =ident2, only.pos = F, test.use = "bimod")
deg=bim[bim$p_val_adj < 0.01,]
deg1=deg[abs(deg$avg_logFC) >= 1,]
degs=dim(deg)
degs1=dim(deg1)

for(i in c(names(o[-1]))){
bim <- FindMarkers(pbmc_c, ident.1 = ident,  ident.2 = i, only.pos = F, test.use = "bimod")
 deg=bim[bim$p_val_adj < 0.01,]
deg1=deg[abs(deg$avg_logFC) >= 1,]
degs=cbind(degs,dim(deg))
degs1=cbind(degs1,dim(deg1))
}
print(degs1)
}

#Seurat v3
compareClusters<-function(obj){
  len<-length(levels(Idents(obj)))
  for(j in 0:len){
    n=table(Idents(obj))
    ident=j
    n[names(n) %in% c(0:ident)]=0
    n=n[-1]
    o=n[n>0]
    ident2=names(o[1])
    bim <- FindMarkers(obj, ident.1 = ident,  ident.2 =ident2, only.pos = F, test.use = "bimod")
    deg=bim[bim$p_val_adj < 0.01,]
    deg1=deg[abs(deg$avg_logFC) >= 1,]
    degs=dim(deg)
    degs1=dim(deg1)

    for(i in c(names(o[-1]))){
      bim <- FindMarkers(obj, ident.1 = ident,  ident.2 = i, only.pos = F, test.use = "bimod")
       deg=bim[bim$p_val_adj < 0.01,]
      deg1=deg[abs(deg$avg_logFC) >= 1,]
      degs=cbind(degs,dim(deg))
      degs1=cbind(degs1,dim(deg1))
    }
    print(degs1)
  }
}


#################################################################################################################################
#                                            Aportion pop to catchments using huff probs                                        #
#################################################################################################################################

library(data.table)

pop_dz15 <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_dz/dz_pop_15.csv")
setnames(pop_dz15, "dz11", "lsoa11")
pop_lsoa15 <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_lsoa/pop_lsoa_15.csv")
pop_msoa15 <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_msoa/msoa_pop_15.csv")

lsoa_probs <- fread("~/Dropbox/liverpool/retail_typology/data/lsoa_probs.csv")
msoa_probs <- fread("~/Dropbox/liverpool/retail_typology/data/msoa_probs.csv")

pop_lsoa15_probs <- pop_lsoa15[lsoa_probs, on = "lsoa11", nomatch = 0]
pop_lsoa15_probs[, weighted_pop := total_pop * mean_huff_prob]

pop_msoa15_probs <- pop_msoa15[msoa_probs, on = "msoa11", nomatch = 0]
pop_msoa15_probs[, weighted_pop := total_pop * mean_huff_prob]

pop_dz15_probs <- pop_dz15[lsoa_probs, on = "lsoa11", nomatch = 0]
pop_dz15_probs[, weighted_pop := total_pop * mean_huff_prob]

fwrite(pop_dz15_probs, "~/Dropbox/liverpool/retail_typology/data/pop_est/pop_dz15_probs.csv")
fwrite(pop_lsoa15_probs, "~/Dropbox/liverpool/retail_typology/data/pop_est/pop_lsoa15_probs.csv")
fwrite(pop_msoa15_probs, "~/Dropbox/liverpool/retail_typology/data/pop_est/pop_msoa15_probs.csv")


REBOL [
    Title: "Get-img-alpha-bounds"
    Date: 30-Nov-2010/10:51:04+1:00
    Author: "Oldes"
	purpose: {finds the smallest area which contains alpha information (not transparent)}
]
get-img-alpha-bounds: func[
	{Returns the smallest area which contains alpha information (not transparent)
	 in format [ofsx ofsy width height]}
	img [image!] "Image to examine"
	/local h w h- w- c r p vertical-b horizontal-b
][
	h: img/size/y
	w: img/size/x
	w-: w - 1
	h-: h - 1
	horizontal-b: copy []
	c: 0
	parse/all/case img/alpha [
		w [
			p: [
				h- [#{FF} w- skip] #{FF} (c: c + 1) [end | (p: next p) :p]
				|
				(
					either c > 0 [
						append horizontal-b c
						c: 0
					][	if empty? horizontal-b [insert horizontal-b 0] ]
					p: next p
				) :p
			]
		]
		(
			if c > 0 [append horizontal-b c]
			if 2 > length? horizontal-b [append horizontal-b 0]
		) to end
	]
	vertical-b: copy []
	r: 0
	parse/all/case img/alpha [
		h [
			[
				w #{FF} (r: r + 1)
				|
				w skip  (
					either r > 0 [
						append vertical-b r
						r: 0
					][	if empty? vertical-b [insert vertical-b 0] ]
				)
			]
		]
		(
			if r > 0 [append vertical-b r]
			if 2 > length? vertical-b [append vertical-b 0]
		)
	]
	;probe vertical-b
	;probe horizontal-b
	reduce [
		first horizontal-b
		first vertical-b
		img/size/x - (first horizontal-b) - (last horizontal-b)
		img/size/y - (first vertical-b)   - (last vertical-b)
	]
]


#===============================================================================
#	cv.best.models.r
#
#	Auther: Michio Oguro
#
#	Description:
#		Extract model(s) with best predictive ability from cv.models object.
#===============================================================================

#-------------------------------------------------------------------------------
#'	(Internal) Find the Index of Best Metrics
#'
#'	This function find the index of metrics indicating best predictive ability.
#'
#'	@param metrics
#'		a matrics of model performance metrics.
#-------------------------------------------------------------------------------
find.best.metrics.index <- function(metrics) {
	minimize <- c("mse", "rmse", "fn", "fp")
	for (i in colnames(metrics)) {
		if (i %in% minimize) {
			metrics[[i]] <- -metrics[[i]]
		}
	}
	return(which.max.multi(metrics))
}

#-------------------------------------------------------------------------------
#'	Extract a Model from cv.models Object
#'
#'	Extract a model from \code{\link{cv.models}} object having multiple models
#'	created by hyper-parameter selection.
#'
#'	@param object a \code{cv.models} object.
#'	@param index model index.
#'	@param criteria reserved, but currently not used.
#'	@export
#-------------------------------------------------------------------------------
extract.result <- function(object, index, criteria = NULL) {
	# Fix random number before using random process.
	set.seed.if.possible(object)
	best <- object
	best$grid <- NULL
	best$grid.predict <- NULL
	best$metrics <- best$cv.results[[index]]$metrics
	best$criteria <- criteria
	best$call <- best$cv.results[[index]]$call
	best$fits <- best$cv.results[[index]]$fits
	best$cv.group <- best$cv.results[[index]]$cv.group
	best$model <- eval(best$call, envir = best$envir)
	best$cv.results <- NULL
	class(best) <- "cv.result"
	return(best)
}

#-------------------------------------------------------------------------------
#'	Find best performing model(s)
#'
#'	Find model(s) with best performance.
#'	The result can have multiple models if there are ties.
#'
#'	@param object
#'	a \code{cv.models} object.
#'
#'	@param criteria
#'	names of performance measures by which best model(s) are determined.
#'
#'	@export
#-------------------------------------------------------------------------------
find.best.models <- function(object, criteria) {
	if (missing(criteria)) {
		criteria <- ifelse(
			object$adapter$model.type == "regression", "q.squared", "mcc"
		)
	}
	if (is.null(object$grid) & is.null(object$grid.predict)) {
		best.index <- 1
	} else {
		metrics <- extract.metrics(object)[criteria]
		best.index <- find.best.metrics.index(metrics)
	}
	result <- lapply(
		best.index, extract.result, object = object, criteria = criteria
	)
	class(result) <- "cv.best.models"
	return(result)
}


args = commandArgs()
range=strsplit(basename(args[3]), ".", fixed=TRUE)[[1]][1]
outpdf = paste("./plots/extendtimes", range, ".pdf", sep="")

e <- read.table(args[3])
pdf(outpdf, width=8, height=6)
plot(density(e[,2] + e[,3] + e[,4]), ylim=c(0,0.8), xlim=c(0,10), frame=FALSE,
axes=FALSE, main="Circuit extension time", xlab="Time [s]")
axis(1, at=0:10)
axis(2)
lines(density(e[,2]), col="red")
lines(density(e[,3]), col="darkgreen")
lines(density(e[,4]), col="blue")
text(x=1.1, y=0.7, labels="1st hop", col="red")
text(x=2.65, y=0.55, labels="2nd hop", col="darkgreen")
text(x=3.68, y=0.27, labels="3rd hop", col="blue")
text(x=5.9, y=0.13, labels="All hops")
abline(v=1:10, lty=3)
dev.off()


library(ggplot2)
library(reshape2)

args <- commandArgs(TRUE)

file <- args[1]
out.plot <- args[2]
col.rank <- as.numeric(args[3])
sig.value <- as.numeric(args[4])

limit <- 5
# top.pct <- 5

data <- read.delim(file,header=T)

if(limit > max(data[,col.rank])){
  limit <- max(data[,col.rank])
}
#sig.value <- as.numeric(quantile(data[,col.rank],prob=1-top.pct/100))
#limit <- max(data[,col.rank])

data$sig <- "NA"
data[data[,col.rank] >= sig.value,]$sig <- "top"
data$sig <- as.factor(data$sig)
data$mask <- data[,col.rank]
data[data[,col.rank] >= sig.value,]$mask <- sig.value
data[data[,col.rank] < sig.value,col.rank] <- NA

data$chr <- as.factor(gsub("Chr","",data[,1]))
chrs <- as.character(sort(as.numeric(levels(data$chr))))
data$chr <- factor(data$chr, levels=chrs)

# 设置染色体长度、数量、中位断点（breakpoint）作为x轴的tick
chrcount <- length(chrs)
breakpoints <- levels(data$chr)

# 设置新坐标（累加坐标）
data$POS <- data[,2]
genome.len <- 0

# 循环计算，获取每一条染色体的长度、中间点，同时计算累加坐标
for(i in 1:chrcount){
  chrname <- chrs[i]
  chrlen <- max(data[data$chr==chrname,2])
  breakpoints[i] <- chrlen/2 + genome.len
  data[data$chr==chrname,]$POS <- data[data$chr==chrname,2] + genome.len
  genome.len <- genome.len + chrlen
}

# 设置染色体颜色，需要两套颜色，分别是染色体区分色以及高亮色
colorchr <- rep(c("#228B22","grey"),round(chrcount/2)+1)[1:chrcount]
colorhl <- c("grey","red")
colorset <- c(colorchr,colorhl)
colorset.rank <- colorset

color.ranks <- match(sort(c(chrs,"top","NA")),c(chrs,"NA","top"))

for(i in 1:length(color.ranks)){
  rank <- color.ranks[i]
  colorset.rank[i] <- colorset[rank]
}

pdf(out.plot,width=8,height=1.5)

ggplot(data) +
  geom_bar(aes(x=POS, y=data[,col.rank], color=sig),stat="identity", position="identity",size=0.5) +
  geom_bar(aes(x=POS, y=mask,color=data$chr),stat="identity",size=0.5) +
  scale_color_manual(values = colorset.rank) +
  coord_cartesian(ylim=c(1,limit)) +
  xlab("CHROMOSOME") +
  ylab("value") +
  theme_bw() +
  theme(axis.line = element_line(colour = "black"),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.border = element_blank(),
        panel.background = element_blank(),
        legend.position = "none") +
  geom_hline(yintercept=sig.value, linetype="dashed", color = "red") +
# 设置阈值线
  scale_x_continuous(breaks=as.numeric(breakpoints),labels=chrs)
# 关键语句，设置断点

dev.off()


outpath <- commandArgs(TRUE) ## task0/reports/logreg.r_holdout_confusion.txt

task_name = gsub("(task.*)/reports/(.*\\.r)_holdout_confusion.txt","\\1", outpath)
mod_name  = gsub("(task.*)/reports/(.*\\.r)_holdout_confusion.txt","\\2", outpath)
mod_path = paste0(task_name, "/models/", mod_name, "data")

load(mod_path) # gets pre-trained `mod`` object

data_path = paste0(task_name, "/data/processed/", "/test.rdata")
load(data_path)

mod_funcs = paste0(task_name, "/src/models/", mod_name)
source(mod_funcs)

scored = predict_model(mod, X, Y, type="class")
confusion <- table(Y, scored)

dir.create(dirname(outpath), showWarnings = FALSE)
write.csv(confusion, file = outpath)

source("common/src/eval/eval_db/dbapi.r")

m = data.frame(confusion)
m$row_id = 1:nrow(m)
m$field_name = paste0(m$Y, "_", m$scored)
m$value = m$Freq
m = m[,-c(1:3)]

result_name = "holdout_confusion"
log_model_result(task_name, mod_name, result_name, m)
dbDisconnect(conn)


source("_common.r")

x_ob = readLines("../runs/summit/dgemm/openblas.txt")
df_ob = process(x_ob, gpu=FALSE)

x_essl = readLines("../runs/summit/dgemm/essl.txt")
df_essl = process(x_essl, gpu=FALSE)

df = rbind(
  cbind(df_ob, Backend="OpenBLAS"),
  cbind(df_essl, Backend="ESSL")
)

plotter(df, color=nthreads, linetype=Backend) +
  labs(color="Number of Threads", linetype="Backend") +
  ggtitle("Square Matrix Product", subtitle="OpenBLAS vs ESSL from R")

ggsave(last_plot(), file="openblas_vs_essl.pdf")


### replace $ and ,. Turn () into negatives
cleanDollars <- function(x){
	x <- gsub("\\(", "-", x)
 	x <- as.numeric(gsub("\\$|,|\\)", "", x))
 	x
}

### compute totals as of a certain date.
fecAsOf <- function(fec, daysOut, dropQ1 = F){

	known <- fec[fec$daysOut  > daysOut, ]

	### don't have Q1 data yet.
	if(dropQ1) print("hi buddy. just fyi, i'm not using any Q1 fec data, because i think you don't have it yet in 2014")
	if(dropQ1) known <- subset(known, daysOut > 203)

#TODO will generate unfair comparisons when one candidate files earlier than the other. be careful around filing deadlines
	totals <- aggregate(list(money = known$money), list(fecid = known$cand_id, year = known$cycle), sum, na.rm = T)
	totals
}

cleanUpResults <- function(results){

	### clean up some things
	results$candidate <- str_trim(results$candidate)
	results$votesmartid[results$votesmartid=="#N/A"] <- NA
	results$fecid[results$fecid=="#N/A"] <- NA

	### add ranks to results
	results <- results[order(results$office),]
	results$rank <- unlist(by(-1*results$vote, results$office, rank, ties.method = "average", na.last = "keep"))

	### simplify party codes
	results$party2 <- results$party
	demids <- c("D", "DEM", "Democrat  ", "D/WF/IDP Combined Parties", "Democratic-Farmer-Labor", "DFL", "D*", "DNL", "Democratic-Nonpartisan League")
	repids <- c("R", "REP", "R/CRV Combined Parties", "Republican  ", "Independent-Republican")
	results$party2[results$party2 %in% demids] <- "Democrat"
	results$party2[results$party2 %in% repids] <- "Republican"
	results$party2[!results$party2%in%c("Democrat", "Republican")] <- "other"

	### add rank by party
	results <- results[order(results$office, results$party2),]
	results$partyrank <- unlist(by(-1*results$vote, paste0(results$office, results$party2), rank, ties.method = "random", na.last = "keep"))
	results$party2 <- paste0(results$party2, results$partyrank)

	### add a total vote
	results <- merge(results, aggregate(list(tvote = results$vote), list(office = results$office), sum, na.rm = T), by = "office", all = T)
	results$pctvote <- 100*results$vote/results$tvote
	results <- results[order(results$vote, decreasing = T), ]

}

## latest cook rating
cookAsOf <- function(data, daysOut){
	known <- data[data$days_til_election > daysOut,]
	names(known)[1] <- "office"
	known <- known[order(known$days_til_election),]
	known <- known[!duplicated(known$office), ]
	known <- known[,c("office", "cook_rating")]
	known
}

thingAsOf <- function(data, daysOut, thing, collapseBy){
	known <- data[data$daysOut >= daysOut,]
	known <- plyr:::arrange(known, as.numeric(daysOut))
	weightingSchemes(known, thing, collapseBy)
}

cleanUpPresApproval <- function(data, var1 = "A0", var2 = "B0", signed = T) {

	data$enddate <- as.Date(data$enddate, format = "%Y-%m-%d")

	if(is.null(data$knownDate)) data$knownDate <- NA

	data$knownDate <- as.Date(data$knownDate, format = "%Y-%m-%d")
	if(all(is.na(data$knownDate))) data$knownDate <- data$enddate

	data <- subset(data, !is.na(enddate))
	data$cycle <-  as.numeric(format(data$enddate, "%Y"))
	data$cycle <- data$cycle + data$cycle%%2 ## broken for days past election day

	## two versions of approval ratings
	data$net <- data[,var1] - data[,var2]
	data$pctapp <- 100*data[,var1]/(data[,var1] + data[,var2])

	## sign the approval ratings
	if(signed){
		reps <- which(data$presparty=="R")
		data$net[reps] <- -1*data$net[reps]
		data$pctapp[reps] <- 100 - data$pctapp[reps]
	}

	data$daysOut <- electionDay(data$cycle) - data$knownDate
	bad <- data$daysOut < 0
	data$cycle[bad] <- data$cycle[bad] + 2
	data$daysOut <- electionDay(data$cycle) - data$knownDate
	data
}

cleanUpPartyFav <- function(data){
	## weirdness so we can use same function as other ones
	data$enddate <- as.character(format(as.Date(data$EndDate, format = "%m/%d/%Y"), format = "%Y-%m-%d"))
	data$A0 <- data$Favorable.dem - data$Unfavorable.dem
	data$B0 <- data$Favorable.rep - data$Unfavorable.rep
	cleanUpPresApproval(data, signed = F)
}

cleanUpPVI <- function(pvi){

	pvi2 <- pvi[ ,grep("pvi|postal", names(pvi))]
	pvi2 <- reshape(pvi2, direction = "long", varying = list(1:16))
	pvi2$year <- 1952 + 4*(16 - pvi2$time)
	names(pvi2)[3] <- "pvi"
	pvi2 <- pvi2[,c("postal", "year", "pvi")]

	pvi3 <- pvi2
	pvi3$year <- pvi3$year + 2

	x <- rbind(pvi2, pvi3)
	rownames(x) <- NULL
	na.exclude(x)
}

realraces <- function(reduced, results){
	these <- c("vote.Democrat1", "vote.Republican1")
	reduced[,these][is.na(reduced[,these])] <- 0
	reduced$demPctMajor <- 100*reduced$vote.Democrat1/(reduced$vote.Democrat1 + reduced$vote.Republican1)
	reduced$demMarginAll <- 100*(reduced$vote.Democrat1 - reduced$vote.Republican1)/reduced$tvote

	reduced$realrace <- as.numeric(reduced$demPctMajor > 10 & reduced$demPctMajor < 90)
	reduced$mostlyARepAndDem <- 1
	reduced$mostlyARepAndDem [reduced$office %in% subset(results, rank < 3 & party2 == "other1")$office ] <- 0

	## is it really a standard 2-party deal?
	reduced$sigThirdParty <- 0
	reduced$sigThirdParty [reduced$office %in% subset(results, party2 == "other1" & pctvote > 20)$office ] <- 1
	reduced$sigThirdParty10 <- 0
	reduced$sigThirdParty10[reduced$office %in% subset(results, party2 == "other1" & pctvote > 10)$office ] <- 1
	problematicRecodes <- subset(results, xx%in%c("2012MEKing", "2010FLCrist", "2010AKMurkowski", "2006CTLieberman"))$office
	reduced$sigThirdParty10[reduced$office%in%problematicRecodes] <- 1

	reduced$fakeParty <- 0
	reduced$fakeParty[reduced$office%in%problematicRecodes] <- 1

	#reduced$mostlyARepAndDem[ (reduced$vote.Democrat1 + reduced$vote.Republican1) / reduced$tvote  < .80 ] <- 0
	reduced
}

weightingSchemes <- function(known, var, id, lastX = 4){
	known$thing <- known[,var]

	zz <- ddply(known, id, function(X) data.frame(
			x1 = mean(X$thing, na.rm = T), ### mean of everything this election cycle
			x2 = weighted.mean(X$thing, .9^(as.numeric(X$daysOut)/30), na.rm = T), ## time weighting. crazy slow decay.
			x2b = weighted.mean(X$thing, .5^(as.numeric(X$daysOut)/14), na.rm = T), ## half-life of two weeks.
			x2c = weighted.mean(X$thing, .5^(as.numeric(X$daysOut)/30), na.rm = T),
			x3 = X$thing[!is.na(X$thing)][1], ## 1 most recent
			x4 = mean(X$thing[order(X$daysOut) < lastX], na.rm = T) ## 3 most recent
	))
	zz
}

addLags <- function(oldreults, reduced){
	oldresults <- oldresults[,c("year", "class", "postal", "offyear", "office", "demPctMajor")]

	for(i in names(reduced)){
		if(!i%in%names(oldresults)){
			oldresults[,i] <- NA
		}
	}

	oldresults <- oldresults[,names(reduced)]
	oldresults <- subset(oldresults, !is.na(postal))
	reduced <- rbind(reduced, oldresults)

	#### make lags.
	reduced$lastResultsThisSeat <- NA
	reduced$lastResultsThisOffOn <- NA
	reduced$lastResultsThisState <- NA
	reduced <- reduced[order(reduced$year, decreasing = T),]

	### terrible; to improve, handle multi races per state.
	### may want to only do competitive raes?
	for(i in 1:nrow(reduced)){
		reduced$lastResultsThisSeat[i] <- subset(reduced, postal == reduced$postal[i] & class == reduced$class[i] & year < reduced$year[i] & demPctMajor!=0)$demPctMajor[1]
		reduced$lastResultsThisOffOn[i] <- subset(reduced, postal == reduced$postal[i] & offyear == reduced$offyear[i] & year < reduced$year[i] & demPctMajor!=0)$demPctMajor[1]
		reduced$lastResultsThisState[i] <- subset(reduced, postal == reduced$postal[i] & year < reduced$year[i] & demPctMajor!=0)$demPctMajor[1]
	}

	reduced <- subset(reduced, year > 1990)
	reduced
}

prepareTheData <- function(results, reduced, presApproval, genBallot, partyFav, pvi, fec, incApproval, lastsen, cookRatings, oldresults){

	results <- cleanUpResults(results)

	##############
	### fec clean up
	##############

	##  moved to fec-updates.r

	##############
	### bio collapse.
	##############

	temp <- names(results)
	bio <- results[ ,grep("city.council", temp):grep("us.senate", temp)]
	bio <- data.frame(nothing = 1, bio)
	results$experience <- apply(bio, 1, function(x) max(which(x == 1))) - 1

	##############
	### 2014, all possible combos
	##############

	finishedRaces <- subset(results, year < 2014)
	finishedRaces$matchup <- 1

	results2014 <- subset(results, year == 2014)
	these <- unique(results2014$office)

	## order by decreasing money, so lower matchup numbers come first
	## temp <- aggregate(list(money = fec$money), list(fecid = fec$cand_id), sum)
	## results2014 <- results2014[order(temp$money[match(results2014$fecid, temp$fecid)], decreasing = T),]

	combos2014 <- NULL
	for(i in these){

		temp <- subset(results2014, office == i)
		dems <- temp[grep("Democrat", temp$party2),]$slug
		reps <- temp[grep("Republican", temp$party2),]$slug

		for(j in 1:length(dems)){
			for(k in 1:length(reps)){

				thisdem <- subset(temp, slug == dems[j])
				if(nrow(thisdem)>0)
					thisdem$party2 <- "Democrat1"

				thisrep <- subset(temp, slug == reps[k])
				if(nrow(thisrep)>0)
					thisrep$party2 <- "Republican1"

				newmatchup <- rbind(thisdem, thisrep)
				newmatchup$matchup <- paste(j, k, sep = "-")
				combos2014 <- rbind(combos2014, newmatchup)
			}
		}
	}

	combos2014 <- combos2014[-c(grep("0-|-0", combos2014$matchup)),]
	results <- rbind(finishedRaces, combos2014)

	##############
	### drop to a single row per race, keeping data for only the top Democrat and the top Republican
	##############
	reduced <- subset(results, party2 %in% c("Democrat1", "Republican1"))
	reduced <- reshape(reduced, direction = "wide", idvar = c("office", "year", "state", "postal", "class", "tvote", "matchup"), timevar = "party2", drop = c("partyrank", "party"))
	reduced$serious.Republican1[is.na(reduced$candidate.Republican1) & reduced$year == 2014] <- 1
	reduced$serious.Democrat1[is.na(reduced$candidate.Democrat1) & reduced$year == 2014] <- 1

	### some dummys (whether our race is real and offyear), and lagged results by seat
	reduced <- realraces(reduced, results)
	reduced$lastparty <- lastsen$lastparty[match(reduced$office, lastsen$nextoffice)]
	reduced$offyear <- as.numeric(reduced$year%%4 != 0)
	reduced <- addLags(oldresults, reduced)

	reduced$win <- ""
	reduced$win[reduced$win.Democrat1 == 1]  <- "D"
	reduced$win[reduced$win.Republican1 == 1]  <- "R"
	reduced$win[reduced$win.other1 == 1]  <- "O"

	##############
	### identify states where the senator (sitting or newly elected) usually (since 1992) doesn't match the presidential vote.
	##############
	temp <- cbind(postal = pvi$postal, pvi[,grep("diff", names(pvi))] )
	temp2 <- reshape(temp, idvar = "postal", direction = "long", varying = list(2:ncol(temp)))
	temp2$year <- as.numeric(gsub("diff", "", names(temp)[-c(1)][temp2$time]))
	names(temp2)[3] <- "diff"
	temp2$presparty <- ifelse(temp2$diff > 0, "D", "R")
	tempsen <- lastsen[,c("Party", "term", "state")]
	names(tempsen) <- c("party", "year", "postal")
	temp3 <- merge(tempsen, temp2, by = c("year", "postal"))
	xx <- strsplit(as.character(temp3$party), split = ";")
	temp3$party <- sapply(xx, function(x) paste(unique(x), collapse = ";"))
	temp3 <- subset(temp3, temp3$year > 1992)
	diffsen <- aggregate(list(diffsen = temp3$party!=temp3$presparty), list(postal = temp3$postal), mean)
	diffsen  <- diffsen[order(diffsen$diffsen),]
	reduced$presSenMostlyOpposite <- 0
	reduced$presSenMostlyOpposite [reduced$postal %in% diffsen$postal[diffsen$diffsen > .5]] <- 1

	##############
	### median senate vote
	##############
	medMargin2 <- with(reduced, aggregate(list(x = reduced$demMarginAll), list(postal = reduced$postal), median, na.rm = T))
	reduced$medMargin2 <- medMargin2$x[match(reduced$postal, medMargin2$postal)]

	##############
	### does sitting president party matter (esp in offyear?) - prob not enough data to actaully investigate this
	##############
  	oldpres <- data.frame(year = seq(1990, 2014, by = 2), sittingPres = "D", stringsAsFactors = F)
  	oldpres$sittingPres[oldpres$year %in% c(1990, 1992, 2002, 2004, 2006, 2008)] <- "R"
  	reduced <- merge(reduced, oldpres, by = "year")

	##############
	### compute margins, name dates consistently, etc. for generic poll data
	##############
	presApproval <- cleanUpPresApproval(presApproval)
	genBallot <- cleanUpPresApproval(genBallot, var1 = "Democrats", var2 = "Republicans", signed = F)
	partyFav <- cleanUpPartyFav(partyFav)
	pvi <- cleanUpPVI(pvi)

	##############
	### add some dates to things
	##############
	incApproval$DATEOUT <- as.Date(incApproval$knownDate, format = "%Y-%m-%d") ### switched from incApproval$DATEOUT to incApproval$knownDate
	incApproval$daysOut <- electionDay(as.numeric(sapply(strsplit(incApproval$relevant.office, split = "-"), function(x) x[5]))) - incApproval$DATEOUT

	save(results, reduced, presApproval, genBallot, partyFav, pvi, fec, incApproval, lastsen, cookRatings, oldresults, file = "fundydata.rdata")

}

prepData <- function(fec2, cookRatings2, incApproval2, presApproval2, genBallot2, partyFav2, reduced){

	##############
	### put it all together
	##############

	makeid <- function(data, var, xx = "year") paste(data[,xx], data[,var])
	getMoney <- function(xx) fec2$money[match(makeid(reduced, xx), makeid(fec2, "fecid"))];

	reduced$money.Democrat1   <- getMoney("fecid.Democrat1")
	reduced$money.Republican1 <-  getMoney("fecid.Republican1")
	reduced$cook <- cookRatings2$cook_rating[ match(reduced$office, cookRatings2$office) ]
	reduced$incApproval <- incApproval2$x2[ match(reduced$office, incApproval2$relevant.office) ]
	reduced$presApproval <- presApproval2$x2b[ match(reduced$year, presApproval2$cycle) ]
	reduced$genBallot <- genBallot2$x2c[ match(reduced$year, genBallot2$cycle) ]
	reduced$partyFav <- partyFav2$x2b[ match(reduced$year, partyFav2$cycle) ]
	reduced$pvi <- pvi$pvi [ match(makeid(reduced, "postal"), makeid(pvi, "postal")) ]

	reduced$incumbent <- "open"
	reduced$incumbent[ which(reduced$incumbent.Democrat1 == 1) ] <- "D"
	reduced$incumbent[ which(reduced$incumbent.Democrat1 == "a") ] <- "Da"
	reduced$incumbent[ which(reduced$incumbent.Republican1 == 1) ] <- "R"
	reduced$incumbent[ which(reduced$incumbent.Republican1 == "a") ] <- "Ra"
	reduced$open <- reduced$incumbent == "open"
	reduced$open2 <- !reduced$incumbent %in% c("D", "R")

	### calculate senate percents on a rolling basis
	lastsen2 <- NULL
	for(year in seq(1992, 2014, by = 2)){
		temp <- subset(lastsen, term < year & term >= year - 40)
		demsplits = ddply(temp, "state", function(X) {
			gg <- strsplit(as.character(X$Party), split = ";")
			l <- sapply(gg, length)
			weight <- 1/rep(l, times = l)
			party = unlist(gg)
			weighted.mean(party !="R" , weight)} )
		demsplits$year <- year
		lastsen2 <- rbind(lastsen2, demsplits)
	}
	names(lastsen2)[2] <- "pctDemLast20"
	reduced$pctDemLast20 <- lastsen2$pctDemLast20[ match( paste(reduced$year, reduced$postal), paste(lastsen2$year, lastsen2$state)    )]

	## bad filling in missing ratings
	reduced$temp <- ifelse(reduced$incumbent %in% c("D", "Da"), reduced$demPctMajor, 100 - reduced$demPctMajor)
	missingratings <- which(is.na(reduced$incApproval) & reduced$incumbent != "open")
	temp <- reduced[missingratings,]
	reduced$incApproval[missingratings] <- predict( lm(incApproval ~ pvi + temp, data = subset(reduced, realrace == 1)), newdata = temp )
	reduced$incApproval[is.na(reduced$incApproval)] <- 0

	reduced$cook <- reduced$cook - 4
	reduced$cook[is.na(reduced$cook)] <- 0
	reduced$cook <- as.factor(reduced$cook)
	reduced$cook <- relevel(reduced$cook, ref = "0")

	fixme <- c("money.Democrat1", "money.Republican1", "experience.Democrat1", "experience.Republican1")
	reduced[,fixme][is.na(reduced[,fixme])] <- 0

	reduced$demMoney <- 100 * with(reduced, money.Democrat1 / (money.Democrat1 + money.Republican1) )
	reduced$demMoney[is.na(reduced$demMoney)] <- 50 ## no one has reported money.
	reduced$demMoney <- reduced$demMoney - 50

	reduced$netExp <- reduced$experience.Democrat1 - reduced$experience.Republican1
	reduced$netExp2 <- floor(reduced$experience.Democrat1/3) - floor(reduced$experience.Republican1/3)

	reduced$incApproval2 <- reduced$incApproval
	reps <- reduced$incumbent%in%c("R", "Ra")
	reduced$incApproval2[reps] <- -1 * reduced$incApproval2[reps]

	reduced$incumbentSimple <- substr(reduced$incumbent, 1, 1)
	reduced$incumbentSimple <- relevel(as.factor(reduced$incumbentSimple), ref = 3)

	reduced$notARace <- with(reduced, as.character(cook)%in%c("-3", "3") | is.na(candidate.Democrat1) | is.na(candidate.Republican1))

	reduced$norep <- is.na(reduced$candidate.Republican1)
	reduced$nodem <- is.na(reduced$candidate.Democrat1)
	reduced
}


## RNA-seq analysis with DESeq2
## modified from example from Stephen Turner, @genetics_blog

library(DESeq2)
library(RColorBrewer)
library(gplots)

## args[1] == full path to Charts directory for this analysis
## args[2] == full path to featureCounts csv for this analysis
## args[3] == comma separated string of conditions to compare and rep counts:
##            "c1,c2,c1reps,c2reps"
## args[4] == script directory
##
args = commandArgs(trailingOnly=TRUE)
setwd(args[1])
source(paste(paste(args[4],"/",sep=""),"rld_pca.r",sep=""))
source(paste(paste(args[4],"/",sep=""),"maplot.r",sep=""))
source(paste(paste(args[4],"/",sep=""),"volcanoplot.r",sep=""))

## preprocess phase --------------------------------------------------

## Read featureCounts matrix
countdata <- read.table(args[2], header=TRUE, row.names=1)

## Remove first five columns (chr, start, end, strand, length)
countdata <- countdata[ ,6:ncol(countdata)]

## Remove .bam or .sam from filenames
colnames(countdata) <- gsub("\\.[sb]am$", "", colnames(countdata))

## Convert to matrix
countdata <- as.matrix(countdata)
head(countdata)

## Assign condition
c1c2reps <- strsplit(args[3], ",", fixed = TRUE)[[1]]
c1 <- c1c2reps[[1]]
c2 <- c1c2reps[[2]]
c1reps <- c1c2reps[[3]]
c2reps <- c1c2reps[[4]]
prefix <- paste(c1,c2,sep="-")

##(condition <- factor(c(rep(c1, reps), rep(c2, reps))))
##(condition <- factor(c(rep("Condition1",2),rep("Condition2",4))))
(condition <- factor(c(rep(c2, c2reps), rep(c1, c1reps))))

## Analysis phase --------------------------------------------------

## Create a coldata frame and instantiate the DESeqDataSet. See
## ?DESeqDataSetFromMatrix
##
(coldata <- data.frame(row.names=colnames(countdata), condition))
dds <- DESeqDataSetFromMatrix(countData=countdata, colData=coldata, design=~condition)
dds

## Run the DESeq pipeline
dds <- DESeq(dds)

# Plot dispersions
png(paste(prefix,"qc-dispersions.png",sep="-"), 1000, 1000, pointsize=20)
plotDispEsts(dds, main="Dispersion plot")
dev.off()

## Regularized log transformation for clustering/heatmaps, etc
rld <- rlogTransformation(dds)
head(assay(rld))
png(paste(prefix,"histogram-assay.png",sep="-"), 1000, 1000, pointsize=20)
hist(assay(rld))
dev.off()

## Colors for plots below via RColorBrewer
(mycols <- brewer.pal(8, "Dark2")[1:length(unique(condition))])

## Create heatmap of sample distance
sampleDists <- as.matrix(dist(t(assay(rld))))
png(paste(prefix,"qc-heatmap-samples.png",sep="-"), w=1000,h=1000, pointsize=20)
heatmap.2(as.matrix(sampleDists), key=F, trace="none",
          col=colorpanel(100, "black", "white"),
          ColSideColors=mycols[condition], RowSideColors=mycols[condition],
          margin=c(10, 10), main="Sample Distance Matrix")
dev.off()

## Do some PCA
## Could do with built-in DESeq2 function:
## DESeq2::plotPCA(rld, intgroup="condition")
png(paste(prefix,"qc-pca.png",sep="-"), 1000, 1000, pointsize=20)
rld_pca(rld, colors=mycols, intgroup="condition", xlim=c(-75, 35))
dev.off()

## Get differential expression results
res <- results(dds)
table(res$padj<0.05)
## Order by adjusted p-value
res <- res[order(res$padj), ]
## Merge with normalized count data
resdata <- merge(as.data.frame(res), as.data.frame(counts(dds, normalized=TRUE)), by="row.names", sort=FALSE)
names(resdata)[1] <- "Gene"
head(resdata)
## Write results
write.csv(resdata, file=paste(prefix,"DGE-results.csv",sep="-"))

## MA plot
## Could do with built-in DESeq2 function:
## DESeq2::plotMA(dds, ylim=c(-1,1), cex=1)
png(paste(prefix,"DGE-maplot.png",sep="-"), 1500, 1000, pointsize=20)
maplot(resdata, main="MA Plot")
dev.off()

## Volcano plot...
png(paste(prefix,"DGE-volcanoplot.png",sep="-"), 1200, 1000, pointsize=20)
volcanoplot(resdata, lfcthresh=1, sigthresh=0.05, textcx=.8, xlim=c(-2.3, 2))
dev.off()


library(raster)

files = list.files('.')
files = files[grep('.tif$', files)]
print(files)

for (f in files){
    rast = raster(f)
    new = rast[68:nrow(rast), 68:ncol(rast), drop=F]
    new_fname = gsub('.tif', '_90x90.tif', f)
    print(paste('Now writing:', new_fname))
    writeRaster(new, new_fname, 'GTiff')
}


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Phylogenetic analyses of fraction feeding and lambda
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(ape) # Phylogenetics
library(MCMCglmm)
library(phylobase)
library(plyr)
library(curl)
library(phylosignal) # for nicer plots (http://www.francoiskeck.fr/phylosignal/demo_plots.html)
# Fix "Peer certificate cannot be authenticated with given CA certificates" error
# library(Rphylopars) # for inference with missing data and within-species variation
library(httr)
library(stringr) # word()
library(quantreg)
library(sfsmisc)
set_config(config(ssl_verifypeer = 0L))
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(list=ls()) # clears workspace
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
source('R/FracFeed-Functions.r') # Convenience functions
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
load('Output/GAM/GAM_fit_noTaxInf.Rdata') # load 'fit' of non-taxonomicmodel
  length(fitted(fit))

load('Data/FracFeed_DataPhylo.Rdata') # load full post-ToL Frac Feeding dataset
  nrow(fdat)
  length(unique(fdat$Consumer.identity))
  nrow(fdat[-fit$na.action,]) # removing species for which GAM couldn't be fit due to lack of information on all variables

load('Data/FracFeed_DynamicsDataPhylo.Rdata') # load full post-ToL Dynamics dataset
  nrow(ddat)
  length(unique(ddat$Consumer.identity))

load('Output/Phylo/Taxa_comb_matched.Rdata') # load taxonomic identities
  nrow(taxa)

###############################
# Set up full tree construction
###############################
tree<-tol_induced_subtree(taxa$ott_id,label_format = 'name')
save(tree,file='Output/Phylo/Tree_comb.Rdata')

length(tree$tip.label)
length(unique(c(ddat$Consumer.identity,fdat$Consumer.identity)))

#######################################################################
# Merge Fraction feeding dataset w/ non-taxonomic model-fit estimates
#######################################################################
fdat$fit <- fdat$resid <- rep(NA,nrow(fdat))
fdat$fit[-fit$na.action] <- fitted(fit)
fdat$resid[-fit$na.action] <- residuals(fit)

#######################################################
# Calculate data averages by consumer identity
# (phylobase 'trees' can only have one datum per taxon)
#######################################################
sfdat<-ddply(fdat,.(Consumer.identity),summarise,fF.m=mean(fF),fF.sd=sd(fF),fit.m=mean(fit),fit.sd=sd(fit),resid.m=mean(resid), resid.sd=sd(resid),n=length(fF))
sfdat$fF.sd[is.na(sfdat$fF.sd)]<-0
sfdat$fit.sd[is.na(sfdat$fit.sd)]<-0
sfdat$resid.sd[is.na(sfdat$resid.sd)]<-0

# Residuals are very heavy-tailed, so created log10-transformed residuals
sfdat$resid.m.log10<-sfdat$resid.m
  neg.res<-which(sfdat$resid.m.log10<0 & !is.na(sfdat$resid.m.log10))
  pos.res<-which(sfdat$resid.m.log10>0 & !is.na(sfdat$resid.m.log10))
  sfdat$resid.m.log10[neg.res]<- -log10(abs(sfdat$resid.m.log10[neg.res]))
  sfdat$resid.m.log10[pos.res]<-  log10(sfdat$resid.m.log10[pos.res])
nrow(sfdat)

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Average dynamics information
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
sddat <- ddply(ddat, .(Consumer.identity), summarise, lambda.m=mean(lambda),lambda.sd=sd(lambda), sigma.m=mean(sigma),sigma.sd=sd(sigma), epsilon.m=mean(epsilon),epsilon.sd=sd(epsilon), lambda.sigma2.m=mean(lambda.sigma2), lambda.sigma2.sd=sd(lambda.sigma2))
# Using 2*lambda / sigma^2 (Butler & King, 2004)
sddat$lambda.sd[is.na(sddat$lambda.sd)]<-0
sddat$sigma.sd[is.na(sddat$sigma.sd)]<-0
sddat$epsilon.sd[is.na(sddat$epsilon.sd)]<-0
sddat$lambda.sigma2.sd[is.na(sddat$lambda.sigma2.sd)]<-0
nrow(sddat)

# scdat<-ddply(cdat,.(Consumer.identity),summarise,OUSS_FAP=mean(OUSS_FAP),OUSS_PM=mean(OUSS_PM),OUSS_lambda=mean(OUSS_lambda),OUSS_lambda.sd=sd(OUSS_lambda),FracCycle= sum(OUSS_Cycles)/length(OUSS_Cycles)) # This was for use on results provided by Louca & Doebeli (which requires loading 'cdat' in 'FracFeed_CycleDataPhylo.Rdata'
# nrow(scdat)

#~~~~~~~~~~~~~~~~
# Merge summaries
#~~~~~~~~~~~~~~~~
sdat<-merge(sfdat,sddat,all=TRUE)
nrow(sdat)==length(tree$tip.label)

rownames(sdat)<-sdat$Consumer.identity
sdat<-sdat[,-1]

#####################
# Match data to tree
#####################
# Check to ensure all taxa are present in both tree and data
a<-sort(tree$tip.label)
b<-sort(rownames(sdat))
a[a%!in%b]
b[b%!in%a]

# Set branch lengths using Grafen's (1989) method (much-improved fan visualization)
btree<-tree<-compute.brlen(tree, method='Grafen', power=1)

tree<-as(tree,'phylo4')
# nodeLabels(tree)

tree_data<-phylo4d(tree,tip.data=sdat,rownamesAsLabels=TRUE, match.data=TRUE,missing.data=NULL,extra.data=NULL)
tree_data<-reorder(tree_data,order='preorder')
save(tree_data,file='Output/Phylo/Tree_w.CombData.Rdata')

# Data-specific trees
ftaxa<-rownames(sdat)[!is.na(sdat$fF.m)]
ftree_data<-subset(tree_data,tips.include=ftaxa)
save(ftree_data,file='Output/Phylo/Tree_w.FracFData.Rdata')

ctaxa<-rownames(sdat)[!is.na(sdat$lambda.m)]
ctree_data<-subset(tree_data,tips.include=ctaxa)
save(ctree_data,file='Output/Phylo/Tree_w.CycleData.Rdata')

fctaxa<-rownames(sdat)[which(!is.na(sdat$lambda.m)&!is.na(sdat$fF.m))]
fctree_data<-subset(tree_data,tips.include=fctaxa)
save(fctree_data,file='Output/Phylo/Tree_w.CombTaxaData.Rdata')

##################
# Plot phylogenies
##################
colpal <- colorRampPalette(c("blue", "yellow", "red"))
# ~~~~~~~~~~~~
# Without data -- all species in combined datasets
# ~~~~~~~~~~~~
pdf('Output/Phylo/Phylogeny.pdf',width=20,height=300)
  plot(tree, show.node.label=TRUE,show.tip.label=TRUE)
dev.off()

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# With data - only those with Fraction Feeding data
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tree_dat<-ftree_data
ftraits<-c('fF.m','fit.m','resid.m.log10')
xlims<-matrix(c(0,1,0,1,range(sdat$resid.m.log10,na.rm=TRUE)),nrow=2)
xlims[1,3]<-floor(xlims[1,3]); xlims[2,3]<-ceiling(xlims[2,3])

# pdf('Output/Phylo/Phylogeny_fF_dot.pdf',width=20,height=120)
#   multiplot.phylo4d(tree_dat,trait=ftraits,data.xlim=xlims,plot.type='dotplot',tree.ratio=0.4,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=F,grid.col='grey90',grid.lty=1,show.box=TRUE,dot.cex=1)
# dev.off()

pdf('Output/Phylo/Phylogeny_fF_col.pdf',width=20,height=120)
  multiplot.phylo4d(tree_dat,trait=ftraits,data.xlim=xlims,plot.type='gridplot',tree.ratio=0.8,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=F,grid.col='grey90',grid.lty=1,show.box=FALSE,cell.col=colpal(100))
dev.off()

pdf('Output/Phylo/Phylogeny_fF_col_fan.pdf',width=25,height=20)
  multiplot.phylo4d(tree_dat,trait=ftraits,tree.type='fan',plot.type='gridplot',data.xlim=xlims,tree.ratio=0.6,show.trait=FALSE,tip.cex=0.2,tree.ladderize=TRUE,cell.col=colpal(100),tree.open.angle = 180,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=FALSE)
dev.off()

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# With data - only those with Cycling data
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tree_dat<-ctree_data
ctraits<-c('fF.m','lambda.m','sigma.m','lambda.sigma2.m')
xlims<-matrix(c(0,1,0,max(sddat$lambda.m,na.rm=TRUE),0,max(sddat$sigma.m,na.rm=TRUE)),nrow=2)
xlims[2,2]<-ceiling(xlims[2,2]);xlims[2,3]<-ceiling(xlims[2,3])

pdf('Output/Phylo/Phylogeny_Cycle_dot.pdf',width=20,height=120)
multiplot.phylo4d(tree_dat,trait=ctraits,data.xlim=xlims,plot.type='dotplot',tree.ratio=0.4,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=F,grid.col='grey90',grid.lty=1,show.box=TRUE,dot.cex=1)
dev.off()

pdf('Output/Phylo/Phylogeny_Cycle_col.pdf',width=20,height=120)
multiplot.phylo4d(tree_dat,trait=ctraits,data.xlim=xlims,plot.type='gridplot',tree.ratio=0.8,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=F,grid.col='grey90',grid.lty=1,show.box=FALSE,cell.col=colpal(100))
dev.off()

pdf('Output/Phylo/Phylogeny_Cycle_col_fan.pdf',width=25,height=20)
multiplot.phylo4d(tree_dat,trait=ctraits,tree.type='fan',plot.type='gridplot',data.xlim=xlims,tree.ratio=0.6,show.trait=FALSE,tip.cex=0.2,tree.ladderize=TRUE,cell.col=colpal(100),tree.open.angle = 180,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=FALSE)
dev.off()

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# With data - both data sets - all taxa
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tree_dat<-tree_data
traits<-c('fF.m','lambda.sigma2.m')
xlims<-matrix(c(0,1,0,max(sddat$lambda.m,na.rm=TRUE)),nrow=2)
xlims[2,2]<-ceiling(xlims[2,2])

pdf('Output/Phylo/Phylogeny_Comb_col_fan.pdf',width=25,height=20)
multiplot.phylo4d(tree_dat,trait=traits,tree.type='fan',plot.type='gridplot',data.xlim=xlims,tree.ratio=0.6,show.trait=FALSE,tip.cex=0.2,tree.ladderize=TRUE,cell.col=colpal(100),tree.open.angle = 180,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=FALSE)
dev.off()

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# With data - both data sets - taxa in both data sets
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tree_dat<-fctree_data
traits<-c('fF.m','lambda.sigma2.m')
xlims<-matrix(c(0,1,0,max(sddat$lambda.m,na.rm=TRUE)),nrow=2) # Should adjust maximum to subset of shared species
xlims[2,2]<-ceiling(xlims[2,2])

pdf('Output/Phylo/Phylogeny_CombTaxa_col_fan.pdf',width=25,height=20)
multiplot.phylo4d(tree_dat,trait=traits,tree.type='fan',plot.type='gridplot',data.xlim=xlims,tree.ratio=0.6,show.trait=FALSE,tip.cex=1,tree.ladderize=TRUE,cell.col=colpal(100),tree.open.angle = 180,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=FALSE)
dev.off()

################################
# Produce plots for major clades
################################
Focal.Nodes<-c('Teleostei','Cnidaria','Amphibia','Tetrapoda','Amniota','Arthropoda','Carnivora','Eucarida','Gnathostomata')

traits<-c('fF.m','lambda.sigma2.m')
xlims<-matrix(c(0,1,0,1),nrow=2)

for(s in 1:length(Focal.Nodes)){
  Select.Node<-Focal.Nodes[s]
  temp.tree_dat<-subset(tree_data,node.subtree=Select.Node)

  pdf(paste0('Output/Phylo/Phylogeny_Comb_col_fan_',Select.Node,'.pdf'),width=25,height=20)
  multiplot.phylo4d(temp.tree_dat,trait=traits,tree.type='fan',plot.type='gridplot',data.xlim=xlims,tree.ratio=0.6,show.trait=FALSE,tip.cex=1,tree.ladderize=TRUE,cell.col=colpal(100),tree.open.angle = 180,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=FALSE)

  tryCatch({ # Wrap in this to avoid warning error stopping loop

  multiplot.phylo4d(temp.tree_dat,trait=traits,data.xlim=xlims,plot.type='gridplot',tree.ratio=0.8,trait.bg.col=NA,grid.vertical=FALSE,grid.horizontal=F,grid.col='grey90',grid.lty=1,show.box=FALSE,cell.col=colpal(100))

  }, error=function(e){cat("ERROR :",conditionMessage(e), "\n")})

  dev.off()
  print(s)
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
##########################################
# Quantify strength of phylogenetic signal
##########################################

# feed.cg<-phyloCorrelogram(ftree_data,trait='Feeding')
# save(feed.cg,file='Output/Phylo/phyloCorr_feedcg.Rdata')
#   plot(feed.cg)
#
# resil.cg<-phyloCorrelogram(ctree_dat,trait='OUSS_lambda')
#   save(resil.cg,file='Output/Phylo/phyloCorr_feedcg.Rdata')
#   plot(resil.cg)
#

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

# library(phylolm)
#
# set.seed(123456)
# tre = rcoal(1000)
# taxa = sort(tre$tip.label)
# b0=0; b1=1;
# x <- rTrait(n=1, phy=tre,model="BM",parameters=list(ancestral.state=0,sigma2=10))
# y <- b0 + b1*x + rTrait(n=1,phy=tre,model="lambda",parameters=list(ancestral.state=0,sigma2=1,lambda=0.5))
#
#
# x[1:5]<-NA
# y[20:25]<-NA
#
# library(Rphylopars)
#
# dat = data.frame(species = taxa,trait=y[taxa],pred=x[taxa])
# fit = phylopars.lm(trait~pred,trait_data=dat,tree=tre,model='lambda')
# summary(fit)

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


# source("~/Dropbox/research/climate-trace-shipping/lib/load.r")
# map <- load.ship.metadata()

res <- matrix(0,nr=8, nc=4)
colnames(res) <- c('Speed','Speedservice','Speedmax','Sum')
map$Speed[is.na(map$Speed)] <- 0
map$Speedservice[is.na(map$Speedservice)] <- 0
map$Speedmax[is.na(map$Speedmax)] <- 0
res[,1:3] <- c(1,1,1,1,0,0,0,0,1,1,0,0,1,1,0,0,1,0,1,0,1,0,1,0)

res[1,4] <- sum(map$Speed > 0 & map$Speedservice > 0 & map$Speedmax > 0)
res[2,4] <- sum(map$Speed > 0 & map$Speedservice > 0 & map$Speedmax == 0)
res[3,4] <- sum(map$Speed > 0 & map$Speedservice == 0 & map$Speedmax > 0)
res[4,4] <- sum(map$Speed > 0 & map$Speedservice == 0 & map$Speedmax == 0)
res[5,4] <- sum(map$Speed == 0 & map$Speedservice > 0 & map$Speedmax > 0)
res[6,4] <- sum(map$Speed == 0 & map$Speedservice > 0 & map$Speedmax == 0)
res[7,4] <- sum(map$Speed == 0 & map$Speedservice == 0 & map$Speedmax > 0)
res[8,4] <- sum(map$Speed == 0 & map$Speedservice == 0 & map$Speedmax == 0)

# results: Speed always present when others present; conclusion: use Speed
#      Speed Speedservice Speedmax   Sum
# [1,]     1            1        1 26558
# [2,]     1            1        0 57603
# [3,]     1            0        1  6081
# [4,]     1            0        0     0
# [5,]     0            1        1     0
# [6,]     0            1        0     0
# [7,]     0            0        1     0
# [8,]     0            0        0 37890


library(ggplot2)
library(tidyr)
library(dplyr)
library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(EnvStats)
library(matrixStats)
library(scales)
library(gridExtra)
library(ggpubr)
library(bayesplot)
library(cowplot)

source("utils/geom-stepribbon.r")
#---------------------------------------------------------------------------

load(paste0('results/',"base",'-',Sys.Date(),'.Rdata'))

data_interventions <- read.csv("interventions.csv",
                                 stringsAsFactors = FALSE)
covariates <- data_interventions[1, c(1,2,3,4,5,6, 7, 8)]

N <- length(dates[[1]])
country <- "MEX"

predicted_cases <- colQuantiles(prediction[,1:N,1], probs=.5)
predicted_cases_li <- colQuantiles(prediction[,1:N,1], probs=.025)
predicted_cases_ui <- colQuantiles(prediction[,1:N,1], probs=.975)
predicted_cases_li2 <- colQuantiles(prediction[,1:N,1], probs=.25)
predicted_cases_ui2 <- colQuantiles(prediction[,1:N,1], probs=.75)

estimated_deaths <- colQuantiles(estimated.deaths[,1:N,1], probs=.5)
estimated_deaths_li <- colQuantiles(estimated.deaths[,1:N,1], probs=.025)
estimated_deaths_ui <- colQuantiles(estimated.deaths[,1:N,1], probs=.975)
estimated_deaths_li2 <- colQuantiles(estimated.deaths[,1:N,1], probs=.25)
estimated_deaths_ui2 <- colQuantiles(estimated.deaths[,1:N,1], probs=.75)

rt <- colQuantiles(out$Rt[,1:N,1],probs=.5)
rt_li <- colQuantiles(out$Rt[,1:N,1],probs=.025)
rt_ui <- colQuantiles(out$Rt[,1:N,1],probs=.975)
rt_li2 <- colQuantiles(out$Rt[,1:N,1],probs=.25)
rt_ui2 <- colQuantiles(out$Rt[,1:N,1],probs=.75)

covariates_country <- covariates[which(covariates$ï..Country == country), 2:8]

covariates_country$lockdown = NULL
covariates_country$sport = NULL
covariates_country$travel_restrictions = NULL
covariates_country_long <- gather(covariates_country[], key = "key",
                                      value = "value")
covariates_country_long$x <- rep(NULL, length(covariates_country_long$key))
un_dates <- unique(covariates_country_long$value)

    for (k in 1:length(un_dates)){
      idxs <- which(covariates_country_long$value == un_dates[k])
      max_val <- round(max(rt_ui)) + 0.3
      for (j in idxs){
        covariates_country_long$x[j] <- max_val
        max_val <- max_val - 0.3
      }
    }

    covariates_country_long$value <- mdy(covariates_country_long$value)
    covariates_country_long$country <- rep(country,
                                           length(covariates_country_long$value))

    data_country <- data.frame("time" = as_date(as.character(dates[[1]])),
                               "country" = rep(country, length(dates[[1]])),
                               "reported_cases" = reported_cases[[1]],
                               "reported_cases_c" = cumsum(reported_cases[[1]]),
                               "predicted_cases_c" = cumsum(predicted_cases),
                               "predicted_min_c" = cumsum(predicted_cases_li),
                               "predicted_max_c" = cumsum(predicted_cases_ui),
                               "predicted_min_c2" = cumsum(predicted_cases_li2),
                               "predicted_max_c2" = cumsum(predicted_cases_ui2),
                               "predicted_cases" = predicted_cases,
                               "predicted_min" = predicted_cases_li,
                               "predicted_max" = predicted_cases_ui,
                               "predicted_min2" = predicted_cases_li2,
                               "predicted_max2" = predicted_cases_ui2,
                               "deaths" = deaths_by_country[[1]],
                               "deaths_c" = cumsum(deaths_by_country[[1]]),
                               "estimated_deaths_c" =  cumsum(estimated_deaths),
                               "death_min_c" = cumsum(estimated_deaths_li),
                               "death_max_c"= cumsum(estimated_deaths_ui),
                               "death_min_c2" = cumsum(estimated_deaths_li2),
                               "death_max_c2"= cumsum(estimated_deaths_ui2),
                               "estimated_deaths" = estimated_deaths,
                               "death_min" = estimated_deaths_li,
                               "death_max"= estimated_deaths_ui,
                               "death_min2" = estimated_deaths_li2,
                               "death_max2"= estimated_deaths_ui2,
                               "rt" = rt,
                               "rt_min" = rt_li,
                               "rt_max" = rt_ui,
                               "rt_min2" = rt_li2,
                               "rt_max2" = rt_ui2)

  data_cases_95 <- data.frame(data_country$time, data_country$predicted_min_c,
                              data_country$predicted_max_c)
  names(data_cases_95) <- c("time", "cases_min", "cases_max")
  data_cases_95$key <- rep("nintyfive", length(data_cases_95$time))
  data_cases_50 <- data.frame(data_country$time, data_country$predicted_min_c2,
                              data_country$predicted_max_c2)
  names(data_cases_50) <- c("time", "cases_min", "cases_max")
  data_cases_50$key <- rep("fifty", length(data_cases_50$time))
  data_cases <- rbind(data_cases_95, data_cases_50)
  levels(data_cases$key) <- c("ninetyfive", "fifty")

  p1 <- ggplot(data_country) +
    geom_bar(data = data_country, aes(x = time, y = reported_cases_c),
             fill = "coral4", stat='identity', alpha=0.5) +
    geom_ribbon(data = data_cases_95,
                aes(x = time, ymin = cases_min, ymax = cases_max, fill = key)) +
    geom_line(aes(x=time,y=predicted_cases_c,color="Predicción"))+
    xlab("") +
    ylab("Número acumulado de casos confirmados") +
    scale_y_continuous(labels = scales::comma_format(accuracy = 1),n.breaks = 10)+
    scale_x_date(date_breaks = "3 days", labels = date_format("%e %b")) +
    scale_fill_manual(name = "", labels = c("95% CrI"),
                      values = c(alpha("deepskyblue4", 0.35))) +
    scale_color_manual(name = "",
                      values ="black") +
    theme_pubr() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    guides(fill=guide_legend(ncol=1))

  data_deaths_95 <- data.frame(data_country$time, data_country$death_min_c,
                               data_country$death_max_c)
  names(data_deaths_95) <- c("time", "death_min", "death_max")
  data_deaths_95$key <- rep("nintyfive", length(data_deaths_95$time))
  data_deaths_50 <- data.frame(data_country$time, data_country$death_min_c2,
                               data_country$death_max_c2)
  names(data_deaths_50) <- c("time", "death_min", "death_max")
  data_deaths_50$key <- rep("fifty", length(data_deaths_50$time))
  data_deaths <- rbind(data_deaths_95, data_deaths_50)
  levels(data_deaths$key) <- c("ninetyfive", "fifty")

  p2 <-   ggplot(data_country, aes(x = time)) +
    geom_bar(data = data_country, aes(y = deaths_c, fill = "reported"),
             fill = "coral4", stat='identity', alpha=0.5) +
    geom_line(aes(y=estimated_deaths_c,color="Predicción"))+
    geom_ribbon(
      data = data_deaths_95,
      aes(ymin = death_min, ymax = death_max, fill = key)) +
    scale_x_date(date_breaks = "3 days", labels = date_format("%e %b")) +
    scale_fill_manual(name = "", labels = c("95% CrI"),
                      values = c(alpha("deepskyblue4", 0.35))) +
    scale_color_manual(name = "",
                       values ="black")+
    scale_y_continuous(labels = scales::comma_format(accuracy = 1),
                       n.breaks = 10)+
    xlab("")+
    theme_pubr() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    guides(fill=guide_legend(ncol=1))+
    ylab("Número acumulado de muertes")

  plot_labels <- c("Cancelación de eventos",
                   "Cierre de escuelas",
                   "Aislamiento después de presentar síntomas",
                   "Distanciamiento Social")

  # Plotting interventions
  data_rt_95 <- data.frame(data_country$time,
                           data_country$rt_min, data_country$rt_max)
  names(data_rt_95) <- c("time", "rt_min", "rt_max")
  data_rt_95$key <- rep("nintyfive", length(data_rt_95$time))
  data_rt_50 <- data.frame(data_country$time, data_country$rt_min2,
                           data_country$rt_max2)
  names(data_rt_50) <- c("time", "rt_min", "rt_max")
  data_rt_50$key <- rep("fifty", length(data_rt_50$time))
  data_rt <- rbind(data_rt_95, data_rt_50)
  levels(data_rt$key) <- c("ninetyfive", "fifth")

  p3 <- ggplot(data_country) +
    geom_stepribbon(data = data_rt_95, aes(x = time, ymin = rt_min, ymax = rt_max,
                                        group = key,
                                        fill = key)) +
    geom_hline(yintercept = 1, color = 'black', size = 0.1) +
    geom_step(aes(x=time,y=rt,linetype="Predicción"))+
    scale_linetype_manual(name = "",
                       values ="solid")+
    geom_segment(data = covariates_country_long,
                 aes(x = value, y = 0, xend = value, yend = max(x)),
                 linetype = "dashed", colour = "black", alpha = 0.75) +
    geom_point(data = covariates_country_long, aes(x = value,
                                                   y = x,
                                                   group = key,
                                                   shape = key,
                                                   col = key), size = 2) +
    xlab("") +
    scale_y_continuous(n.breaks = 10)+
    ylab("Número efectivo de reproducción") +
    scale_fill_manual(name = "", labels = c("95% CrI"),
                      values = c(alpha("deepskyblue4", 0.55))) +
    scale_shape_manual(name = "Intervenciones", labels = plot_labels,
                       values = c(21, 22, 23, 24, 25, 12)) +
    scale_colour_discrete(name = "Intervenciones", labels = plot_labels) +
    scale_x_date(date_breaks = "3 days", labels = date_format("%e %b"),
                 limits = c(data_country$time[1],
                            data_country$time[length(data_country$time)])) +
    theme_pubr() +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    theme(legend.position="right")

  p <- plot_grid(p1, p2, p3, ncol = 3, rel_widths = c(1, 1, 2))


#Evolutionary models of continuous trait evolution in R

## Read data & tree
library(phytools)
library(geiger)

tree<-read.tree("TutorialData/anole.gp.tre",tree.names=T)
group<-read.csv('TutorialData/anole.gp.csv', row.names=1, header=TRUE,colClasses=c('factor'))
gp<-as.factor(t(group)); names(gp)<-row.names(group)
svl<-read.csv('TutorialData/anole.svl2.csv', row.names=1, header=TRUE)
svl<-as.matrix(treedata(phy = tree,data = svl, warnings=FALSE)$data)[,1]  #match data to tree

##BM plot data
tree.col<-contMap(tree,svl,plot=FALSE)  #runs Anc. St. Est. on branches of tree
plot(tree.col,legend=0.7*max(nodeHeights(tree)),
     fsize=c(0.7,0.9))

#PLOT data
tree.col<-contMap(tree,svl,plot=FALSE)  #runs Anc. St. Est. on branches of tree
plot(tree.col,type="fan",legend=0.7*max(nodeHeights(tree)),
     fsize=c(0.7,0.9))
cols<-setNames(palette()[1:length(unique(gp))],sort(unique(gp)))
tiplabels(pie=model.matrix(~gp-1),piecol=cols,cex=0.3)
add.simmap.legend(colors=cols,prompt=FALSE,x=0.8*par()$usr[1],
                  y=-max(nodeHeights(tree)-.6),fsize=0.8)

## 1: Some evolutionary models in GEIGER
  #NOTE: may need to adjust the bounds of the search: see help file
fit.BM1<-fitContinuous(tree, svl, model="BM")  #Brownian motion model
fit.BMtrend<-fitContinuous(tree, svl, model="trend")   #Brownian motion with a trend
fit.EB<-fitContinuous(tree, svl, model="EB")   #Early-burst model
fit.lambda<-fitContinuous(tree, svl,
        bounds = list(lambda = c(min = exp(-5), max = 2)), model="lambda")  #Lambda model
options(warn=-1)
fit.K<-fitContinuous(tree, svl, model="kappa")   #Early-burst model
options(warn=-1)
fit.OU1<-fitContinuous(tree, svl,model="OU")    #OU1 model

#Examine AIC
c(fit.BM1$opt$aic,fit.BMtrend$opt$aic,fit.EB$opt$aic,fit.lambda$opt$aic,fit.OU1$opt$aic)
  #NOTE: none of these generate dAIC > 4.  So go with simplest model (BM1)

# Compare LRT formally (NOT needed in this case, but done so anyway)
LRT<-(2*(fit.BM1$opt$lnL-fit.OU1$opt$lnL))
prob<-pchisq(LRT, 1, lower.tail=FALSE)
LRT
prob

## 2: More complex models: Multiple Ornstein-Uhlenbeck Peaks
library(OUwie)
data<-data.frame(Genus_species=names(svl),Reg=gp,X=svl)  #input data.frame for OUwie

fitBM1<-OUwie(tree,data,model="BM1",simmap.tree=TRUE)
fitOU1<-OUwie(tree,data,model="OU1",simmap.tree=TRUE)
  tree.simmap<-make.simmap(tree,gp)  # perform & plot stochastic maps (we would normally do this x100)
fitOUM<-OUwie(tree.simmap,data,model="OUM",simmap.tree=TRUE)

fitBM1
fitOU1
fitOUM  #OUM is strongly preferred (examine AIC)

#How it SHOULD be run
#trees.simmap<-make.simmap(tree = tree,x = gp,nsim = 100)  # 100 simmaps
#fitOUM.100<-lapply(1:100, function(j) OUwie(trees.simmap[[j]],data,model="OUM",simmap.tree=TRUE))
#OUM.AIC<-unlist(lapply(1:100, function(j) fitOUM.100[[j]]$AIC))
#hist(OUM.AIC)
#abline(v=fitBM1$AIC, lwd=2) #add value for BM1

## 3: More complex models: Multiple Evolutionary Rates

# 3A: BM1 vs BMM: Comparing evolutionary rates
tree.simmap<-make.simmap(tree,gp)  # perform & plot stochastic maps (we would normally do this x100)
BMM.res<-brownie.lite(tree = tree.simmap,x = svl,test="simulation")
BMM.res

# 3B: Identifying rate shifts on phylogeny
  #Bayesian MCMC: single rate shift (Revell et al. 2012: Evol.)
BM.MCMC<-evol.rate.mcmc(tree=tree,x=svl, quiet=TRUE)
post.splits<-minSplit(tree,BM.MCMC$mcmc)  #summarize
MCMC.post<-posterior.evolrate(tree=tree,mcmc=BM.MCMC$mcmc,tips = BM.MCMC$tips,ave.shift = post.splits)
   #Plot rescaled to rates
ave.rates(tree,post.splits,extract.clade(tree, node=post.splits$node)$tip.label,
    colMeans(MCMC.post)["sig1"], colMeans(MCMC.post)["sig2"],post.splits)

   #Reversible-jump MCMC: multiple rate shifts (Eastman et al. 2011: Evol.)
BM.RJMC<-rjmcmc.bm(phy = tree,dat = svl)
#Run again for plotting
r <- paste(sample(letters,9,replace=TRUE),collapse="")
rjmcmc.bm(phy=tree, dat=svl, prop.width=1.5, ngen=20000, samp=500, filebase=r, simple.start=TRUE, type="rbm")
outdir <- paste("relaxedBM", r, sep=".")
ps <- load.rjmcmc(outdir)
dev.new()
plot(x=ps, par="shifts", burnin=0.25, legend=TRUE, show.tip=FALSE, edge.width=2)

###################  FOR LECTURE:
#1: what does lambda do?
TreeLambda0 <- rescale(tree, model = "lambda", 0)
TreeLambda5 <- rescale(tree, model = "lambda", 0.5)

par(mfcol = c(1, 3))
plot(tree, show.tip.label = FALSE)
plot(TreeLambda5,show.tip.label = FALSE)
plot(TreeLambda0,show.tip.label = FALSE)
par(mfcol=c(1,1))


# 3. faza: Vizualizacija podatkov

# ZEMLJEVID SVETA S PODATKI O BREZPOSELNOSTI

brezposelnost_svet <- function(){
  svet <- uvozi.svet()
  brezposelnost <- uvozi.zaposlenost()
  podatki <- merge(y = brezposelnost,x = svet, by.x='name', by.y = 'name')
  podatki %>% select(name, 'Brezposelnost')
  svet2 <- tm_shape(podatki) + tm_polygons('Brezposelnost')
  tmap_mode('view')
  return(svet2)
}
brezposelnost_svet <- brezposelnost_svet()

# HISTOGRAM ZADOVOLJSTVA PREBIVALCEV ZA LETO 2013 IN 2018

zadovoljstvo_2013 <- function(){
  ocene <- uvozi.rating()
  stare_ocene <- ocene %>% filter(leto == 2013) %>% select(Drzava, Ocena)
  stare_ocene[,-1] <-round(stare_ocene[,-1]*2)/2

  histogram <- ggplot(stare_ocene, aes(x=Ocena)) +
                    geom_histogram(binwidth=0.5, fill="#c0392b", alpha=0.75) +
                    fte_theme() +
                    labs(title="Ocena zadovoljstva prebivalcev evropskih držav z življenjem leta 2013",
                         x="Ocena zadovoljstva", y="Število držav") +
                    scale_x_continuous(breaks = seq(0,10, by=0.5), limits = c(4.5,9)) +
                    scale_y_continuous(breaks = seq(0,26, by=2), limits = c(0,12)) +
                    geom_hline(yintercept=0, size=0.4, color="black") +
                    geom_vline(xintercept=mean(stare_ocene$Ocena))
  return(histogram)
}
zadovoljstvo_2013 <- zadovoljstvo_2013()

zadovoljstvo_2018 <- function(){
  ocene <- uvozi.rating()
  nove_ocene <- ocene %>% filter(leto == 2018) %>% select(Drzava, Ocena)
  nove_ocene[,-1] <-round(nove_ocene[,-1]*2)/2

  histogram <- ggplot(nove_ocene, aes(x=Ocena)) +
    geom_histogram(binwidth=0.5, fill="#c0392b", alpha=0.75) +
    fte_theme() +
    labs(title="Ocena zadovoljstva prebivalcev evropskih držav z življenjem leta 2018",
         x="Ocena zadovoljstva", y="Število držav") +
    scale_x_continuous(breaks = seq(0,10, by=0.5), limits = c(4.5,9)) +
    scale_y_continuous(breaks = seq(0,26, by=2), limits = c(0,12)) +
    geom_hline(yintercept=0, size=0.4, color="black") +
    geom_vline(xintercept=mean(nove_ocene$Ocena))
  return(histogram)
}
zadovoljstvo_2018 <- zadovoljstvo_2018()

# OSNOVNI GRAF, KI PRIKAZUJE GIBANJE POVPRECNEGA BDP V EVROPI

gibanje_BDP <- function(){
  BDP <- uvozi.BDP()
  bdp_po_letih <- aggregate(BDP$'BDP per capita', by=list(leto=BDP$leto), FUN=mean)
  bdp_po_letih$x <- as.numeric(bdp_po_letih$x)
  g <- ggplot(bdp_po_letih, aes(x=leto, y=x, group = 1)) +
    geom_point(color="#c0392b") +
    geom_path(color = "black") +
    ylim(20000, 30000)+
    fte_theme() +
    labs(x="Leto", y="Realni BDP v €", title="Realni povprecni BDP v € na prebivalca v Evropi")
  return(g)
}
gibanje_BDP <- gibanje_BDP()

# ZEMLJEVID EVROPE GLEDE NA BDP

zemljevid_evrope_BDP <- function(){
  evropa <- uvozi.svet() %>% filter (continent == 'Europe')
  BDP <- uvozi.BDP()
  BDP <- BDP %>% filter (leto == 2018) %>% select('Drzava', 'BDP per capita')
  podatki <- merge(y = BDP,x = evropa, by.x='name', by.y = 'Drzava')
  evropa <- tm_shape(podatki) + tm_polygons('BDP per capita')
  tmap_mode('view')
  return(evropa)
}
zemljevid_evrope_BDP <- zemljevid_evrope_BDP()


# Base plot of raster, but with cut limits
# 'Plot raster with limits

#' Plot raster with limits
#'
#' Base plot of raster, with inlusion of lower and higher plot limits
#'
#' @param x raster
#' @param lcut Minimum value to plot, all below will be similarly coloured. Set to \code{NA} to disable.
#' @param hcut Maximum value to plot, all above will be similarly coloured. Set to \code{NA} to disable.
#' @param setNA Value in raster to set as \code{NA} in output. Set to \code{NA} to disable.
#' @param useimage Use \code{image.plot} to make the plot rather than \code{plot.raster} (logical).
#'
#' @return no function return
#' @export
plotRast = function(x, lcut=NA, hcut=NA, setNA=NA, useimage=F, col=pkrf::ramp('parula',256), ...) {

  require(raster)

  # perfom cutting
  if ((!is.na(lcut)) & (!is.na(lcut))){
    x[x<lcut] <- lcut
    x[x>hcut] <- hcut
    zlimits <- c(lcut,hcut)

  }else if (!is.na(lcut)){
    x[x<lcut] <- lcut
    zlimits   <- c(lcut, raster::cellStats(x,max))

  }else if (!is.na(hcut)){
    x[x>hcut] <- hcut
    zlimits   <- c(raster::cellStats(x,min), hcut)

  }else{
    zlimits <- raster::cellStats(x, range)
  }

  # set NA
  if (!is.na(setNA)){
    x[x==setNA] <- NA
  }

  # plot the image
  if (useimage){
    raster::image(x, zlim=zlimits, col=col, ...)
  }else{
    raster::plot(x, zlim=zlimits, col=col, ...)
  }

}

#' @rdname plotRast
#' @export
pkRastplot <- plotRast


  figure.timeseries.snowcrab.habitat.temperatures = function(p) {

    td = bio.snowcrab::interpolation.db( p=p, DS="habitat.temperatures" )

    td$t = td$temperature
    td$t.sd = td$temperature.sd

    areas = c("cfa4x", "cfasouth", "cfanorth" )
    regions = c("4X", "S-ENS", "N-ENS")
    td$region = factor(td$region, levels=areas, labels=regions)
    td$ubound = td$t + td$t.sd
    td$lbound = td$t - td$t.sd
    td = td[is.finite(td$t) ,]
    td = td[order(td$region,td$yr),]
    xlim=range(td$yr); xlim[1]=xlim[1]-0.5; xlim[2]=xlim[2]+0.5
    ylim= range( c(td$t, td$ubound, td$lbound)  ); ylim[1]=ylim[1]-0.5; ylim[2]=ylim[2]+0.5

    fn = file.path( p$annual.results, "timeseries",  "interpolated", "mean.bottom.temp.snowcrab.habitat" )

    dir.create( dirname(fn), recursive=T, showWarnings=F  )

    png( filename=paste(fn, "png", sep="."), width=3072, height=2304, pointsize=40, res=300 )

    setup.lattice.options()
    pl = xyplot( t~yr|region, data=td, ub=td$ubound, lb=td$lbound,
        layout=c(1,3), xlim=xlim, ylim=ylim, cex=3, # scales = list(y = "free"),
            main="Temperature in potential habitats", xlab="Year", ylab="Celsius",
            panel = function(x, y, subscripts, ub, lb, ...) {
            panel.abline(h=mean(y, na.rm=T), col="gray40", lwd=2, ...)
            larrows(x, lb[subscripts],
                    x, ub[subscripts],
                   angle = 90, code = 3, length=0.005, lwd=1, col="darkgray")
            panel.xyplot(x, y, type="b", lwd=4, pch=".", col="black", ...)
#            panel.loess(x,y, span=0.15, lwd=2)
       }
    )
    print( pl )
    dev.off()

    means = tapply(td$t, td$region, mean, na.rm=T)
    print("mean temperatures:")
    print(means)
    print("SD:")
    print( tapply(td$t, td$region, sd, na.rm=T) )
    print( "latest year:" )
    print( td$t[ td$yr==p$year.assessment ])
    #table.view( td )
    return(fn)
  }


#' frostime
#'
#' Given a temperature t (Celsius) and wind ( m/sec) frost time following Wind Chill Frostbite Chart.
#'
#' @param t numeric Air temperature in Celsius degrees.
#' @param wind numeric the wind speed in meter per seconds [m/s].
#' @return time of frosting
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  frostime
#' @references ISO 9920:2007 Ergonomics of the thermal environment -- Estimation of thermal insulation and water vapour resistance of a clothing ensemble.
#' @export
#'
#'
#'
#'

frostime=function(t,wind) {
                         ct$assign("t", as.array(t))
                         ct$assign("wind", as.array(wind))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=frostime(t[i],wind[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


library(tidyverse)

focus_subject <- "computing" # use a vector for multiple patterns
science_subjects <- c("bio", "chem", "physics")
stem_subjects <- c("math", "statistic", "engineering", "comput", "technical", "bio", "chem", "physics", "physiology")

default_highlights <- c("focus" = "maroon", "other" = "black")
default_highlights

gender_options <- c("male-", "female-", "NotKnown-", "NA-", "NotApplicable-")
gender_options_formatted <- c("male", "female", "NotKnown", "NA", "NotApplicable")

# definitions moved into common_interaction
#gender_colour_scheme <- c("female" = "purple", "male" = "darkgreen")
#gender_shape_icons <- c("female" = -0x2640L, "male" = -0x2642L) # \u2640 and \u2642 )
# see also https://www.telegraph.co.uk/women/business/women-mean-business-interactive

redundant_column_flags <- c("-Passes", "-percentage*", "-COMP", "-PassesUngradedCourses")

path_to_file_store <- "sta_it_402/data"

# todo - complete and include levels -
sqa_qualification_list <- read_csv("sta_it_402/data/demographic_data/sqa_qualifications.csv", trim_ws = T) %>%
                            suppressMessages()
sqa_qualification_list

# default file for normalising pupil counts across years
school_rolls_from_1966 <- read_csv("base/index_factors_census_pupils_from_1966.csv", trim_ws = T) %>%
                            suppressMessages()
base_year <- 1986


###
### figure 4: pie chart
###

rm(list = ls()) # This clears everything from memory.

library(dplyr)
library(ggplot2)
library(cowplot)

setwd("~/Dropbox/BCI_Turnover")
load("BCI_turnover20150611.RData")
source("~/Dropbox/MS/TurnoverBCI/TurnoverBCImain/source.R")
# prepare data set
ab.data <- as.data.frame(sapply(D20m,function(x)apply(x,2,sum)))
ab.data$sp <- rownames(ab.data)
trait.temp <- data.frame(sp=rownames(trait),
           moist=trait$Moist,
           slope=trait$sp.slope.mean,
           slope.sd = trait$sp.slope.sd,
           convex= -trait$sp.convex.mean, # convavity
           convex.sd=trait$sp.convex.sd,
           WSG=trait$WSG,
           slope10=trait$slope_size_10,
           slope20=trait$slope_size_20,
           slope30=trait$slope_size_30,
           slope40=trait$slope_size_40,
           slope50=trait$slope_size_50,
           slope60=trait$slope_size_60,
           slope70=trait$slope_size_70,
           slope80=trait$slope_size_80,
           slope90=trait$slope_size_90,
           slope100=trait$slope_size_100,
           convex10=trait$convex_size_10,
           convex20=trait$convex_size_20,
           convex30=trait$convex_size_30,
           convex40=trait$convex_size_40,
           convex50=trait$convex_size_50,
           convex60=trait$convex_size_60,
           convex70=trait$convex_size_70,
           convex80=trait$convex_size_80,
           convex90=trait$convex_size_90,
           convex100=trait$convex_size_100)

ab.t.data <- merge(ab.data,trait.temp,by="sp")
rownames(ab.t.data) <- ab.t.data$sp
ab.t.data2 <- na.omit(ab.t.data)

#this may be useful way to detect species.
#using the product of delta abundance and deviaiton from mean (or median) trait for each species
WSGab <- data.frame(sp = ab.t.data$sp,
        delta_ab = ab.t.data$census_2010/sum(ab.t.data$census_2010) -     ab.t.data$census_1982/sum(ab.t.data$census_1982),
        delta_ab2 = ab.t.data$census_2010 - ab.t.data$census_1982,
        delta_ab3 = ab.t.data$census_2010/ab.t.data$census_1982,
        WSG = ab.t.data$WSG,
        WSG_delta =ab.t.data$WSG - mean(ab.t.data$WSG,na.rm=T))
WSGab$index <- as.numeric(scale(WSGab$delta_ab)) * as.numeric(scale(WSGab$WSG_delta))

WSGab <- WSGab[order(WSGab$index),]

# moistab
moistab <- data.frame(sp = ab.t.data2$sp,
                    delta_ab = ab.t.data2$census_2010/sum(ab.t.data2$census_2010) - ab.t.data2$census_1982/sum(ab.t.data2$census_1982),
                    moist = ab.t.data2$moist,
                    moist_delta =ab.t.data2$moist - mean(ab.t.data2$moist))
moistab$index <- as.numeric(scale(moistab$delta_ab)) * as.numeric(scale(moistab$moist_delta))

# moistab$index2 <- moistab$delta_ab * moistab$moist_delta

moistab <- moistab[order(moistab$index),]

# convex100ab
convexab <- data.frame(sp = ab.t.data2$sp,
                    delta_ab = ab.t.data2$census_2010/sum(ab.t.data2$census_2010) - ab.t.data2$census_1982/sum(ab.t.data2$census_1982),
                    convex = ab.t.data2$convex,
                    convex_delta =ab.t.data2$convex - mean(ab.t.data2$convex))
convexab$index <- as.numeric(scale(convexab$delta_ab)) * as.numeric(scale(convexab$convex_delta))

# convexab$index2 <- convexab$delta_ab * convexab$_delta

convexab <- convexab[order(convexab$index),]

# slope100ab
slopeab <- data.frame(sp = ab.t.data2$sp,
                    delta_ab = ab.t.data2$census_2010/sum(ab.t.data2$census_2010) - ab.t.data2$census_1982/sum(ab.t.data2$census_1982),
                    slope = ab.t.data2$slope,
                    slope_delta =ab.t.data2$slope - mean(ab.t.data2$slope))
slopeab$index <- as.numeric(scale(slopeab$delta_ab)) * as.numeric(scale(slopeab$slope_delta))

slopeab <- slopeab[order(slopeab$index),]

#using the product of delta abundance and deviaiton from mean (or median) trait for each species
WSGab <- data.frame(sp = ab.t.data$sp,
                    delta_ab = ab.t.data$census_2010/sum(ab.t.data$census_2010) - ab.t.data$census_1982/sum(ab.t.data$census_1982),
                    WSG = ab.t.data$WSG,
                    WSG_delta =ab.t.data$WSG - mean(WSG100[[1]])) %>%
                    mutate(WSG_delta2 = WSG - mean(WSG, na.rm = T))

WSGab$index <- WSGab$delta_ab * WSGab$WSG_delta*100

WSGab <- WSGab[order(WSGab$index),]

# moistab
moistab <- data.frame(sp = ab.t.data$sp,
                    delta_ab = ab.t.data$census_2010/sum(ab.t.data$census_2010) - ab.t.data$census_1982/sum(ab.t.data$census_1982),
                    moist = ab.t.data$moist,
                    moist_delta = ab.t.data$moist - mean(Moist100[[1]]))
moistab$index <- moistab$delta_ab * moistab$moist_delta*100

moistab <- moistab[order(moistab$index),]

# convex100ab
convexab <- data.frame(sp = ab.t.data$sp,
                    delta_ab = ab.t.data$census_2010/sum(ab.t.data$census_2010) - ab.t.data$census_1982/sum(ab.t.data$census_1982),
                    convex = ab.t.data$convex,
                    convex_delta =ab.t.data$convex + mean(convex100[[1]])) # concave
convexab$index <- convexab$delta_ab * convexab$convex_delta*100

convexab <- convexab[order(convexab$index),]
# convexab <- convexab[order(convexab$convex),]

# slopeab
slopeab <- data.frame(sp = ab.t.data$sp,
                    delta_ab = ab.t.data$census_2010/sum(ab.t.data$census_2010) - ab.t.data$census_1982/sum(ab.t.data$census_1982),
                    slope = ab.t.data$slope,
                    slope_delta =ab.t.data$slope - mean(slope100[[1]]))
slopeab$index <- slopeab$delta_ab * slopeab$slope_delta*100

slopeab <- slopeab[order(slopeab$index),]

# sp list for appendix ====================================================

taxa <- read.csv("~/Dropbox/MS/TurnoverBCI/nomenclature_R_20120305_Rready-2.csv")

sp_list <- WSGab %>%
  mutate(Wood_density = round(index, 4)) %>%
  mutate(Abundance_change = round(delta_ab, 4)) %>%
  select(sp, Abundance_change, Wood_density, -index) %>%
  full_join(., moistab, by = "sp") %>%
  mutate(Moisture = round(index, 4)) %>%
  select(-index) %>%
  full_join(., convexab, by = "sp") %>%
  mutate(Concavity = round(index, 4)) %>%
  select(-index) %>%
  full_join(., slopeab, by = "sp") %>%
  mutate(Slope = round(index, 4), sp6 = sp) %>%
  left_join(., taxa, by = "sp6") %>%
  select(sp, family, genus, species,
    Abundance_change, Wood_density, Moisture, Concavity, Slope) %>%
  arrange(sp) %>%
  mutate(species = paste(genus, species)) %>%
  select(-genus)

write.csv(sp_list, "/Users/mattocci/Dropbox/MS/TurnoverBCI/sp_list.csv")

# ========================================
WSGab <- WSGab %>%
  mutate(WSG_index = index)

moistab <- moistab %>%
  mutate(moist_index = index)

convexab <- convexab %>%
  mutate(convex_index = index)

slopeab <- slopeab %>%
  mutate(slope_index = index)

fig_dat <- full_join(WSGab, moistab, by = "sp") %>%
  full_join(., convexab, by = "sp") %>%
  full_join(., slopeab, by = "sp") %>%
  tidyr::gather(., "trait", "val", c(WSG_index, slope_index, moist_index, convex_index)) %>%
  dplyr::select(., c(sp, trait, val)) %>%
  na.omit %>%
  mutate(sig = ifelse(val < 0, "Negative", "Positive"))  %>%
  mutate(val2 = abs(val)) %>%
  mutate(trait_sig = paste(trait, sig, sep = "_"))

  fig_dat %>% group_by(trait) %>%
   summarise(mean = sum(val2, na.rm = T))

temp0 <- tapply(fig_dat$val2, fig_dat$trait, mean, na.rm = T) %>% rep(each = 2)

temp <- fig_dat %>% group_by(trait, sig) %>%
  summarise(mean = mean(val2, na.rm = T)) %>%
  mutate(trait_sig = paste(trait, sig, sep = "_")) %>%
  as_data_frame %>%
  dplyr::select(., c(mean, trait_sig)) %>%
  mutate(mean2 = mean / temp0)

# temp[3,1] <- 100

# high slope
# PIPECA

# large change
# PSYCLI

# high abund
# HYBAPR
# FARAOC

sp_vec <- c("PIPECO", "POULAR", "PIPECA", "PSYCLI", "HYBAPR", "FARAOC")

# moist
# TET2PA

#convex
# SWARS1
# ALSEBL

# slope
# HYBAPR
library(grDevices)

n <- 2
hues <- seq(15, 375, length=n+1)
cols_hex <- sort(hcl(h=hues, l=65, c=100)[1:n])

sp_vec2 <- c("PIPECO", "POULAR", "TET2PA", "SWARS1", "ALSEBL", "HYBAPR")

sp_vec2 <- c("FARAOC", "HYBAPR", "PIPECO", "POULAR")

#sp
sp1 <- sp_list %>% arrange(desc(Wood_density)) %>% head(6) %>% .$sp %>% as.character
sp2 <- sp_list %>% arrange(desc(Moisture)) %>% head(1) %>% .$sp %>% as.character
sp3 <- sp_list %>% arrange(desc(Concavity)) %>% head(6) %>% .$sp %>% as.character
sp4 <- sp_list %>% arrange((Slope)) %>% head(3) %>% .$sp %>% as.character

sp_vec3 <- c(sp1,sp2,sp3,sp4) %>% unique

fig_dat2 <- full_join(fig_dat, temp, by = "trait_sig") %>%
  arrange(val2) %>%
  mutate(trait = factor(trait, levels = c("WSG_index", "moist_index", "convex_index", "slope_index"))) %>%
  mutate(trait2 = factor(trait, labels = c("Wood density", "Moisture", "Concavity", "Slope"))) %>%
  mutate(sig = factor(sig, levels = c("Positive", "Negative"))) %>%
  mutate(col = ifelse(sp == "POULAR", "POULAR",
    ifelse(sp == "PIPECO", "PIPECO", "Other species"))) %>%
  mutate(col = factor(col, levels = c("PIPECO", "POULAR", "Other species"))) %>%
  mutate(sp2 = ifelse(sp %in% sp_vec, as.character(sp), "Other species")) %>%
  mutate(sp3 = ifelse(sp %in% sp_vec2, as.character(sp), "Other species")) %>%
  mutate(sp2 = factor(sp2, levels = c("FARAOC", "HYBAPR", "PIPECA", "PIPECO", "POULAR", "PSYCLI", "Other species"))) %>%
  mutate(sp3 = factor(sp3, levels = c("FARAOC", "HYBAPR", "PIPECO", "POULAR", "Other species"))) %>%
  mutate(sp4 = ifelse(sp %in% sp_vec3, as.character(sp), "Other species")) %>%
  mutate(sp4 = factor(sp4, levels = c(sort(sp_vec3), "Other species")))

lab_dat <- data_frame(lab = paste("(", letters[1:12], ")", sep = ""),
    y = 20,
    x = rep(c(0.21, -1.9, -0.29, 0.5),  3),
    size = rep(c("50ha", "1ha", "0.04ha"), each = 4),
    trait = rep(c("WSG", "moist", "convex", "slope"), 3),
    sp2 = "Other species") %>%
    mutate(size = factor(size, levels = c("50ha", "1ha", "0.04ha"))) %>%
    mutate(trait = factor(trait, levels = c("WSG", "moist", "convex", "slope"))) %>%
    mutate(trait2 = factor(trait, labels = c("Wood~density ~(g~cm^{-3})", "Moisture", "Concavity~(m)", "Slope~(degrees)")))

# highliting 4 species
postscript("/Users/mattocci/Dropbox/MS/TurnoverBCI/TurnoverBCI_MS/fig/pie_4_species.eps", width = 6, height = 3.6)

n <- 4
hues <- seq(15, 375, length=n+1)
cols_hex <- sort(hcl(h=hues, l=65, c=100)[1:n])

lab_dat <- fig_dat2 %>% count(trait2, sig) %>% as.data.frame %>%
  mutate(x = 1.4, y = 0.8) %>%
  mutate(n2 = paste("n =", n, sep = " "))

  ggplot(fig_dat2) +
  geom_bar(aes(y = val2, x = mean2/2,
    fill = as.factor(sp3), width = mean2), position = "fill", stat="identity", color = "white", size = 0.02) +
  geom_text(data = lab_dat, aes(label = n2, x = 1.25, y = 1),
    size = 4, vjust = 0) +
  facet_grid(sig ~ trait2) +
  coord_polar(theta="y") +
  scale_fill_manual(values = c(cols_hex, "gray"),
    guide = guide_legend(title.position = "top",
      title = "Species",)) +
  theme_bw() +
  theme(axis.text.x = element_blank(),
     axis.text.y = element_blank(),
     axis.ticks = element_blank()) +
  xlab("") + ylab("") +
  theme(legend.position = "bottom",
    legend.margin = unit(-0.2, "cm"),
    panel.grid = element_blank())

dev.off()


source("FunctionsForBrainCellProportionsPrediction.r")

library(bigmelon)
library(pheatmap)
library(glmnet)

setwd(dataDir)

gfile<-openfn.gds(gdsFile, readonly = FALSE)

## filter samples
QCSum<-read.csv(paste0(qcOutFolder,"PassQCStatusAllSamples.csv"), stringsAsFactors = FALSE, row.names = 1)

passQC<-rownames(QCSum)[which(QCSum$predLabelledCellType == "TRUE")]
QCmetrics<-read.gdsn(index.gdsn(gfile, "QCdata"))
QCmetrics<-QCmetrics[match(passQC, QCmetrics$Basename),]

rawbetas<-betas(gfile)[,]
rawbetas<-rawbetas[,match(passQC, colnames(rawbetas))]

cellTypes<-unique(QCmetrics$Cell.type)
cellTypes<-cellTypes[!is.na(cellTypes)]
## sort so colours lines up correctly
cellTypes<-sort(cellTypes)
col_pal<-c("darkgreen", "darkblue", "darkmagenta", "deeppink", "darkgray") ## assumes celltypes are order alphabetically

#############
### First ref panel all Exeter FANS fractions including double negative
#############

load("RefDataForCellCompEstimation.rdata")
counts.all <- projectCellType(rawbetas[rownames(braincelldata), ], braincelldata)

## plot results
pdf(paste0(qcOutFolder, "PredictedCellComposition.pdf"),width = 12)
par(mfrow = c(2,3))
for(each in cellTypes){
	barplot(t(counts.all[which(QCmetrics$Cell.type == each),])*100, col = col_pal, main = each, ylab = "% estimated", names.arg = rep("", sum(QCmetrics$Cell.type == each)))
}
plot(0,1, type = "n", xlab = "", ylab = "", axes = FALSE)
legend("center", colnames(counts.all), col = col_pal[1:ncol(counts.all)], pch = 15)

par(mfrow = c(2,2))
for(i in 1:ncol(counts.all)){
	boxplot(counts.all[,i]*100 ~ QCmetrics$Cell.type, col = col_pal, ylab = paste("%", colnames(counts.all)[i], "estimated"), xlab = "Cell type")
}
dev.off()

#aggregate(counts , by = list(QCmetrics$Cell.type), mean)

#################
### Second ref panel all Exeter FANS fractions excluding double negative
#################

load("RefDataForCellCompEstimationNoDoubleNeg.rdata")
counts.nodneg <- projectCellType(rawbetas[rownames(braincelldata), ], braincelldata)

## plot results
pdf(paste0(qcOutFolder, "PredictedCellCompositionNoDoubleNeg.pdf"),width = 12)
par(mfrow = c(2,3))
for(each in cellTypes){
	barplot(t(counts.nodneg[which(QCmetrics$Cell.type == each),])*100, col = col_pal[-1], main = each, ylab = "% estimated", names.arg = rep("", sum(QCmetrics$Cell.type == each)))
}
plot(0,1, type = "n", xlab = "", ylab = "", axes = FALSE)
legend("center", colnames(counts.nodneg), col = col_pal[c(1:ncol(counts.nodneg))+1], pch = 15)

par(mfrow = c(2,2))
for(i in 1:ncol(counts.nodneg)){
	boxplot(counts.nodneg[,i]*100 ~ QCmetrics$Cell.type, col = col_pal, ylab = paste("%", colnames(counts.nodneg)[i], "estimated"), xlab = "Cell type")
}

dev.off()

## compare output with and without double negative
pdf(paste0(qcOutFolder, "ComparePredictedCellCompositionWithoutDoubleNeg.pdf"),width = 12, height = 4)
par(mfrow = c(1,3))
for(each in c("IRF8","NeuN","Sox10")){
	plot(counts.all[,each], counts.nodneg[,each], pch = 16,main = each, xlab = "With DNeg", ylab = "Without DNeg", col = col_pal[as.factor(QCmetrics$Cell.type)])
	abline(a = 0, b = 1)
}
dev.off()

##############
### Third EpiGABA FANS samples
##############

load("RefDataEpiGABAForCellCompEstimation.rdata")
counts.epigaba <- projectCellType(rawbetas[intersect(rownames(braincelldata), rownames(rawbetas)), ], braincelldata[intersect(rownames(braincelldata), rownames(rawbetas)),])

## plot results
pdf(paste0(qcOutFolder, "PredictedCellCompositionEpiGabaRef.pdf"),width = 12)
par(mfrow = c(2,3))
for(each in cellTypes){
	barplot(t(counts.epigaba[which(QCmetrics$Cell.type == each),])*100, col = c("red", "blue", "green"), main = each, ylab = "% estimated", names.arg = rep("", sum(QCmetrics$Cell.type == each)))
}
plot(0,1, type = "n", xlab = "", ylab = "", axes = FALSE)
legend("center", colnames(counts.epigaba), col = c("red", "blue", "green"), pch = 15)

par(mfrow = c(2,2))
for(i in 1:ncol(counts.epigaba)){
	boxplot(counts.epigaba[,i]*100 ~ QCmetrics$Cell.type, col = c("red", "blue", "green"), ylab = paste("%", colnames(counts.epigaba)[i], "estimated"), xlab = "Cell type")
}

dev.off()

pdf(paste0(qcOutFolder, "CompareCellCompositionEpiGabaBDRRef.pdf"),width = 10, height = 13)
par(mfrow = c(ncol(counts.all), ncol(counts.epigaba)))
for(i in 1:ncol(counts.all)){
	for(j in 1:ncol(counts.epigaba)){
		plot(counts.all[,i], counts.epigaba[,j], pch = 16, xlab = colnames(counts.all)[i], ylab = colnames(counts.epigaba)[j], col = col_pal[as.factor(QCmetrics$Cell.type)])
		abline(a = 0, b = 1)
	}
}
dev.off()

##############
### Fourth ref panel Merge EpiGABA and Exeter FANS samples
##############

load("RefDataForCellCompEstimationAll.rdata")
counts.merge <- projectCellType(rawbetas[intersect(rownames(braincelldata), rownames(rawbetas)), ], braincelldata[intersect(rownames(braincelldata), rownames(rawbetas)),])

## plot results
pdf(paste0(qcOutFolder, "PredictedCellCompositionMergedRef.pdf"),width = 12)
par(mfrow = c(2,3))
for(each in cellTypes){
	barplot(t(counts.merge[which(QCmetrics$Cell.type == each),])*100, col = c("red", "blue", "green", col_pal[2:4]), main = each, ylab = "% estimated", names.arg = rep("", sum(QCmetrics$Cell.type == each)))
}
plot(0,1, type = "n", xlab = "", ylab = "", axes = FALSE)
legend("center", colnames(counts.merge), col = c("red", "blue", "green", col_pal[2:4]), pch = 15)

par(mfrow = c(2,3))
for(i in 1:ncol(counts.merge)){
	boxplot(counts.merge[,i]*100 ~ QCmetrics$Cell.type, col = c("red", "blue", "green", col_pal[2:4]), ylab = paste("%", colnames(counts.merge)[i], "estimated"), xlab = "Cell type")
}

dev.off()

##############
### Fifth ref c("GABAneurons","GLIA","GLUneurons","Sox10","IRF8")
### Fourth ref panel Merge EpiGABA and Exeter FANS samples
##############

load("RefDataForCellCompEstimationAllNoNeuN.rdata")
counts.merge4 <- projectCellType(rawbetas[intersect(rownames(braincelldata), rownames(rawbetas)), ], braincelldata[intersect(rownames(braincelldata), rownames(rawbetas)),])

## plot results
pdf(paste0(qcOutFolder, "PredictedCellCompositionMergedRefNoNeuN.pdf"),width = 12)
par(mfrow = c(2,3))
for(each in cellTypes){
	barplot(t(counts.merge4[which(QCmetrics$Cell.type == each),])*100, col = c("red", "blue", "green", col_pal[c(2,4)]), main = each, ylab = "% estimated", names.arg = rep("", sum(QCmetrics$Cell.type == each)))
}
plot(0,1, type = "n", xlab = "", ylab = "", axes = FALSE)
legend("center", colnames(counts.merge4), col = c("red", "blue", "green", col_pal[c(2,4)]), pch = 15)

par(mfrow = c(2,3))
for(i in 1:ncol(counts.merge4)){
	boxplot(counts.merge4[,i]*100 ~ QCmetrics$Cell.type, col = c("red", "blue", "green", col_pal[c(2,4)]), ylab = paste("%", colnames(counts.merge4)[i], "estimated"), xlab = "Cell type")
}

dev.off()

## compare with and without NeuN+ve
pdf(paste0(qcOutFolder, "ComparePredictedCellCompositionWithoutNeuN.pdf"),width = 12, height = 8)
par(mfrow = c(2,3))
for(each in c("GABAneurons","GLIA","GLUneurons","Sox10","IRF8")){
	plot(counts.merge[,each], counts.merge4[,each], pch = 16,main = each, xlab = "With NeuN", ylab = "Without NeuN", col = col_pal[as.factor(QCmetrics$Cell.type)])
	abline(a = 0, b = 1)
}
dev.off()


#options(error = recover, warn = 2)
#options(error = function() {traceback(2, max.lines=100); if(!interactive()) quit(save="no", status=1, runLast=T)})
#sink(stdout(), type="message")
#https://stackoverflow.com/questions/7485514/can-you-make-r-print-more-detailed-error-messages
#http://adv-r.had.co.nz/Exceptions-Debugging.html

##################################################
## Project: Comparison of BCI Papers
## Script purpose: Compare Frustration/Fun/Motivation/Control level between BCI papers
## Date: 01/07/2019
## Author: Bastian Ilso
##################################################
library(gsheet)
library(dplyr)
library(ggplot2)

# data import and prep ---------
url <- 'docs.google.com/spreadsheets/d/1EU_GgYr4gQ42Eks8QA5KPyyKwED1eQQRSUTx_PspfEM#gid=1516753331'
papers.data <- gsheet2tbl(url)

#import kiwi data
data<-read.csv("kiwiQuantReport.csv",header=TRUE,sep = ",")
data[is.na(data$shamChange),]$shamChange<-0
#<-data[!data$PID==2,]
data$shamRateCont<-as.numeric(data$shamRate)
data<-data[order(data$PID, data$shamRate),]
data$shamRate = factor(data$shamRate, levels=c("0", "15", "30"))
data$FrustNormalized = (data$FrustEpisode-1)/6
data$controlNormalized = (data$controlEpisode-1)/6
dfDataForPercFrustPlot<-papers.data[which(papers.data$Paper=='Laar-Hamster' | papers.data$Paper=='MED8-Kiwi'),]
data$Paper<-"MED8-KiwiRaw"
#<- papers.data[papers.data$Paper=='Laar-Hamster' | papers.data$Paper=='MED8-Kiwi',]

##Plot Level of Control vs Frustration Level ---------
##Plot Level of Control vs Frustration Level
papers.data %>%
  filter(!is.na(Frustration)) %>%
  group_by(Paper) %>%
  ggplot(aes(x=Control, y=Frustration, color=Paper)) +
  scale_colour_manual(values=c("#D55E00", "#009E73", "#0072B2", "#ad4141", "#ad4141", "#ad4141")) +
  scale_x_continuous(labels = scales::percent, limit=c(0,1)) +
  #xlim(0,1) +
  ylim(0,1) +
  geom_line(size=1.25) +
  geom_point(size=3.5) +
  theme_bw() +
  theme(legend.position = "none") +
  theme(panel.grid.major = element_line(size = 0.45, colour = "#d8d8d8"), panel.grid.minor = element_blank()) +
  theme(text = element_text(size = 12))

## SMALL VERSION ---------
##Plot Level of Control vs Frustration Level
papers.data %>%
  filter(!is.na(Frustration)) %>%
  filter(Paper != "MED8-Kiwi") %>%
  filter(Paper != "McCrea-Hockey") %>%
  group_by(Paper) %>%
  ggplot(aes(x=Control, y=Frustration, color=Paper)) +
  scale_colour_manual(values=c("#D55E00", "#009E73", "#0072B2", "#ad4141", "#ad4141", "#ad4141")) +
  scale_x_continuous(labels = scales::percent, limit=c(0,1)) +
  #xlim(0,100) +
  ylim(0,1) +
  geom_line(size=1.25) +
  geom_point(size=1.75) +
  theme_bw() +
  theme(panel.grid.major = element_line(size = 0.45, colour = "#d8d8d8"), panel.grid.minor = element_blank()) +
  theme(legend.position = "none") +
  theme(text = element_text(size = 12))

##Plot Level of Control vs Perceived Control --------
papers.data %>%
  filter(!is.na(`Perceived Control`)) %>%
  group_by(Paper) %>%
  ggplot(aes(x=Control, y=`Perceived Control`, color=Paper)) +
  scale_colour_manual(values=c("#000000", "#da995fff", "#f6b3b3", "#e79557", "#ad4141", "#da5f5fff", "#009E73", "#0072B2")) +
  scale_x_continuous(labels = scales::percent, limit=c(0,1)) +
  #xlim(0,1) +
  ylim(0,1) +
  #geom_hline(yintercept=1) +
  geom_line(size=1.25) +
  geom_point(size=3.5) +
  theme_bw() +
  theme(legend.position = "none") +
  theme(panel.grid.major = element_line(size = 0.45, colour = "#d8d8d8"), panel.grid.minor = element_blank()) +
  theme(text = element_text(size = 12))

## SMALL VERSION --------
##Plot Level of Control vs Perceived Control
papers.data %>%
  filter(!is.na(`Perceived Control`)) %>%
  filter(Paper != "MED8-Kiwi") %>%
  filter(Paper != "MED8-Kiwi-Interp") %>%
  filter(Paper != "McCrea-Hockey") %>%
  filter(Paper != "Greville-Causal1") %>%
  filter(Paper != "Greville-Causal2") %>%
  filter(Paper != "Greville-Causal3") %>%
  group_by(Paper) %>%
  ggplot(aes(x=Control, y=`Perceived Control`, color=Paper)) +
  scale_colour_manual(values=c("#000000", "#009c73", "#ad4141", "#ad4141", "#009c73", "#009c73","#009c73", "#009c73")) +
  scale_x_continuous(labels = scales::percent, limit=c(0,1)) +
  #xlim(0,1) +
  ylim(0,1) +
  geom_line(size=1.25) +
  geom_point(size=1.75) +
  theme_bw() +
  theme(panel.grid.major = element_line(size = 0.45, colour = "#d8d8d8"), panel.grid.minor = element_blank()) +
  theme(legend.title = element_blank()) +
  theme(legend.position = "none") +
  theme(text = element_text(size = 12))

##Plot Perceived Control vs Frustration --------
papers.data %>%
  filter(!is.na(`Perceived Control`)) %>%
  group_by(Paper) %>%
  ggplot(aes(x=`Perceived Control`, y=Frustration, color=Paper)) +
  scale_colour_manual(values=c("#000000", "#ad4141", "#f6b3b3", "#e79557", "#009E73", "#ad4141", "#009E73", "#0072B2")) +
  xlim(0,1) +
  ylim(0,1) +
  geom_line(size=1.25) +
  geom_point(size=3.5) +
  theme_bw() +
  theme(legend.position = "none") +
  theme(panel.grid.major = element_line(size = 0.45, colour = "#d8d8d8"), panel.grid.minor = element_blank()) +
  theme(text = element_text(size = 12))

##Plot Perceived Control vs Frustration plus raw data --------
  ggplot()+
    xlim(0,1) + ylim(0,1) +
geom_point(data=dfDataForPercFrustPlot, mapping=aes(x=`Perceived Control`,y=Frustration, color=as.factor(Paper), group=as.factor(Paper)), size=3.5) +
  geom_line(size=1.25) +
    geom_point(data = data,mapping=aes(x=controlNormalized,y=FrustNormalized,color=as.factor(shamRate), group=as.factor(Paper)),position = "jitter",width = 0.1, height = 0.1)+
    geom_smooth(data=data,mapping=aes(x=controlNormalized,y=FrustNormalized,color=shamRate,group=shamRate),method = lm, se = FALSE)+
  theme_bw() +
    theme(text = element_text(size = 12))

##Plot Perceived Control vs Frustration ony raw data med8 Kiwi --------
ggplot()+
  xlim(0,1) + ylim(0,1) +
  #    geom_point(data=dfDataForPercFrustPlot, mapping=aes(x=`Perceived Control`,y=Frustration, color=as.factor(Paper), group=as.factor(Paper)), size=3.5) +
  geom_line(size=1.25) +
  geom_point(data = data,mapping=aes(x=controlNormalized,y=FrustNormalized,size=as.numeric(as.character(shamRate)),color=as.numeric(as.character(shamRate))),position = "jitter",width = 0.05, height = 0.05)+
  geom_smooth(data=data,mapping=aes(x=controlNormalized,y=FrustNormalized,group=shamRate,color=as.numeric(as.character(shamRate))),method = lm, se = FALSE)+
  theme_bw() +
  theme(text = element_text(size = 12))

#aes(linetype=sex, color=sex)
#geom_smooth(geom_smooth(method = "lm", se = FALSE, linetype = "dashed")

##Plot Level of Control vs Fun/Motivation --------
papers.data %>% mutate(Motivation.Fun = coalesce(Fun, Motivation)) %>%
  filter(!is.na(Motivation.Fun)) %>%
  group_by(Paper) %>%
  ggplot(aes(x=Control, y=Motivation.Fun, color=Paper)) +
  scale_colour_manual(values=c("#D55E00", "#009E73", "#CC79A7", "#0072B2")) +
  xlim(0,1) +
  ylim(0,1) +
  geom_point() +
  geom_line()

## correlation/regression analysis of previous work
cor(papers.data[papers.data$Paper=="Laar-Hamster",]$`Perceived Control`,papers.data[papers.data$Paper=="Laar-Hamster",]$`Frustration`)
cor(papers.data[papers.data$Paper=="MED8-Kiwi",]$`Perceived Control`,papers.data[papers.data$Paper=="MED8-Kiwi",]$`Frustration`)

resLaar<- cor.test(papers.data[papers.data$Paper=="Laar-Hamster",]$`Perceived Control`, papers.data[papers.data$Paper=="Laar-Hamster",]$`Frustration`,
                   method = "pearson")
resLaar
resKiwi <- cor.test(papers.data[papers.data$Paper=="MED8-Kiwi",]$`Perceived Control`, papers.data[papers.data$Paper=="MED8-Kiwi",]$`Frustration`,
                    method = "pearson")
summary(lm(`Frustration`~`Perceived Control`, data=papers.data[papers.data$Paper=="Laar-Hamster",]))


library(Seurat)

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_TSNE_labels.rds"
h1 = readRDS(fn)

sig.list = readRDS("sig/sig.list.RDS")

df.subj = h1@meta.data %>% dplyr::mutate(response = str_remove(adjmfc.time, "d0 ")) %>%
  dplyr::select(subject=sampleid, response) %>%
  dplyr::mutate(subject = as.numeric(subject)) %>%
  distinct() %>%
  dplyr::arrange(subject)

sigs = c(rep("CD40.act",3), rep("SLE.sig",4), rep("IFN26",2), "TGSig", "LI.M165")
cl.name = c("C3.1.0", "C1", "C6", "C1", "C6", "C7", "C2", "C9", "C2.1.0", "C9", "C9")
cl.level = str_count(cl.name, "\\.")+1
sig.label = glue::glue("{sigs} ({cl.name})")
sig.label = sig.label %>% str_replace("SLE.sig", "SLE-Sig") %>%
  str_replace("CD40.act", "CD40act") %>% str_replace("IFN26", "IFN-I-DCact")

dn = "results/sig_scores"

df.scores = df.subj
for(s in seq_along(sig.label)) {
  cat(sig.label[s],"\n")
  fn = glue::glue("{dn}/scores_{sigs[s]}_{cl.level[s]}.txt")
  df = fread(fn) %>% dplyr::select("subject",cl.name[s])
  df.scores = left_join(df.scores, df, by="subject")
}
names(df.scores)[-(1:2)] = sig.label

# add CD38++ frequencies in flow
fn.flow = file.path("../generated_data/CHI/CHI_sample_info_2_CD38hi.txt")
df.flow = fread(fn.flow) %>%
  dplyr::filter(time==0) %>%
  dplyr::select(subject, `CD38hi (flow)` = CD38hi)

# add microarray scores
fn.ma = file.path("../generated_data/CHI/CHI_cd38_ge_sig_score_day0.txt")
df.ma = fread(fn.ma) %>%
  dplyr::select(subject, `TGSig (microarray)` = score)

fn.ma2 = file.path("results/sig_scores/scores_SLE.sig_MA.txt")
df.ma2 = fread(fn.ma2) %>%
  dplyr::select(subject, `SLE-Sig (microarray)` = SLE.sig)

df.scores = df.scores %>%
  left_join(df.flow, by="subject") %>%
  left_join(df.ma, by="subject") %>%
  left_join(df.ma2, by="subject")

fwrite(df.scores, "results/Score_table.txt", sep="\t")