##################################################################################
# Woldenberg a la Bonica
# This code runs a Bonica-like algorithm to provide a dynamic view of Woldenberg's
# IFE.  The first run has already been saved ("posterior-samples/wold23-window-results-compress.RData")
# March 19, 2013: Add party-based priors for councilors coming in from outside
##################################################################################

library (arm)
library (MCMCpack)
library (foreign)
library (car)
library (gtools)
#library (multicore)
library (R2jags)
library (mcmcplots)
library (sm)
library (lubridate)

rm(list = ls())
workdir <- c("/home/eric/Dropbox/data/rollcall/ife_cg/ife-update/data/")
setwd(workdir)

# Define colors and plotting names
ids <- matrix(c("Woldenberg", "woldenberg", "PRI", 23,
                "Barragán",   "barragan",   "PRD", 23,
                "Cantú",      "cantu",      "PRD", 23,
                "Cárdenas",   "cardenas",   "PRD", 23,
                "Lujambio",   "lujambio",   "PAN", 23,
                "Merino",     "merino",     "PRI", 23,
                "Molinar",    "molinar",    "PAN", 2 ,
                "Peschard",   "peschard",   "PRI", 23,
                "Zebadúa",    "zebadua",    "PRD", 2 ,
                "Rivera",     "rivera",     "PRI",  3,
                "Luken",      "luken",      "PAN",  3),
              ncol = 4,
              byrow = TRUE)
#
ids <- as.data.frame(ids, stringsAsFactors = FALSE)
colnames(ids) <- c("name", "column", "pty", "tenure")
ids$tenure <- as.numeric(ids$tenure)
ids <- within(ids, party <- ifelse (pty=="PRI", 1,
                            ifelse (pty=="PAN", 2,
                            ifelse (pty=="PRD", 3,
                            ifelse(pty=="PVEM", 4, 5)))))
ids <- within(ids, color <- ifelse (pty=="PRI", "red",
                            ifelse (pty=="PAN", "blue",
                            ifelse (pty=="PRD", "gold",
                            ifelse(pty=="PVEM", "green", "orangered4")))))

# select term 2, 3 or both
sel    <- grep(pattern = "[23]", ids$tenure)
name   <- ids$name[sel]
party  <- ids$party[sel]
color  <- ids$color[sel]
column <- ids$column[sel]

## rgb.23 <- c(length=11)
## rgb.23[c(1,6,8,10)] <- rgb(1,       0, 0, 0.6) #red
## rgb.23[c(2:4,9)]    <- rgb(1, 215/255, 0, 0.6) #gold
## rgb.23[c(5,7,11)]   <- rgb(0,       0, 1, 0.6) #blue

###############################################################################
## Read votes (includes informative votes only, exported by code/data-prep.r ##
###############################################################################
vot <-read.csv("v23.csv",  header=TRUE)
#
# subset to chosen periods
sel.r <- which(vot$term %in% 2:3)
drop.c <- ids$column[grep(pattern = "[23]", ids$tenure)] # column names not in terms 2-3
drop.c <- setdiff(ids$column, drop.c)
drop.c <- which(colnames(vot) %in% drop.c)
if (length(drop.c)>0) vot <- vot[sel.r, -drop.c]
colnames(vot)
# total members
J <- length(name)

########################
## recode vote values ##
########################
vs <- vot[,1:J]
#table(v$albo, useNA = "always")
vs[vs==0] <- NA    ## Version probit requiere 0s y 1s
vs[vs>2] <- NA
vs[vs==2] <- 0

# format dates
vot$date <- ymd(vot$date)
# summarize then drop uncontested votes
table(factor(vot$dunan, labels = c("contested","not")), vot$term, useNA = "ifany")
table(factor(vot$dunan, labels = c("contested","not")), useNA = "ifany")
sel <- which(vot$dunan==1)
vot <- vot[-sel,] # drop uncontested votes
vs  <- vs [-sel,] # drop uncontested votes

###########################
###     WOLDENBERG      ###
###########################

## MODEL
model1Dj.irt <- function() {
	for (j in 1:J){                ## loop over respondents
		for (i in 1:I){              ## loop over items
			v[j,i] ~ dbern(p[j,i]);                                 ## voting rule
			probit(p[j,i]) <- mu[j,i];                              ## sets 0<p<1 as function of mu
			mu[j,i] <- signal[i]*x[j] - difficulty[i];              ## utility differential
		}
	}
	## priors ################
	for (j in 1:J){
		x[j] ~ dnorm (x.mean[j], x.tau[j]);
	}
	for (i in 1:I){
		signal[i] ~ dnorm(0, 0.1);
		difficulty[i] ~ dnorm(0, 0.25);
	}
	for (p in 1:3){
		partyPos[p] <- mean (x[party[p]]); # 4mar21: should be median, unknown function in bugs?
	}
}
#end model##############

# Center on vote (for date), extend windows to both sides
I <- nrow(vot)
item <- 1:I
inicio <- item-15; inicio[inicio<0] <- 0
final  <- item+15; final[final>I] <- I
item.date <- vot$date
S <- length(inicio)

# Added March 19: We need a matrix showing whether each councilor is actually in IFE the moment the vote takes place
IsCouncilor <- matrix (1, ncol=J, nrow=S)
IsCouncilor[item.date > ymd(20001114), c(7,9)] <- NA # Last Molinar, Zebadua vote
IsCouncilor[item.date < ymd(20010130), c(10,11)] <- NA # First Rivera, Luken vote

# Initial ideal points to anchor ideological space
x.location <- c(1,2,0,-2,rep(0,7))
x.precision  <- c(4,4,1,4,rep(1,7))
window.results <- list () ## ADD SESSION'S RESULTS TO OBJECT HOLDING ALL RESULTS
partyPlacement <- rep (NA,11)
x.mean <- numeric ()
x.tau  <- numeric ()

s <- 1
## Save overall totals for use later (I J redefined to window s totals in next loop)
J.all <- J; I.all <- I
for (s in 1:S){        # <= BIG FUNCTION STARTS (loop over 552 windows)

	# Added March 19: We include councilors (and their party IDs) only if they were actual councilors for at least one vote
	# This means that the length of estimated ideal points is either
	# 9 (for most votes) or 11 (when there is some overlap: two councilors are leaving , two are coming in)
	councilor.in <- apply (IsCouncilor[inicio[s]:final[s],], 2, invalid)
	councilors   <- name [councilor.in==FALSE]
	sponsors     <- party[councilor.in==FALSE]

	for (c in 1:J.all){
		x.mean[c] <- ifelse (!is.na(x.location[c]), x.location[c], partyPlacement[sponsors[c]])
		x.tau[c]  <- ifelse (!is.na(x.precision[c]), x.precision[c], 4)
	}

	v <- vs[inicio[s]:final[s], 1:J.all][, councilor.in==FALSE]; ## EXTRACT 30 VOTES EACH TIME
	v <- t(v)                       ## ROLL CALLS NEED ITEMS IN COLUMNS, LEGISLATORS IN ROWS
	J <- nrow(v); I <- ncol(v)      ## SESSION TOTALS

	ife.data <- list ("J", "I", "v", "x.mean", "x.tau", "party")
	ife.inits <- function (){
		list (
			x=rnorm(J),
			signal=rnorm(I),
			difficulty=rnorm(I)
		)
	}
	ife.parameters <- c("x", "signal", "difficulty", "partyPos")

	print(cat("Session no.", s, "of", S, ", with", I, "votes \n"))

	#full JAGS run
	start.time <- proc.time()

	# Use dual core capabilities
	results <-
#            mclapply(1:2, function(x) {
#		model.jags.re <- try(
                                 jags (data=ife.data, inits=ife.inits, ife.parameters,
								   model.file=model1Dj.irt, n.chains=1,
#								   model.file=model1Dj.irt, n.chains=2,
#								   n.iter=600, n.burnin=300, n.thin=30)
								   n.iter=20000, n.burnin=10000, n.thin=100)
#		)
#		if(inherits(model.jags.re,"try-error")) {return()}
#		return(model.jags.re)
#	}, mc.cores=2 )
	time.elapsed <- round(((proc.time()-start.time)[3])/60,2); rm(start.time)
	print(cat("\tTime elapsed in estimation:", time.elapsed, "minutes", "\n")); rm(time.elapsed)

	# ADD COUNCILOR NAMES AND VOTE INFO TO RESULTS OBJECT
        results <- c(results, councilors=list(councilors)); # should be faster than results[[length(results)+1]] <- councilors;
        results <- c(results, folio.date=list(vot[s,c("folio","dy","mo","yr")])); # add vote on which window is centered
        window.results <- c(window.results, list(results)); # should be faster than window.results[length(window.results)+1] <- list(results) ## ADD SESSION'S RESULTS TO OBJECT HOLDING ALL RESULTS

	# Update location of ideal point at time s, to be used as location prior at time s+1
	x.location  <- rep (NA, J.all)
	x.precision <- rep (100, J.all)
#	locs <- apply( rbind (results[[1]]$BUGSoutput$sims.list$x, results[[2]]$BUGSoutput$sims.list$x), 2, median)
#	partyPlacement <- apply( rbind (results[[1]]$BUGSoutput$sims.list$partyPos, results[[2]]$BUGSoutput$sims.list$partyPos), 2, median)
	locs <- apply( results$BUGSoutput$sims.list$x, 2, median)
	partyPlacement <- apply( results$BUGSoutput$sims.list$partyPos, 2, median)
	for (n in 1:J.all){
		if (length( which(councilors==name[n]) )==0) {               # if councilor not member current round
			x.location[n] <- NA                                  # then prior for next round set to NA
			x.precision[n] <- NA                                 # (and line above sets it to party placement)
		}
		else { x.location[n] <-  locs[which (councilors==name[n])] } # councilor's prior for next round is current x
	}
	# Precision prior is always constant at 100, implying standard deviation = sqrt (1/100) = 0.1
}  # <---   END OF LOOP OVER WINDOWS
## Restore overall totals
J <- J.all; I <- I.all; rm(J.all, I.all)

# rename object with posterior sims
window.results.23 <- window.results
ls()
rm(window.results)

# clean
ls()
rm(c, s, n, i, v, sel, ife.inits, ife.parameters, ife.data)
rm(councilors, sponsors, inicio, final, councilor.in)
rm(x.location, x.mean, x.precision, x.tau, item, results, item.date)
rm(color, column, locs, name, party, partyPlacement)

# save
summary(window.results)
summary(window.results[[231]]) # 9 members
summary(window.results[[232]]) # 11 members, overlap
save.image(file = "posterior-samples/wold23-window-results-compress.RData", compress = "xz")
#save(window.results.23, file = "posterior-samples/wold23-window-results-compress.RData")
x

# Save semester.results, containing all chains from all runs
# save (semester.results, file="DynWoldenbergBonicaMarch19.RData")
# save (semester.results, file="DynWoldenbergBonica.RData")

# RData file with runs carried out in Mexico, early March
# load ("DynWoldenbergBonica.RData")

# RData file with runs carried out in Wash U, March 19
# These runs omit non-sitting Councilors and party precisions for new Councilors
load ("DynWoldenbergBonicaMarch19.RData")

S <- length(semester.results)

multiGelman.hat <- numeric ()
for (i in 1:S){
	chainsConv <- mcmc.list(list (as.mcmc (semester.results[[i]][[2]]$BUGSoutput$sims.list$x), as.mcmc (semester.results[[i]][[1]]$BUGSoutput$sims.list$x)))
	tmp <- gelman.diag (chainsConv)[[2]]
	multiGelman.hat <- c(multiGelman.hat, tmp)
}
summary (multiGelman.hat)
rm (tmp, chainsConv)

CouncilorIn <- matrix (1, nrow=11, ncol=S)
#CouncilorIn[c(7,9),  all23$date[-c(1:29)] > 20001114] <- NA # Last Molinar, Zebadua vote
#CouncilorIn[c(10,11),all23$date[-c(1:29)] < 20010130] <- NA # First Rivera, Luken vote
CouncilorIn[c(7,9),  item.date > ymd(20001114)] <- NA # Last Molinar, Zebadua vote
CouncilorIn[c(10,11), item.date < ymd(20010130)] <- NA # First Rivera, Luken vote

# If using DynWoldenbergBonica.RData, use the following code to extract ideal points
ideal.points <- matrix (NA, nrow=S, ncol=11)
for (i in 1:S){
	ideal.points[i,] <- apply (rbind (semester.results[[i]][[1]]$BUGSoutput$sims.list$x, semester.results[[i]][[2]]$BUGSoutput$sims.list$x), 2, median)
}

# If using DynWodenbergBonicaMarch19.RData, use the following code to extract ideal points
ideal.points <- matrix (NA, nrow=S, ncol=11)
ideal.points.var <- matrix (NA, nrow=S, ncol=11)
for (i in 1:S){
 	for (j in 1:11){
 		councilor <- name[j]
 		num <- which (semester.results[[i]][[3]]==councilor)
 		if ( length (num)==0 ) {
 			ideal.points[i,j] <- 1
			ideal.points.var[i,j]  <- 0
 		} else {
 			ideal.points[i,j] <- median (c (semester.results[[i]][[1]]$BUGSoutput$sims.list$x[,num], semester.results[[i]][[2]]$BUGSoutput$sims.list$x[,num]))
 			ideal.points.var[i,j]  <- var (c (semester.results[[i]][[1]]$BUGSoutput$sims.list$x[,num], semester.results[[i]][[2]]$BUGSoutput$sims.list$x[,num]))
 		}
 	}
}

# Get SDs of estimates, the width should be useful to plot thickness of data points
ideal.points.var <- sqrt (ideal.points.var)

# Non-smoothed ideal point time-paths
plot(c(1:S), ideal.points[1:S,1], main="", ylim=c(-3,3), type="n", xlab="", ylab="Ideal points")
for (j in 1:11){
	lines(CouncilorIn[j,1:S] * ideal.points[1:S,j], lwd=4, col=color.23[j])
}

# Item indices closest to federal elections
fedEls.items <- c(
min(which(abs(item.date-ymd(19970706))==min(abs(item.date-ymd(19970706))))),
min(which(abs(item.date-ymd(20000702))==min(abs(item.date-ymd(20000702))))),
min(which(abs(item.date-ymd(20030706))==min(abs(item.date-ymd(20030706)))))
#min(which(abs(item.date-ymd(20060702))==min(abs(item.date-ymd(20060702))))),
#min(which(abs(item.date-ymd(20090705))==min(abs(item.date-ymd(20090705))))),
#min(which(abs(item.date-ymd(20120701))==min(abs(item.date-ymd(20120701)))))
    )

# Item indices closest to New Years
newYear.items <- c(
min(which(abs(item.date-ymd(19970101))==min(abs(item.date-ymd(19970101))))),
min(which(abs(item.date-ymd(19980101))==min(abs(item.date-ymd(19980101))))),
min(which(abs(item.date-ymd(19990101))==min(abs(item.date-ymd(19990101))))),
min(which(abs(item.date-ymd(20000101))==min(abs(item.date-ymd(20000101))))),
min(which(abs(item.date-ymd(20010101))==min(abs(item.date-ymd(20010101))))),
min(which(abs(item.date-ymd(20020101))==min(abs(item.date-ymd(20020101))))),
min(which(abs(item.date-ymd(20030101))==min(abs(item.date-ymd(20030101)))))
## min(which(abs(item.date-ymd(20040101))==min(abs(item.date-ymd(20040101))))),
## min(which(abs(item.date-ymd(20050101))==min(abs(item.date-ymd(20050101))))),
## min(which(abs(item.date-ymd(20060101))==min(abs(item.date-ymd(20060101))))),
## min(which(abs(item.date-ymd(20070101))==min(abs(item.date-ymd(20070101))))),
## min(which(abs(item.date-ymd(20080101))==min(abs(item.date-ymd(20080101))))),
## min(which(abs(item.date-ymd(20090101))==min(abs(item.date-ymd(20090101))))),
## min(which(abs(item.date-ymd(20100101))==min(abs(item.date-ymd(20100101))))),
## min(which(abs(item.date-ymd(20110101))==min(abs(item.date-ymd(20110101))))),
## min(which(abs(item.date-ymd(20120101))==min(abs(item.date-ymd(20120101)))))
    )

# Item indices for entry/exit from council
inNout <- matrix (NA, nrow=11, ncol=S)
for (j in 1:11){
  inNout[j,min(which(CouncilorIn[j,]==1))] <- min(which(CouncilorIn[j,]==1))
  inNout[j,max(which(CouncilorIn[j,]==1))] <- max(which(CouncilorIn[j,]==1))
}

# Function captures smooth.spline ideal point coordinates: Smooth[[j]]$x[1:s], Smooth[[j]]$y[1:s] give vote s's
Smooth <- list ()
for (j in 1:11){
#	Smooth[[j]] <- smooth.spline(c(1:S), ideal.points[,j], df=10)
        Smooth[[j]] <- smooth.spline(c(1:S)[!is.na(CouncilorIn[j,1:S])], ideal.points[!is.na(CouncilorIn[j,1:S]),j], df=10)
}

for (j in 1:11){
	Smooth[[j]]$y[is.na(CouncilorIn[j,1:S])] <- NA
}

# Smoothed ideal point time-paths
err <- ideal.points.var*2/max(ideal.points.var) ## estimate error
spaghetti.graph <- function(progress=S){
#pdf(paste(graphdir,"woldBonicaSmoothError.pdf",sep=""), width=7, height=7)
plot(c(1:S), ideal.points[1:S,1], main="", ylim=c(-3,3), type="n", xlab="Divided vote", ylab="Ideal points")
axis(3, at=newYear.items, labels = 1997:2003, cex.axis=.6)
abline(v=fedEls.items, lty=3, col="grey50")
text(rep(fedEls.items, times=2), c(rep(3.1,times=3),rep(2.925,times=3)), c("midterm","presidential","midterm",rep("election",3)), adj=0, cex=.65, pos=1, col="grey30")
for (j in 1:11){
       points(1:progress, Smooth[[j]]$y[1:progress], cex=.3, col=color.23[j])
#       points(1:progress, Smooth[[j]]$y[1:progress], cex=err[,j], col=color.23[j])
#	lines(1:progress, Smooth[[j]]$y[1:progress], lwd=3, col=color.23[j])
#        points(inNout[j,], Smooth[[j]]$y, pch=19, col=color.23[j])
}
text(-15,Smooth[[2]]$y[1]+.15,c("Barragán"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[1]]$y[1]+.4,c("Woldenberg"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[1]]$y[1]+.25,c("Peschard"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[1]]$y[1]+.1,c("Merino"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[7]]$y[30],c("Molinar"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[9]]$y[15],c("Zebadúa"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[5]]$y[1]-.25,c("Lujambio"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[5]]$y[1]-.4,c("Cantú"), pos=4, adj=0, cex=.75, col="black")
text(-15,Smooth[[4]]$y[70],c("Cárdenas"), pos=4, adj=0, cex=.75, col="black")
text(233-15,Smooth[[10]]$y[233]-.125,c("Rivera"), pos=4, adj=0, cex=.75, col="black")
text(233-15,Smooth[[11]]$y[233]+.075,c("Luken"), pos=4, adj=0, cex=.75, col="black")
#dev.off()
}

spaghetti.graph()

# Smoothed ideal point time-paths, daily change movie
snapshot <- seq (3, 553, by=5)
for (s in snapshot){
	which.s <- which (snapshot==s)
	if (which.s < 10) {name = paste('Wolden00', which.s,'plot.png',sep='')}
	if (which.s >= 10 && which.s < 100) {name = paste('Wolden0', which.s,'plot.png', sep='')}
	if (which.s >= 100) {name = paste('Wolden', which.s,'plot.png', sep='')}

	jpeg (paste(graphdir, "animBits/", name, sep=""), quality=100, height=500, width=500)

        spaghetti.graph(s)

	## plot(c(1:S), ideal.points[1:S,1], main="", ylim=c(-3,3), type="n", xlab="", ylab="Ideal points")
	## for (j in 1:11){
	## 	lines ( Smooth[[j]]$x[1:s], Smooth[[j]]$y[1:s], lwd=6, col=color.23[j])
	## }
	legend ("bottomright", bty="n", xjust=0, legend=paste ("vote date:", item.date[s], sep=" ")) #Change the legend for the date of the vote
	dev.off()
}

# Make a short film
# The number after loop controls the number of automatic replays (0 stands for infinite loop)
# The number after delay determines length of transition between slides)
setwd(paste(graphdir,"animBits/", sep=""))
system ("convert -loop 1 -delay 20 *.png IFEwoldenTheMovie.gif")
setwd(workdir)

###########################
#  Regression analysis
# Identify first Sunday in July for election years
election.dates <- c(19970706,20000702,20030706,20060702,20090705,20120701)
ymd (20130308) - ymd (20130307)

Dates <- matrix (NA, nrow=length(all23$date), ncol=length(election.dates))
for (i in 1:6){
	for (j in 1:length(all23$date)){
		Dates[j,i] <- ymd (election.dates[i]) - ymd (all23$date[j])
	}
}

Date2NextElection <- numeric ()
for (i in 1:length(all23$date)){
	Date2NextElection[i] <- min (Dates[i,][Dates[i,]>0])
}
rm (Dates)
Date2NextElection <- Date2NextElection[-c(1:29)]

Ideal.Points <- matrix (NA, ncol=ncol(ideal.points), nrow=nrow(ideal.points))
for (j in 1:ncol(ideal.points)){
	Ideal.Points[,j] <- CouncilorIn[j,] * ideal.points[,j]
}

WD.PRI <- WD.PRD <- WD.PAN <- numeric ()
for (i in 1:nrow(Ideal.Points)){
	WD.PRI[i]  <- max(Ideal.Points[i,color.23=="red"], na.rm=T) - min(Ideal.Points[i,color.23=="red"], na.rm=T)
	WD.PRD[i]  <- max(Ideal.Points[i,color.23=="gold"], na.rm=T) - min(Ideal.Points[i,color.23=="gold"], na.rm=T)
	WD.PAN[i]  <- max(Ideal.Points[i,color.23=="blue"], na.rm=T) - min(Ideal.Points[i,color.23=="blue"], na.rm=T)
}

AV.PRI <- AV.PRD <- AV.PAN <- numeric ()
for (i in 1:nrow(Ideal.Points)){
	AV.PRI[i] <- mean(Ideal.Points[i,color.23=="red"], na.rm=T)
	AV.PRD[i] <- mean(Ideal.Points[i,color.23=="gold"], na.rm=T)
	AV.PAN[i] <- mean(Ideal.Points[i,color.23=="blue"], na.rm=T)
}

PAN.PRD <- PRD.PRI <- PRI.PAN <- numeric ()
for (i in 1:nrow(Ideal.Points)){
	PAN.PRD[i] <- AV.PAN[i] - AV.PRD[i]
	PRD.PRI[i] <- AV.PRD[i] - AV.PRI[i]
	PRI.PAN[i] <- AV.PRI[i] - AV.PAN[i]
}

mod <- lm (PRI.PAN ~ Date2NextElection + I(Date2NextElection^2))
plot (PRI.PAN, type="l", lwd=2)
abline (v=c(163,493))

mod <- lm (PAN.PRD ~ Date2NextElection + I(Date2NextElection^2))
plot (PAN.PRD, type="l", lwd=2)
abline (v=c(163,493))

mod <- lm (PRD.PRI ~ Date2NextElection + I(Date2NextElection^2))
plot (PRD.PRI, type="l", lwd=2)
abline (v=c(163,493))


#seurat()

make_edges = function(data, pairs, subset=NULL, binary=FALSE, symmetric=TRUE, max_cells_per_gene=2, verbose=TRUE){

    # this function creates a (cells x cells) edge matrix
    # weights wij are calculated as the product of the node weights, wij=wi*wj
    # input arguments:
    # data = (cells x genes) weights matrix or (cells, genes, weights) list
    # pairs = (gene, gene) list
    # subset = (gene -> cells) list

    library(Matrix)
    library(tidyr)
    library(data.table)

    # format data
    if(ncol(data) == 3){
        colnames(data) = c('cell', 'gene', 'value')
	data = data.frame(spread(data, gene, value, fill=0), row.names=1)
	data = as(as.matrix(data), 'sparseMatrix')
    }
    print(dim(data))

    # make binary
    if(binary == FALSE & max(data) > 1){
        print('[warning] max(data) > 1')
    }

    if(binary == TRUE){
        data = data > 0
    }

    # remove promiscuous genes
    data = data[,colSums(data > 0, na.rm=T) <= max_cells_per_gene]
    print(dim(data))

    # make adjacency matrix
    cells = rownames(data)
    A = matrix(0, nrow=length(cells), ncol=length(cells))
    rownames(A) = colnames(A) = cells

    # make labels
    L = sapply(cells, function(a) sapply(cells, function(b) c(), simplify=F), simplify=F)

    # add edges
    count = 0
    for(i in 1:nrow(pairs)){
        u = as.character(pairs[i,1]) # source gene
	v = as.character(pairs[i,2]) # target gene
	if(u %in% colnames(data) & v %in% colnames(data)){

	    Ai = data[,u] %*% t(data[,v])

	    if(!is.null(subset)){

	        # subset on gene u
		Au = Ai
		i = rownames(data) %in% subset[[u]]
		Au[!i,] = 0

		# subset on gene v
		Av = Ai
		i = rownames(data) %in% subset[[v]]
		Av[!i,] = 0

		# sum components
		Ai = Au + Av

		# skip on empty
		if(sum(Ai) == 0){
		    next
		}
	    }

	    if(symmetric == TRUE){
	        Ai = Ai + t(Ai)
	    }

	    A = A + Ai

	    # update labels
	    cells1 = rownames(data)[data[,u] > 0]
	    cells2 = rownames(data)[data[,v] > 0]
	    for(ca in cells1){
	        for(cb in cells2){
		    L[[ca]][[cb]] = c(L[[ca]][[cb]], paste(u, v, sep='-'))
		    if(symmetric == TRUE){
		        L[[cb]][[ca]] = c(L[[cb]][[ca]], paste(u, v, sep='-'))
		    }
		}
	    }

	    # print message
	    if(verbose == TRUE){
	        print(paste0('Edge: ', u, ', ', v, ' (', paste(cells1, collapse=', '), ') <--> (', paste(cells2, collapse=', '), ')'))
	    }
	    count = count + 1
        }
    }

    # fix labels
    for(ca in names(L)){
        for(cb in names(L[[ca]])){
	    L[[ca]][[cb]] = unique(L[[ca]][[cb]])
	}
    }

    print(paste(count, 'total interactions'))
    return(list(edges=A, labels=L))
}

rescale_vector = function(x, target=c(0, 1), f=identity, abs=FALSE){
    # map vector onto target interval, then apply f
    if(min(target) == max(target)){
        return(rep(max(target), length(x)))
    }
    a = target[[1]]
    b = target[[2]]
    if(min(x) == max(x)){
        rep(max(target), length(x))
    } else {
        if(abs == TRUE){
            x = (x - min(abs(x)))/(max(abs(x)) - min(abs(x)))*(b - a) + a
	} else {
            x = (x - min(x))/(max(x) - min(x))*(b - a) + a
	}
        f(x)
    }
}

plot_network = function(mat=NULL, edges=NULL, lab=NULL, f_weights=identity, rescale_weights=c(0,1), f_coords=identity, rescale_coords=c(0,1), alpha=1, remove_self=FALSE,
                        edge.label.cex=1, vertex.label.cex=1, node_color=NULL){

    # plot network diagram from matrix or edgelist
    # mat = (source x target) weights matrix
    # edges = (source, target, weight) edgelist
    # lab = list(source -> target -> label)

    library(igraph)
    library(data.table)
    library(tidyverse)

    # convert matrix to edges
    if(!is.null(mat)){
        edges = gather(as.data.frame(mat) %>% rownames_to_column('source'), target, weight, -source)
    }

    # select edges
    edges = data.frame(as.data.table(edges)[,.SD[which.max(abs(weight))],.(source, target)], stringsAsFactors=F)
    edges$source = as.character(edges$source)
    edges$target = as.character(edges$target)

    # remove zeros and de-duplicate
    edges = edges[edges$weight != 0,]
    i = apply(edges, 1, function(a) paste(sort(c(a[[1]], a[[2]])), collapse=' '))
    edges = edges[!duplicated(i),]

    # modify edges
    edges$weight = f_weights(edges$weight)

    # delete zero and self edges
    edges = edges[abs(edges$weight) > 0,]
    if(remove_self == TRUE){
        edges = edges[edges$source != edges$target,]
    }

    # get nodes
    nodes = data.frame(id=sort(unique(c(edges[,1], edges[,2]))), stringsAsFactors=F)

    # adjust edges
    if(all(edges$weight > 0)){
        edges$color = '#000000'
    } else {
        edges$color = ifelse(edges$weight > 0, 'blue', 'red')
        edges$weight = abs(edges$weight)
    }

    # make graph
    g = graph.data.frame(d=edges, vertices=nodes, directed=FALSE)
    if(!is.null(node_color)){
        V(g)$color = node_color[names(V(g))]
    } else {
        V(g)$color = '#cccccc'
    }
    l = layout_with_fr(g, weight=abs(edges$weight) > 0)

    # make labels
    lab = cbind(l, nodes)
    colnames(lab) = c('x', 'y', 'lab')

    # rescale coordinates
    l = apply(l, 2, function(a) rescale_vector(a, target=rescale_coords, f=f_coords, abs=TRUE))

    # rescale edge widths
    w = edges$weight
    w = rescale_vector(w, target=rescale_weights, f=f_weights, abs=TRUE)

    # plot and save
    plot(g, edge.width=w, vertex.color=V(g)$color, edge.color=E(g)$color, edge.label=E(g)$label, edge.label.color='black', vertex.label.color='black', layout=l,
         edge.label.cex=edge.label.cex, vertex.label.cex=vertex.label.cex)

}

ggplot_network = function(graph=NULL, edges=NULL, node_sizes=NULL, node_colors=NULL, edge_color='#cccccc', edge_colors=NULL, scale_nodes=c(4,4), scale_edges=c(.5,.5), curvature=0,
                          smin=NULL, smax=NULL,
                          alpha=1, symm=TRUE, do.legend=TRUE, legend_title=NULL, out=NULL, nrow=1, ncol=1, qmax=1, ggtitle='', layout='fruchtermanreingold', layout.weights=TRUE, plot.weights=TRUE,
			  node.size.title='', lab.use=NULL, ret.graph=FALSE){

    library(ggplot2)
    library(tidyverse)
    library(cowplot)
    library(ggnetwork)
    source('~/code/single_cell/colors.r')

    # plot network from graph or edgelist
    # -----------------------------------
    # graph = [m x n] matrix
    # edges = data.frame(1=source, 2=target, 3=weight, 4=color)
    # node_sizes = list(node_label = size)
    # node_colors = list(node_label = color)
    # edge_colors = [m x n] matrix
    # scale_nodes = c(min, max)
    # scale_edges = c(min, max)

    # convert graph to edgelist
    if(!is.null(graph)){
        graph = as.data.frame(as.matrix.data.frame(as.data.frame(graph)))
	edges = gather(graph %>% rownames_to_column('source'), target, weight, -source)
    }
    if(ncol(edges) == 3){colnames(edges) = c('source', 'target', 'weight')}

    # convert colors to edgelist
    if(!is.null(edge_colors)){
        edge_colors = as.data.frame(as.matrix.data.frame(as.data.frame(edge_colors)))
	edge_colors = gather(edge_colors %>% rownames_to_column('source'), target, color, -source)
	edges = merge(edges, edge_colors, by=c('source', 'target'))
    }
    if(! 'color' %in% colnames(edges)){edges$color = edge_color}

    # convert node_sizes to list
    nodes = sort(unique(c(as.character(edges$source), as.character(edges$target))))
    if(!is.null(node_sizes) & is.null(names(node_sizes))){names(node_sizes) = rownames(graph)} # assume graph
    if(is.null(node_sizes)){node_sizes = setNames(rep(1, length(nodes)), nodes)}

    # convert node_colors to list
    if(is.null(node_colors)){
        node_colors = setNames(rep(1, length(nodes)), nodes)
    } else {
        if(length(node_colors) == 1){
	    node_colors = setNames(rep(node_colors, length(nodes)), nodes)
	}
	if(is.null(names(node_colors))){names(node_colors) = rownames(graph)}
    }
    node_colors = as.factor(node_colors)

    # remove duplicate edges
    if(symm == TRUE){
        i = apply(edges[,1:2], 1, function(a) paste(sort(a), collapse=' '))
	edges = edges[!duplicated(i),]
    }

    # adjust edge weights
    edges = edges[edges$weight > 0,,drop=F]
    edges = edges[edges$source != edges$target,,drop=F]
    if(!is.null(scale_edges)){
        edges$weight = rescale_vector(edges$weight, target=scale_edges, abs=TRUE)
    }

    # convert edges to igraph object
    g = graph.data.frame(edges)

    # vertex attributes / igraph craziness
    nodes = V(g)$name

    # node sizes
    node_sizes = node_sizes[nodes]
    V(g)$node_size = node_sizes
    if(is.null(smin)){smin = min(node_sizes)}
    if(is.null(smax)){smax = max(node_sizes)}
    if(smin == smax){size_guide=FALSE} else {size_guide=TRUE}

    # node colors
    i = levels(node_colors)
    node_colors = node_colors[nodes]
    levels(node_colors) = i
    V(g)$node_color = as.character(node_colors)

    # igraph -> data.frame for ggplot2
    if(layout.weights == TRUE){
        net = ggnetwork(g, layout=layout, weights='weight', arrow.gap=1)
    } else {
        net = ggnetwork(g, layout=layout, arrow.gap=1)
    }

    if(nlevels(node_colors) > 0){
        net$node_color = factor(net$node_color, levels=levels(node_colors))
    }

    if(plot.weights == FALSE){
        net$weight[!is.na(net$weight)] = 1
    }
    return(net)
    # plot with ggnetwork
    if(is.null(out)){alpha = 1}

    if(length(unique(net$node_color)) > 1){
        p = ggplot(net, aes(x=x, y=y, xend=xend, yend=yend)) +
            geom_edges(color='#cccccc', size=na.omit(net$weight), alpha=alpha, curvature=curvature) +
            geom_nodes(aes(color=node_color, size=node_size)) +
            scale_color_manual(legend_title, breaks=levels(net$node_color), labels=levels(net$node_color), values=set.colors, drop=FALSE) +
	    scale_size(node.size.title, range=scale_nodes, limits=c(smin, smax), guide=size_guide)
    } else {
        p = ggplot(net, aes(x=x, y=y, xend=xend, yend=yend)) +
            geom_edges(color=na.omit(net$color), size=na.omit(net$weight), alpha=alpha, curvature=curvature) +
            geom_nodes(color='#0191C8', aes(size=node_size)) +
	    scale_size(node.size.title, range=scale_nodes, limits=c(smin, smax), guide=size_guide) +
	    scale_color_manual(guide=F)
    }

    if(is.null(lab.use)){
        lab.use = net$vertex.names
    }
    p = p + geom_nodetext_repel(aes(label=ifelse(vertex.names %in% lab.use, as.character(vertex.names), ''))) + theme_blank()

    if(ggtitle != ''){p = p + ggtitle(ggtitle)}

    if(do.legend == FALSE){p = p + theme(legend.position='none')}

    if(!is.null(out)){save_plot(p, file=out, nrow=nrow, ncol=ncol)}

    if(ret.graph == FALSE){p} else {list(p=p, g=g)}
}

nice_network = function(graph=NULL, edges=NULL, symm=TRUE, self=FALSE,
	                layout='fruchtermanreingold', layout_weights=TRUE,
			size_legend='nodes', size_trans='identity', # 'log2', etc
                        node_colors=NULL, node_sizes=NULL, node_scale=c(5,5), node_limits=NULL, node_alpha=1, node_pal=NULL, node_padding=.5, node_strokes=0.25,
			edge_colors=NULL, edge_alpha=1, edge_scale=c(.5,.5), edge_limits=NULL, edge_pal=NULL, color_sign=FALSE, edge_padding=.5, linewidth_pal=1:6,
			node_guide='legend', edge_guide='legend', size_guide='legend', linetype_guide='legend', do.legend=TRUE,
			node_title='', edge_title='', size_title='', linetype_title='',
			lab.use=NULL, node_lab.size=4, edge_lab.size=3, segment.color='grey',
			ggtitle='', drop_levels=FALSE, out=NULL, nrow=1, ncol=1, ret.data=FALSE,
			do.arrow=FALSE, arrow.gap=.015
			) {

    library(ggplot2)
    library(cowplot)
    library(ggnetwork)
    library(igraph)
    library(ggrepel)
    library(tidyverse)
    source('~/code/single_cell/colors.r')

    # plot network from graph or edgelist
    # -----------------------------------
    # graph = [m x n] matrix
    # edges = data.frame(1=source, 2=target, 3=weight, 4=color, 5=size, 6=label, 7=linetype, ...)
    # lab.use = list of node/edge labels to use
    # node_sizes = list(label=size)
    # node_colors = list(label=color)
    # edge_colors = [m x n] matrix
    # node_scale = c(min, max)  * scales specify the minimum and maximium size of the plotting symbol
    # edge_scale = c(min, max)
    # node_limits = c(min, max) * limits specify the minimum and maximum size of the value being plotted
    # edge_limits = c(min, max)

    # set arrow parameters
    # --------------------
    if(do.arrow == FALSE){
        arrow = NULL
	arrow.gap = 0
    } else {
        arrow = arrow(length=unit(6, "pt"), type="closed")
	arrow.gap = arrow.gap
    }

    # construct edgelist
    # ------------------
    if(!is.null(graph)){
        graph = as.data.frame(as.matrix.data.frame(as.data.frame(graph)))
	edges = gather(graph %>% rownames_to_column('source'), target, weight, -source)
    }
    if(! all(c('source', 'target', 'weight') %in% colnames(edges))){
        stop('check format')
    }

    # fix edgelist
    # ------------
    edges = as.data.table(edges)
    edges$source = as.character(edges$source)
    edges$target = as.character(edges$target)

    if(symm == TRUE){
        i = apply(edges[,.(source, target)], 1, function(a) paste(a, collapse=' '))
	edges = edges[!duplicated(i)]
    }
    if(self == FALSE){
        edges = edges[source != target]
    }
    edges = edges[abs(weight) > 0]

    # node attributes
    # ---------------
    node_labels = sort(unique(c(edges$source, edges$target)))

    node_sizes = unlist(node_sizes) # recently added
    if(is.null(node_sizes)){
        node_sizes = setNames(rep(1, length(node_labels)), node_labels)
    }
    if(is.null(names(node_sizes))){
        names(node_sizes) = node_labels
    }

    node_colors = unlist(node_colors) # recently added
    if(is.null(node_colors)){
        node_colors = setNames(rep(1, length(node_labels)), node_labels)
    }
    if(is.null(names(node_colors))){
        names(node_colors) = node_labels
    }
    if(is.null(levels(node_colors))){
        node_colors = as.factor(node_colors)
    }

    node_strokes = unlist(node_strokes) # recently added
    if(length(node_strokes) == 1){
        node_strokes = setNames(rep(node_strokes, length(node_labels)), node_labels)
    }

    # edge attributes
    # ---------------
    if(!is.null(edge_colors)){
        edge_colors = as.data.frame(as.matrix.data.frame(as.data.frame(edge_colors)))
	edge_colors = gather(edge_colors %>% rownames_to_column('source'), target, color, -source)
	edges = merge(edges, edge_colors, by=c('source', 'target'))
    }
    if(! 'color' %in% colnames(edges)){
        edges$color = 1
    }
    if(! 'label' %in% colnames(edges)){
        edges$label = ''
    }
    if(! 'linetype' %in% colnames(edges)){
        edges$linetype = 1
    }
    edges$color = as.factor(edges$color)
    edges$linetype = as.factor(edges$linetype)

    # fix edge weights
    # ----------------
    if(any(edges$weight < 0)){
        print('Warning: negative edges')
    }
    if(color_sign == TRUE){
        edges$color = factor(ifelse(edges$weight > 0, 'Positive', 'Negative'), levels=c('Positive', 'Negative'))
    }
    edges$weight = abs(edges$weight)

    # graph layout
    # ------------
    g = graph.data.frame(edges)
    node_order = V(g)$name
    V(g)$node_size = node_sizes[node_order]
    V(g)$node_color = as.character(node_colors[node_order])
    V(g)$node_stroke = as.numeric(node_strokes[node_order])
    layout_weights = ifelse(layout_weights == TRUE, 'weight', NULL)
    d = ggnetwork(g, layout=layout, weights=layout_weights, arrow.gap=arrow.gap)

    # scale sizes (after layout)
    # --------------------------
    i = (d$x == d$xend & d$y == d$yend)
    #d[!i, 'weight'] = rescale_vector(d[!i, 'weight'], edge_scale)
    if(is.null(node_limits)){
        node_limits = c(min(V(g)$node_size), max(V(g)$node_size))
    }

    # plot parameters
    # ---------------
    if(!is.null(lab.use)){
        d$vertex.names = ifelse(d$vertex.names %in% lab.use, as.character(d$vertex.names), '')
	d$label = ifelse(d$label %in% lab.use, as.character(d$label), '')
    }
    d$node_color = factor(d$node_color, levels=levels(node_colors))
    d$color = factor(d$color, levels=levels(edges$color))
    d$linetype = factor(d$linetype, levels=levels(edges$linetype))
    if(is.null(node_pal)){
        if(nlevels(d$node_color) == 1){node_pal = 'black'} else {node_pal = set.colors}
    }
    if(is.null(edge_pal)){
        if(nlevels(d$color) == 1){edge_pal = 'grey'} else {edge_pal = set.colors}
    }

    # self edges
    # ----------
    if(self == TRUE){
        self_nodes = edges[edges$source == edges$target, 'source']
	d$node_stroke = ifelse(i & d$source %in% self_nodes, d$node_stroke, 0)
    }

    # plot network
    # ------------
    p = ggplot(d)
    print(d)
    # scale nodes or edges (can't do both)
    if(size_legend == 'nodes'){
        p = p + geom_segment(data=d[!i,], aes(x=x, y=y, xend=xend, yend=yend, colour=color, linetype=linetype), size=d[!i,'weight'], alpha=edge_alpha, arrow=arrow) +
	    geom_point(data=d[i,], pch=21, aes(x=x, y=y, fill=node_color, size=node_size, stroke=node_stroke), alpha=node_alpha) +
	    scale_radius(size_title, limits=node_limits, range=node_scale, guide=size_guide, trans=size_trans)
    } else {
        p = p + geom_segment(data=d[!i,], aes(x=x, y=y, xend=xend, yend=yend, colour=color, linetype=linetype, size=weight), alpha=edge_alpha, arrow=arrow) +
	    geom_point(data=d[i,], pch=21, aes(x=x, y=y, fill=node_color, stroke=node_stroke), size=max(node_scale), alpha=node_alpha) +
	    scale_size(size_title, limits=edge_limits, range=edge_scale, guide=size_guide, trans=size_trans)
    }

    # construct the rest of the plot
    p = p +
	geom_text_repel(data=d[i,], aes(x=x, y=y, label=vertex.names), box.padding=unit(node_padding, 'lines'), segment.color=segment.color, size=node_lab.size) +
	geom_text_repel(data=d[!i,], aes(x=(x+xend)/2, y=(y+yend)/2, label=label), box.padding=unit(edge_padding, 'lines'), segment.color=segment.color, size=edge_lab.size) +
	scale_fill_manual(node_title, breaks=levels(d$node_color), labels=levels(d$node_color), values=node_pal, guide=node_guide, drop=FALSE) +
	scale_colour_manual(edge_title, breaks=levels(d$color), labels=levels(d$color), values=edge_pal, guide=edge_guide, drop=FALSE) +
	scale_linetype_manual(linetype_title, guide=linetype_guide, drop=FALSE, values=linewidth_pal) +
	theme_blank() + ggtitle(ggtitle)

    # fix legends
    # -----------
    p = p + guides(
                fill = guide_legend(override.aes = list(size=.75*max(node_scale))),
		colour = guide_legend(override.aes = list(size=2))
		)
    if(do.legend == FALSE){
        p = p + theme(legend.position='none')
    }
    if(nlevels(d[i, 'node_color']) == 1){
        p = p + guides(fill=FALSE)
    }
    if(nlevels(d[!i, 'color']) == 1){
        p = p + guides(colour=FALSE)
    }
    if(size_legend == 'nodes'){
        if(min(d[i, 'node_size'], na.rm=T) == max(d[i, 'node_size'], na.rm=T)){p = p + guides(size=FALSE)}
    }
    if(nlevels(d[!i, 'linetype']) == 1){
        p = p + guides(linetype=FALSE)
    }
    p

    # write output
    # ------------
    if(!is.null(out)){
        save_plot(p, file=out, nrow=nrow, ncol=ncol)
    }
    if(ret.data == FALSE){
        p
    } else {
        list(p=p, d=d)
    }
}


options(max.print=1000)
rm(list =ls())
today <- format(Sys.Date(), "%Y%m%d")

get_ref_target <- function(class, turb_data) {
    class_codes <- ref_stations$station_co[ref_stations$class == class]
    results <- turb_data$Result[turb_data$StationCode %in% class_codes]
    quantile(results, probs = 0.75)
}

get_gen_target <- function(class, turb_data) {
    class_codes <- mon_stations$station_co[mon_stations$class == class]
    results <- turb_data$Result[turb_data$StationCode %in% class_codes]
    quantile(results, probs = 0.25)
}

data_dir <- "H:\\gabilan-turbidity-tmdl\\data\\"
mon_stations <-
    read.csv(paste0(data_dir, "mon-stations-classified.csv"))
mon_stations <- mon_stations[!is.na(mon_stations$stream_order), ]
mon_stations$order <- NA
# https://www.thoughtco.com/what-is-stream-order-1435354
mon_stations$order[mon_stations$stream_order <= 3] <- "head"
mon_stations$order[mon_stations$stream_order > 3] <- "medium"
mon_stations$class <- paste(mon_stations$order, mon_stations$slope,
                            mon_stations$substrate, sep = "-")

# for appendix
# mon_out <- mon_stations[c("station_co", "station_na", "class")]
# mon_summ <- as.data.frame(table(mon_out$class))
# write.csv(mon_out, paste0(data_dir, "mon-stations-classed-", today, ".csv"), row.names = FALSE)
# write.csv(mon_summ, paste0(data_dir, "mon-stations-summ-", today, ".csv"), row.names = FALSE)

# import turbidity data and subset by season
turb_all <- read.csv(paste0(data_dir, "ceden-turbidity.csv"))
date <- as.Date(turb_all$SampleDate, format = "%m/%d/%Y")
month <- strftime(date, format = "%m")
month <- as.numeric(month)
is_dry <- month > 4 & month < 10
turb_dry <- turb_all[is_dry, ]
turb_wet <- turb_all[!is_dry, ]

rest_names <- c("309GAB", "309NAD", "309ALG", "309ALD", "309JON", "309TEH",
                "309TEM", "309TDW", "309OLD", "309ASB", "309MER", "309ESP",
                "309RTA")
rest_stations <- mon_stations[mon_stations$station_co %in% rest_names, ]
rest_classes <- names(table(rest_stations$class))
table(rest_stations$class)

p25_impact <- quantile(mon_stations$impact, probs = 0.25)
ref_stations <- mon_stations[mon_stations$impact <= p25_impact, ]

# # for report
# ref_summ <- as.data.frame(table(ref_stations$class))
# write.csv(ref_summ, paste0(data_dir, "ref-stations-summ-", today, ".csv"), row.names = FALSE)

ref_targets_all <-
    sapply(rest_classes, get_ref_target, turb_all)
gen_targets_all <-
    sapply(rest_classes, get_gen_target, turb_all)
ref_targets_wet <-
    sapply(rest_classes, get_ref_target, turb_wet)
gen_targets_wet <-
    sapply(rest_classes, get_gen_target, turb_wet)
ref_targets_dry <-
    sapply(rest_classes, get_ref_target, turb_dry)
gen_targets_dry <-
    sapply(rest_classes, get_gen_target, turb_dry)

out <- data.frame(least_imp = c(ref_targets_all, ref_targets_wet,
                                ref_targets_dry),
                  gen = c(gen_targets_all, gen_targets_wet, gen_targets_dry))
name_sub <- gsub(".75%", "", names(ref_targets_dry))
out$class <- rep(name_sub, 3)
out$season <- rep(c("all", "wet", "dry"), each = 3)
# write.csv(out, paste0(data_dir, "targets-", today, ".csv"), row.names = FALSE)

# all reference
# '305SSCAUC', '312ALA', '309NAC', '312WE1028', '308LILPAL', '309ARCBRC', '310COO', '308BGC', '309SED071', '308ROCBBQ', '308BSU', '309NAF', '308MWCAH1', '307SCCARR', '309CAW050', '312WE1035', '312CCC', '312SBC', '304WAD', '310LSL', '312RYCALR', '309PS0043', '309CAW009', '309LAS1MI', '308WER325', '308LIM', '308LSRASC', '310USL', '304GAZ', '304APS', '308PS0156', '312CUY', '309PS0116', '309CAW174', '314WE0779', '314SYC', '309CAW178', '304PS0194', '312CUT', '312SQRABP', '312PS0099', '308CAW055', '307CMN', '307PS0028', '307CE0094', '304WDCAH1', '310AGB', '304SCM', '307CMU', '309CAW116', '309SAP', '309CAW194', '314WE0796', '312SIV', '312CAW031', '304CAW016', '310SCP', '309SEC', '304CAW153', '310LPCBPC', '308BSR', '308WLO', '308LSU', '308GAR', '307CMRADC', '305UVCASC', '309ARSARC', '305BRI', '310ADU', '309CAW130', '314SYP', '312SIS'

# least impacted
# ref_stations$station_co[ref_stations$class == "head-low-unconsolidated"
#                         | ref_stations$class == "head-low-vegetated"
#                         | ref_stations$class == "medium-low-unconsolidated"]

# '304CAW016', '312CUY', '309SAP', '312WE1035', '312CAV', '312SBC', '304WAD', '312RYCALR', '309SARANF', '310ADU', '314WE0779', '312SIV', '309CAW178', '305LGCACR', '309CAW116', '309CAW050', '312DAVDAV', '312SIS', '305SSCAUC', '312CUT', '305BRI', '309CAW174', '314WE0796', '310LSL', '310SCP', '307SCCARR', '310ADC', '314SYP', '304SVC', '309NAC', '309PS0116', '309CAW194', '312CCC', '304PS0194', '309PS0043', '308PS0308', '309CAW130', '314SYC'

# general
# mon_stations$station_co[mon_stations$class == "head-low-unconsolidated"
#                         | mon_stations$class == "head-low-vegetated"
#                         | mon_stations$class == "medium-low-unconsolidated"]

# '304WAD', '310SYB', '310PCO', '309POT', 'GVWTC1', '311SLE', '309CAW178', '310SLD', '305HAR', '305STL', '309SOS', '309SBC', '309NOS', '305SJA', '305PRR', '305SJN', '310LVR', '310SBE', '310CLK', '310CLV', '310MNO', '313WE0899', '305SSCAUC', '315ROM', '315GBR', '315MIU', '305PES', 'GVWBL2', '315LCC', '309NAD', '315ABU', '315BEF', '310LSL', 'GVWLC2', 'GVWDV24', '305CAW097', '304WE1096', '304SVC', 'GVWMY2', '304PS0194', '304CAW016', 'GVWSP3', 'GVWDV25', '315DOS', 'NATLAS', '305OAK', 'GVWLV1', '310PRE', '305CHE', '314MCM', '304SOK', '310WRP', '305CCUSGS', '312RYCALR', '310DAM', '310SLU', '310DAL', '315RSB', '310UWR', '305ACR', '305LGCACR', '309UQA', '305LEA', '312CUT', '310SCP', '309TEH', '309SALDDM', '309OLD', '312SMA', '309TEM', '304SOQ', '309SBR', '310TWB', '315ATA', 'GVWAT1', '310VIA', '309NAC', '309USA', '309PS0043', '313SAE', '310SLB', '307CML', '310CER', '314WE0785', '307CARME36', '307CARME38', '310UCR', '307CARME366', '313SAI', '310OLD', '310SSC', '314SYN', '310CCC', '310MOR', '312SMI', '310CAW176', '307CMD', '310CAN', '309JON', '306CORNC31', '309BLA', '309ALU', '309ASB', '309ALG', '315LCR', '309GAB', 'GVWDV20', '306CARNE36', '309ALD', '306WAC', 'GABVET', 'GVWLC1', '309MER', '309AXX', '309AVR', '305WCS', '306CAR', '305PS0034', '305MUR', '312HUA', '312CUY', '317EST', '315SCC', '315TOR', '315ABH', 'GVWDV21', 'GVWDV22', '315GAN', '309ANT', '315SJH', '309TOP', '309SUN', '309SARANF', '305CAW049', '309CAW116', '305SBH', '309GRN', '317ESE', '315MYC', '315CAU', '305BRI', 'GVWMY1', '307SCCARR', '309LOK', '309PS0116', '309PSO', '309SAG', '309SAN', '315ATU', 'GVWSJ1', 'GVWAT2', '307TUL', '308PS0308', '312NIT', '310DAU', '309PS0072', '309SAP', '315CRP', '309CAW182', 'GVWGA2', '309SSP', '309SAC', '309PS0040', '310UPN', '310ADU', '309SALUBD', '312NIP', 'GVWSJ2', '309SAS', '310APN', '309DSA', '309SAT', '310PEN', '309CAW050', '309SET', '309CAW174', '309DAV', '310CPN', '310ADC', '309CAW194', 'CMWCP00', '309CAW130', '309QUI', '309CRR', '309UAL', '312ORI', '309SRITA34', '309QCW', '309-SRITA-36', '310BER', 'GVWCG1', '306CARNE32', '309CCD', 'GVWSP1', '315FRC', '314DDE', 'GVWAT3', '315FRCMVD', '312ORN', '315FRCMVU', '310CHD', '306CARNE33A', '315FMV', '306CARNE31', '310LBC', '312GVS', '309HRT', '312MAB', '310ARG', '315MIS', 'CMWSM01', '315ANN', '315SJC', '309RTA', '312GVT', '309QUA', '310TUR', '315YSI', '315SMC', '315SPC', 'CMWFK00', 'GVWGA1', '309ESP', '305MVR', '315MTC', '312ORC', '312WE1035', '314WE0779', '312DAVDAV', '314WE0796', '311SLN', '314SYP', '305TRE', '314SYL', '312CCC', '314SYI', '314SYC', '305PAC', '312CAV', '315RIN', '305CAW161', '312SIV', '312SIS', '312SBC'


a1 <- c(1, 2, 3)
a2 <- c(3, 4, 5)
a3 <- c(a1, a2)


require(magrittr)

player_dob <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-09/player_dob.csv")
grand_slams <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-09/grand_slams.csv")
grand_slam_timeline <- readr::read_csv("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-04-09/grand_slam_timeline.csv")

age_slams_comb <- dplyr::left_join(grand_slams, player_dob, by = c("name")) %>%
  dplyr::mutate(age = tournament_date - date_of_birth) %>% # needs to be datetime
  dplyr::group_by(name, age, gender) %>%
  dplyr::summarize(counts = n()) %>%
  dplyr::group_by(name) %>%
  dplyr::mutate(total_wins = cumsum(counts)) %>%
  dplyr::arrange(desc(total_wins))

# test plot
age_slams_comb %>%
  ggplot2::ggplot(ggplot2::aes(x = age,
  	y = total_wins, group = name)) +
  ggplot2::geom_point() +
  ggplot2::geom_step() +
  ggplot2::facet_wrap(~gender) +
  ggplot2::theme_bw()

tmp <- dplyr::left_join(grand_slams, player_dob, by = c("name")) %>%
         dplyr::mutate(age = tournament_date - date_of_birth)

df <- grand_slam_timeline %>%
	dplyr::rename(name = "player") %>%
	dplyr::left_join(., age_slams_comb, by = c('name', 'year'))

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

dplyr::glimpse(df)

dat <- grand_slam_timeline %>%
			dplyr::filter(outcome == "Won") %>%
			dplyr::arrange(year) %>%
			dplyr::group_by(player) %>%
			dplyr::mutate(count = seq(n()))

dat <- grand_slam_timeline %>%
				dplyr::filter(outcome == "Won") %>%
				dplyr::mutate(outcome == ifelse(outcome == "Won", 1,0))

theme_bluewhite <- function (base_size = 11, base_family = "") {
    ggplot2::theme_classic() +
        ggplot2::theme(
            panel.grid.major  = ggplot2::element_line(color = "white"),
            panel.background = ggplot2::element_rect(fill = "lightblue"),
          #  panel.border = ggplot2::element_rect(color = "lightblue", fill = NA),
            axis.line = ggplot2::element_line(color = "lightblue"),
            axis.ticks = ggplot2::element_line(color = "lightblue"),
            axis.text = ggplot2::element_text(color = "steelblue")
        )
}

dat %>%
    ggplot2::ggplot(., ggplot2::aes(x=player, y = count, col = player,
                                    group = player)) +
    ggplot2::geom_point() +
    ggplot2::geom_line() +
    ggplot2::facet_wrap(~tournament) +
    theme_bluewhite() +
    ggplot2::theme(legend.position = "none")

dat %>%
    ggplot2::ggplot(., ggplot2::aes(x=year, y = count, col = player,
                                 group = player)) +
    ggplot2::geom_point() +
    ggplot2::geom_line() +
    ggplot2::facet_wrap(~tournament) +
    ggplot2::theme_bw() +
    ggplot2::theme(legend.position = "none") +
  #  ggplot2::geom_text() +
    ggplot2::labs(title = 'Hour: {frame_along}') +
    #  transition_time(date_time) #+
    gganimate::transition_reveal(count)

gganimate::animate(anim, fps = 6)


#' Generate level change regression matrix
#'
#' Generates a regression matrix of LS (level change) outliers to be included in weekly modeling routines
#'
#' @param outlier_dates Integer matrix - matrix of dates for LS outliers
#' @param this_week Numeric vector; Week of the year for each observation.
#' @param this_year Numeric vector; Year of each observation.
#' @param forecast Numeric scalar; Number of forecasts. Default: 0.
#' @param air_name Logical scalar; If TRUE, names are formatted as they are in the fractional airline routine;
#'                 otherwise format them as in movereg. Default: TRUE
#' @param x13type Logical scalar; Indicates if level change outlier is defined as in X-13ARIMA-SEATS. Default: TRUE.
#' @param return_xts Logical scalar; return matrix as an \code{xts} time series object. Default is FALSE.
#'        If TRUE, \code{this_week} and \code{this_year} should be \code{xts} time series objects.
#' @return Generate matrix of level change outlier regressors, with column names that describe the individual regressors
#' @examples
#' ic_level_dates <-
#'    matrix(c(12, 2020, 13, 2020), ncol=2, byrow=TRUE)
#' ic_level_matrix <-
#'    gen_level_outlier_matrix(ic_level_dates, ic_week, ic_year, 0,
#'                             return_xts = FALSE)
#' cc_level_dates <-
#'    matrix(c(12, 2020, 13, 2020), ncol=2, byrow=TRUE)
#' cc_level_matrix_xts <-
#'    gen_level_outlier_matrix(cc_level_dates, cc_week_xts, cc_year_xts, 0,
#'                             return_xts = TRUE)
#' @import stats
#' @export
gen_level_outlier_matrix <- function(outlier_dates, this_week, this_year, forecast = 0, air_name = TRUE, x13type = TRUE,
                                     return_xts = FALSE) {
    # Author: Brian C. Monsell (OEUS), Version 4.2, 3/14/2021

    # Set number of outliers, length of outlier regressors
    num_otlr <- nrow(outlier_dates)
    len_otlr <- length(this_week) + forecast

    # Inititalize outlier matrix to 0
    outlier_matrix <- matrix(0, ncol = num_otlr, nrow = len_otlr)

    # Format outlier regressor to maintain the level of the series for the most recent observations
    if (x13type) {
        for (i in 1:num_otlr) {
            # set constant used to set the current observation to -1
            this_obs <- -1

            # generate a logical filter to match the outlier date for outlier i
            this_filter <- (this_week == outlier_dates[i, 1]) & (this_year == outlier_dates[i, 2])

            for (j in 1:len_otlr) {
                # change constant to 0 when filter matches current observation
                if (this_filter[j]) {
                  this_obs <- 0
                }
                outlier_matrix[j, i] <- this_obs
            }
        }
    } else {
        for (i in 1:num_otlr) {
            # set constant used to set the current observation to 0
            this_obs <- 0

            # generate a logical filter to match the outlier date for outlier i
            this_filter <- (this_week == outlier_dates[i, 1]) & (this_year == outlier_dates[i, 2])

            for (j in 1:len_otlr) {
                # change constant to 1 when filter matches current observation
                if (this_filter[j]) {
                  this_obs <- 1
                }
                outlier_matrix[j, i] <- this_obs
            }
        }
    }

    # Generate outlier names, set column names of outlier matrix to outlier names
    if (air_name) {
        outlier_names <- paste0("LS(week ", outlier_dates[, 1], ", ", outlier_dates[, 2], ")")
    } else {
        outlier_names <- paste("LS week", outlier_dates[, 1], outlier_dates[, 2])
    }
    colnames(outlier_matrix) <- outlier_names

    # return outlier matrix
    if (return_xts) {
       outlier_matrix_xts <-
          xts::xts(x = outlier_matrix,
                   order.by = as.Date(zoo::index(this_week), origin = "1970-01-01"))
       return(outlier_matrix_xts)
    } else {
       return(outlier_matrix)
    }

}


# 3. faza: Vizualizacija podatkov

library(tidyverse)
library(ggplot2)
library(dplyr)

source("uvoz/uvoz.r", encoding="UTF-8")

#torej mam tri glavne tabele s katerimi želim risati grafe:
#zlocinci, tabela_r in tabela_o

g1 <- tabela_r %>% filter(regija!="SLOVENIJA") %>%
  ggplot(mapping = aes(x = leto, y = obsojeni, color = regija))+
  labs(x = "leto",
    y = "Število obsojenih na 1000 prebivalcev",
    title = "Število obsojenih po slovenskih regijah",
    color = "Statistična regija") +
  geom_line() + geom_point()

g2 <- tabela_r %>% filter(regija!="SLOVENIJA") %>%
  ggplot(
    mapping = aes(x = zadovoljstvo, y = obsojeni, color= revscina , size= stanovanje)
  ) +
  labs(y = "Število obsojenih na 1000 prebivalcev",
       x = "Samoocena splošnega zadovoljstva z življenjem",
       title = "Število obsojenih glede na socioekonomska stanja",
       color = "Stopnja revščine",
       size =  "Delež slabih stanovanj") +
  geom_point(position = position_jitter(width = 0.10))

g3 <- zlocinci %>% filter(dejanje == "KAZNIVO DEJANJE - SKUPAJ") %>%
  filter(starost != "skupaj") %>%
  ggplot(
    mapping = aes(x = leto, y = obsojeni ,  fill = spol)
  )  +
  labs(x = "Leto", y = "Število obsojenih",
       title = "Število obsojenih po spolu", fill = "Spol") +
  geom_col(
    position = position_dodge()
  )

g4 <- zlocinci %>% filter(starost != "Starost - SKUPAJ") %>%
  group_by(starost) %>%
  ggplot(
    mapping = aes(x = leto, y = obsojeni ,  fill = starost)
  )  +
  labs(x = "Leto", y = "Število obsojenih",
       title = "Število obsojenih po starostnih skupinah",
       fill = "Starostna skupina")+
  geom_col()

g5 <- tabela2 %>%filter(leto == 2020)%>%
  ggplot(
    mapping = aes(x = starost, y = obsojeni, fill=dejanje)
  ) +
  theme(
    axis.text.x = element_text(angle = 45, vjust = 0.5),
    axis.title.x = element_text(vjust = 0)
    )+
  labs(y = "Število obsojenih", x = "Starost zločincev",
       fill = "KAZNIVA DEJANJA ZOPER",
       title = "Deset najpogostejših zločinov glede na spol in starost zločincev v letu 2020")+
  geom_col() + facet_wrap(.~ spol,ncol = 5)

g6 <- tabela_o %>% filter(obcina!="SLOVENIJA") %>% filter(leto >2010)%>%
  ggplot(
    mapping = aes(x = placa, y = obsojeni)
  ) +
  labs(y = "Število obsojenih na 1000 prebivalcev", x = "Povprečna plača",
       title  = "Število obsojenih glede na povprečno plačo po letih") +
  scale_y_log10() +
  geom_point(position = position_jitter(width = 0.10)) +
  facet_wrap(.~ leto,ncol = 5)

g6
# zdi se kot da spremenljivki nista najbolj povezani, zato bo opustila analiz med njima

#--------------------------------------------------------------------------------
############################### ZEMLJEVID ######################################

library(sp)
library(rgdal)
library(rgeos)
library(raster)
library(tidyverse)
library(tmap)

source("lib/uvozi.zemljevid.r")
obcine <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
                          pot.zemljevida="OB", encoding="Windows-1250")

tm_shape(obcine) + tm_polygons("OB_UIME") + tm_legend(show=FALSE)
obcine$OB_UIME <- factor(obcine$OB_UIME)

lvls <- levels(obcine$OB_UIME)

tabela <- tabela_o %>% filter(leto == 2015) %>% filter(obcina != "SLOVENIJA" )

obsojeni.zemljevid <- unique(tabela$obcina) %>% sort()

razlicni <- lvls!= obsojeni.zemljevid

primerjava <- data.frame(obcina.zemljevid = parse_character(lvls),
                         obcina.obsojeni = obsojeni.zemljevid)[razlicni,]

obsojeni.na.zemljevidu <- tabela%>%
  left_join(primerjava, by = c("obcina" = "obcina.obsojeni")) %>%
  mutate(obcina = ifelse(is.na(obcina.zemljevid), obcina, obcina.zemljevid) %>% factor()) %>%
  dplyr::select(-obcina.zemljevid)

obcine.obsojeni.zemljevid <- sp::merge(obcine, obsojeni.na.zemljevidu,
                              by.x = "OB_UIME", by.y = "obcina", duplicateGeoms = TRUE)

tmap_mode("view")
map <- tm_shape(obcine.obsojeni.zemljevid) +
    tm_polygons("obsojeni", popup.vars = c("Število obsojenih na 1000 preb: " = "obsojeni")) + tm_legend(show=FALSE)
map


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__,|___|___|
#==============================================================================
# SCATTER PLOT
#==============================================================================
# Title          : beeswarm scatter plot.r
# Description    : beeswarm scatter plotting using {}
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 201800404
# Version        : 0.0.3
# Usage          : Run in R 3.4
# Notes          : Source http://www.cbs.dtu.dk/~eklund/beeswarm
# R version      : 3.4
#==============================================================================

# install.packages('beeswarm')

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(beeswarm)

#==============================================================================
# Plots
#==============================================================================
stripchart(decrease ~ treatment, data = OrchardSprays,
  vertical = TRUE, log = "y", method = 'jitter', jitter = 0.2, cex = 1,
  pch = 16, col = rainbow(8),
  main = 'stripchart')

beeswarm(decrease ~ treatment, data = OrchardSprays,
  log = TRUE, pch = 16, col = rainbow(8),
  main = 'beeswarm')

# Specify color of individual points
data(breast)
beeswarm(time_survival ~ ER, data = breast,
    pch = 16, pwcol = 1 + as.numeric(event_survival),
    xlab = "", ylab = "Follow-up time (months)",
    labels = c("ER neg", "ER pos"))
legend("topright", legend = c("Yes", "No"),
    title = "Censored", pch = 16, col = 1:2)

# methods for arranging points
set.seed(666)
n <- 200
distro <- list(runif = runif(n, min = -3, max = 3),
               rnorm = rnorm(n))

for (m in c("swarm", "center", "hex", "square")) {
  windows()
  beeswarm(distro,
    col = 2:3, pch = 16,
    method = m,
    main = paste('method = "', m, '"', sep = ''))
}

# methods for arranging points (horizontal axis), "corral" methods
for (ii in c("none", "gutter", "wrap", "random", "omit")) {
  windows()
  beeswarm(distributions,
    pch = 21, col = 2:4, bg = "#00000050",
    corral = ii,
    main = paste('corral = "', ii, '"', sep = ''))
}

# combine beeswarms with "boxplot" or "bxplot"
boxplot(len ~ dose, data = ToothGrowth,
  outline = FALSE,     ## avoid double-plotting outliers, if any
  main = 'boxplot + beeswarm')

beeswarm(len ~ dose, data = ToothGrowth,
  col = 4, pch = 16, add = TRUE)

beeswarm(len ~ dose, data = ToothGrowth,
  col = 4, pch = 16,
  main = 'beeswarm + bxplot')

bxplot(len ~ dose, data = ToothGrowth, add = TRUE)

# arguments "side" and "priority"
beeswarm(distributions, col = 2:4,
  main = 'Default')

beeswarm(distributions, col = 2:4, side = -1,
  main = 'side = -1')

beeswarm(distributions, col = 2:4, side = 1,
  main = 'side = 1')

beeswarm(distributions, col = 2:4, priority = "descending",
  main = 'priority = "descending"')

beeswarm(distributions, col = 2:4, priority = "random",
  main = 'priority = "random"')

beeswarm(distributions, col = 2:4, priority = "density",
  main = 'priority = "density"')


# mead-powell storage graph
library(ggplot2)
library(tidyverse)
library(readr)
library(reshape2)

# read data
mp <- read_csv("./data/meadpowell.csv", col_names=TRUE)

# add up total storage
mp$Total <- mp$Mead + mp$Powell
newdata <- as_tibble(melt(mp, id.vars="Year",
                          variable.name="Reservoir",
                          value.name="Storage"))
newdata <- filter(newdata, Storage>0)

# plot it
ggplot(newdata, aes(x=Year, y=Storage/1000, colour=Reservoir)) +
  theme_bw() +
  theme(plot.title = element_text(size = rel(2)),
        panel.background = element_rect(colour = NA),
        plot.background = element_rect(colour = NA),
        plot.subtitle = element_text(size = rel(1.5)),
        axis.title = element_text(face = "bold",size = rel(1))) +
  geom_line(size=1) +
  ylab("millions of acre feet") +
  xlab("Data: USBR\nGraph:John Fleck, University of New Mexico Water Resources Program\n
       Code and data: https://github.com/johnrfleck/colorado-river") +
  ggtitle("Combined Storage, Lakes Mead and Powell")


# discretize time in bins of custom resolution
# use: get_bins(x,x.min,x.max,resolution)
get_bins <- function(x, x.min, x.max, resolution){
  bins <- x %>% # lambda expression
  {
    t <- . # basically asign x to t to be used as a placeholder variable
    t <- cut(t,(x.min:x.max)*resolution) # find intervals between xmin and xmax
    t <- ifelse(is.na(t),0,t) # return the levels of the intervals
    t %>% as.integer() # convert to integers
  }
  bins # same as return(x), but more efficient
}


# Load data ---------------------------------------------------------------

load("data_generated/Pregnancy_flow_cytometry.RData")
load("data_generated/Pregnancy_somalogic.RData")

# load V3 vs. V1 results --------------------------------------------------

soma.comp = fread("results/soma_visits_comparison.txt")
i.soma = soma.comp$Target[soma.comp$wQ <= 0.05 & abs(log2(soma.comp$FC)) > log2(1.2)]
length(i.soma)

flow.comp = fread("results/flow_visits_comparison.txt")
i.flow = flow.comp$ID[flow.comp$wQ.3.v.1 <= 0.05 & abs(log2(flow.comp$FC.3.v.1)) > log2(1.2)]
length(i.flow)

# Soma vs. Flow -----------------------------------------------------------

fi = rownames(dat.flow) %in% rownames(dat.soma)
si = match(rownames(dat.flow)[fi],rownames(dat.soma))
identical(rownames(dat.soma)[si],rownames(dat.flow)[fi])

dat.flow = dat.flow[fi, i.flow]
info.flow = info.flow[fi,]
dat.soma = dat.soma[si, i.soma]
info.soma = info.soma[si,]

tp1 = 1
tp2 = 3

tp.lbl = paste0("V",tp2,".V",tp1)
i2 = which(info.soma$Visit == tp2)
i1 = which(info.soma$Visit == tp1)
is2 = info.soma$Subject[i2] %in% info.soma$Subject[i1]
is1 = match(info.soma$Subject[i2], info.soma$Subject[i1])
stopifnot(identical(info.soma$Subject[i2[is2]], info.soma$Subject[i1[is1]]))
dat.soma.tp = dat.soma[i2[is2],] / dat.soma[i1[is1],]
info.soma.tp = info.soma[i2,]

i2 = which(info.flow$Visit == tp2)
i1 = which(info.flow$Visit == tp1)
is2 = info.flow$Subject[i2] %in% info.flow$Subject[i1]
is1 = match(info.flow$Subject[i2], info.flow$Subject[i1])
stopifnot(identical(info.flow$Subject[i2[is2]], info.flow$Subject[i1[is1]]))
dat.flow.tp = dat.flow[i2[is2],] / dat.flow[i1[is1],]
info.flow.tp = info.flow[i2,]

ccs.sf = cor(dat.soma.tp, dat.flow.tp, use = "pairwise.complete.obs", method = "spearman")
ccs.sf.p = ccs.sf
ccs.sf.padj = ccs.sf
for(m in 1:ncol(dat.flow.tp)) {
  for(k in 1:ncol(dat.soma.tp)) {
    ccs.sf.p[k,m] = cor.test(dat.soma.tp[,k], dat.flow.tp[,m], method = "spearman",
                             alternative = "two.sided", exact=F)$p.value
  }
  ccs.sf.padj[,m] = p.adjust(ccs.sf.p[,m], method="BH") %>% matrix(dim(ccs.sf))
}
rownames(ccs.sf.padj) = rownames(ccs.sf.p)
colnames(ccs.sf.padj) = colnames(ccs.sf.p)

ccs.sf.p.log = ccs.sf
ccs.sf.p.log = -log10(ccs.sf.p) * sign(ccs.sf)
range(ccs.sf.padj)

ccs.sf.row.min = apply(ccs.sf.padj, 1, min)
i.sel = ccs.sf.row.min <= 0.05
sum(i.sel)

ccs.sf.col.min = apply(ccs.sf.padj[i.sel,], 2, min)
i.sel.fl = ccs.sf.col.min <= 0.1
sum(i.sel.fl)

DF = data.frame()
DF.ccs = data.frame()

visit_lbl = paste0("V",tp2,".V",tp1)

df.ccs.p = ccs.sf.p %>% as.data.frame() %>%
  tibble::rownames_to_column("soma") %>%
  gather("population", "p", -1)
df.ccs.padj = ccs.sf.padj %>% as.data.frame() %>%
  tibble::rownames_to_column("soma") %>%
  gather("population", "FDR", -1)
df.ccs = ccs.sf %>% as.data.frame() %>%
  tibble::rownames_to_column("soma") %>%
  gather("population", "rho", -1) %>%
  mutate(p = df.ccs.p$p, FDR = df.ccs.padj$FDR, visit.label = visit_lbl) %>%
  arrange(FDR,p)

fwrite(df.ccs, file = glue::glue("results/Soma_Flow_{visit_lbl}_spearman.txt"), sep="\t")

DF = cbind(dat.soma.tp, dat.flow.tp) %>%
  as.data.frame() %>%
  tibble::rownames_to_column("sample") %>%
  separate(sample, c("subject","visit"), remove = F)

popt = df.ccs$population[1]
somat = df.ccs$soma[1]
pop = glue::glue("`{popt}`")
somam = glue::glue("`{somat}`")

df.text = df.ccs %>%
  dplyr::filter(population == popt, soma == somat) %>%
  mutate(label = glue::glue("p = {format(p, digits=2)}\nFDR = {format(FDR, digits=2)}"))
ggplot(DF, aes_string(somam, pop)) +
  geom_smooth(method = "lm", fill = NA) +
  geom_point(size=2) +
  # facet_wrap(~visit.label) +
  scale_y_log10() +
  # geom_text(aes(label=subject), size=3) +
  geom_text(data=df.text, aes(label=label), x=Inf, y=-Inf, hjust=1.1, vjust=-0.5) +
  guides(size = guide_legend(), col = F) +
  xlab(somat) +
  ylab(paste("population ", popt)) +
  theme_bw()
fn.fig = glue::glue("figures/ID{popt}_{somat}_FC_{visit_lbl}_correlation.png")
ggsave(fn.fig, w=5, h=4)


# Load libraries
library(data.table)
library(devtools)
library(repmis)
library(lubridate)
library(zoo)
library(scales)
library(ggplot2)
library(reshape2)
library(plyr)

StatRollApply <- # nolint
  ggproto("RollApply", Stat,
    required_aes = c("x", "y"),
    compute_group = function(data, scales, FUN = median, width = 84,
                             rm.below = NULL, rm.above = NULL, ...) {
      require(zoo)
      filtered <-
        rollapplyr(data$y, width, FUN, fill = NA, ..., align = "center")
      if (!is.null(rm.below))
        filtered[filtered < rm.below] <- NA
      if (!is.null(rm.above))
        filtered[filtered > rm.above] <- NA
      return(data.table(x = data$x, y = filtered))
    }
  )

StatRollApplyRibbon <- # nolint
  ggproto("RollApplyRibbon", Stat,
    required_aes = c("ymin", "ymax"),
    compute_group = function(data, scales, FUN = mean, width = 84, ...) {
      require(zoo)
      minima <-
        rollapplyr(data$ymin, floor(width / 2), min,
                   fill = c("extend"), ..., align = "center")
      minima[minima ==  Inf] <- NA
      data$ymin <- rollapplyr(minima, width, mean,
                              fill = NA, ..., align = "center")

      maxima <-
        rollapplyr(data$ymax, floor(width / 2), max,
                   fill = c("extend"), ..., align = "center")
      maxima[maxima == -Inf] <- NA
      data$ymax <- rollapplyr(maxima, width, mean,
                              fill = NA, ..., align = "center")
      return(data.table(x = data$x, ymin = data$ymin, ymax = data$ymax))
    }
  )

stat_rolling_median <-
  function(mapping = NULL, data = NULL, width = 84,
           geom = "smooth", position = "identity",
           show.legend = NA, inherit.aes = TRUE,
           rm.below = NULL, rm.above = NULL, ...) {
    layer(stat = StatRollApply, # nolint
      data = data, mapping = mapping, geom = geom,
      position = position, show.legend = show.legend, inherit.aes = inherit.aes,
      params = list(FUN = median, width = width,
                    rm.below = rm.below, rm.above = rm.above, ...)
    )
  }

stat_rolling_mean_ribbon <-
  function(mapping = NULL, data = NULL, width = 84,
           geom = "ribbon", position = "identity",
           show.legend = NA, inherit.aes = TRUE, ...) {
    layer(stat = StatRollApplyRibbon, # nolint
      data = data, mapping = mapping, geom = geom,
      position = position, show.legend = show.legend, inherit.aes = inherit.aes,
      params = list(FUN = mean, width = width, ...)
    )
  }

preprocess <- function(polldata) {
  # Calculate coalition values
  polldata[["RightBlock"]] <- rowSums(polldata[, c("M", "L", "C", "KD")])
  polldata[["LeftBlock"]]  <- rowSums(polldata[, c("S", "V", "MP")])
  # Convert dates to a suitable format
  polldata[["PublDate"]]          <- as.Date(polldata[["PublDate"]])
  polldata[["collectPeriodTo"]]   <- as.Date(polldata[["collectPeriodTo"]])
  polldata[["collectPeriodFrom"]] <- as.Date(polldata[["collectPeriodFrom"]])
  # Remove polls with missing data
  nopubdate <- is.na(polldata[["PublDate"]])
  noenddate <- is.na(polldata[["collectPeriodTo"]])
  polldata[["PublDate"]][nopubdate] <- polldata[["collectPeriodTo"]][nopubdate]
  polldata[["collectPeriodTo"]][noenddate] <- polldata[["PublDate"]][noenddate]
  polldata <-
    subset(polldata, !(is.na(collectPeriodFrom) | is.na(PublDate) | is.na(n))) # nolint
  # Done!
  return(polldata)
}

expand_polls <- function(poll_data) {
  # Expand polls so the result of each covers its entire measurement period
  poll_data[["rownum"]] <- 1:nrow(poll_data)
  polls_dt <- data.table(poll_data)
  polls_dt <- polls_dt[,
    list(PollDate = seq(collectPeriodFrom, collectPeriodTo, by = "day")), # nolint
    by = "rownum"]
  polls_dt <- merge(polls_dt, data.table(poll_data), by = c("rownum"))
  return(polls_dt)
}

transform_polls <- function(poll_data, FUN, .SDcols) {
  return(
    poll_data[, lapply(.SD, FUN, na.rm = TRUE),
              by = "PollDate", .SDcols = .SDcols]
  )
}

make_continuous <- function(poll_data, select) {
  poll_zoo <- zoo(poll_data, poll_data[["PollDate"]])
  poll_zoo <- merge(poll_zoo,
                    zoo(, seq(start(poll_zoo), end(poll_zoo), by = 1)),
                    all = TRUE)
  poll_zoo <- subset(poll_zoo, select = select)
  return(fortify(poll_zoo, NA, melt = TRUE))
}

numeric_levels <- function(column) {
  return(as.numeric(levels(column))[column])
}
reorder_levels <- function(column, new_order) {
  return(
    factor(column, levels = levels(column)[new_order])
  )
}

get_plot <- function(derived, real, election) {
  # Define the color/line/alpha scheme for the plot
  # Ccolors from http://sv.wikipedia.org/wiki/Mall:Partifärg
  # Blocks take colors from (M) and (S) resp., uncertains are grey
  colors <- c(
    "#b70410", "#f9232b", "#79cf49",
    "#00993c", "#211974", "#5cb7e9",
    "#0049d8", "#dedd37", "#e2328d",
    "#cccccc", "#0049d8", "#f9232b"
  )
  linetypes <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2,   2  )
  alphas    <- c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0.5, 0.5)

  # nolint start
  p <- ggplot(
    derived,
    aes(
      x = Index, y = Value, ymin = MinValue, ymax = MaxValue,
      color = Series, group = Series, linetype = Series, alpha = Series
    )
  )
  # nolint end

  # Rolling median of the derived data
  p <- p + stat_rolling_median(rm.below = 1.0, na.rm = TRUE, alpha = 0.15)
  # Ribbon for derived data
  p <- p + stat_rolling_mean_ribbon(
    data = subset(derived, !(Series %in% c("Osäkra", "Alliansen", "Rödgröna"))),
    width = 84, na.rm = TRUE, alpha = 0.05, fill = "#333333", colour = NA
  )

  # Actual polls
  p <- p + geom_point(
    data = subset(real, !(Series %in% c("Alliansen", "Rödgröna"))),
    alpha = 0.125
  )

  # Election results
  p <- p + geom_point(data = election, shape = 18)

  # Lower limit for getting into Riksdagen
  p <- p + geom_hline(yintercept = 4, colour = "#333333", linetype = "dashed")

  # Styling
  p <- p + scale_colour_manual(  name = "Parti", values = colors   ) +
           scale_linetype_manual(name = "Parti", values = linetypes) +
           scale_alpha_manual(   name = "Parti", values = alphas   )

  # Labels and scales
  p <- p + labs(x = "Datum", y = "Stöd (%)")
  p <- p + scale_x_date(
    breaks = date_breaks("1 year"),
    minor_breaks = date_breaks("1 month"),
    labels = date_format("%Y")
  )
  p <- p + scale_y_continuous(
    breaks = 0:12 * 5,
    minor_breaks = 0:60,
    limits = c(0, 60)
  )

  # Done!
  return(p)
}

# Helper map for converting columns to party names
partynames <- c(
  "M"          = "Moderaterna",
  "L"         = "Liberalerna",
  "C"          = "Centerpartiet",
  "KD"         = "Kristdemokraterna",
  "S"          = "Socialdemokraterna",
  "V"          = "Vänsterpartiet",
  "MP"         = "Miljöpartiet",
  "SD"         = "Sverigedemokraterna",
  "FI"         = "Feministiskt initiativ",
  "Uncertain"  = "Osäkra",
  "RightBlock" = "Alliansen",
  "LeftBlock"  = "Rödgröna"
)
partyorder <- c(6, 5, 7, 3, 4, 2, 1, 8, 9:12)
parties <- c(
  "M", "L", "C", "KD", "S", "V", "MP", "SD", "FI",
  "Uncertain", "RightBlock", "LeftBlock"
)

# Load data
devtools::install_github("MansMeg/SwedishPolls", subdir = "RPackage")
poll_data <- preprocess(SwedishPolls::get_polls())

# Calculate a weighting value based on estimated interviews per day
poll_durations <-
  poll_data[["collectPeriodTo"]] - poll_data[["collectPeriodFrom"]] + 1
poll_data[["weight"]] <- poll_data[["n"]] / as.numeric(poll_durations)

# Expand the polls and get min/max series for later use
polls_dt     <- expand_polls(poll_data)
polls_dt_min <- transform_polls(copy(polls_dt), min, c(parties))
polls_dt_max <- transform_polls(copy(polls_dt), max, c(parties))

# Produce a weighted mean of polls for each day
polls_dt[, `:=`(parties, Map("*",
                             polls_dt[, parties, with = F],
                             polls_dt[, "weight", with = F])), with = F]
polls_dt <- transform_polls(polls_dt, sum, c(parties, "weight"))
polls_dt[, `:=`(parties, Map("/",
                             polls_dt[, parties, with = F],
                             polls_dt[, "weight", with = F])), with = F]

# Create a continuous time series
derived_data  <- make_continuous(polls_dt, select = parties)
poll_data_min <- make_continuous(polls_dt_min, select = parties)
poll_data_max <- make_continuous(polls_dt_max, select = parties)

# Transform back to data frame and reorder parties
derived_data[["Value"]]    <- numeric_levels(derived_data[["Value"]])
derived_data[["MinValue"]] <- numeric_levels(poll_data_min[["Value"]])
derived_data[["MaxValue"]] <- numeric_levels(poll_data_max[["Value"]])

# Reorder and translate party names
derived_data[["Series"]] <- reorder_levels(derived_data[["Series"]], partyorder)
derived_data[["Series"]] <- revalue(derived_data[["Series"]], partynames)

# Remove nonsensical min/max values
derived_data[["MinValue"]][derived_data[["MinValue"]] ==  Inf] <- NA
derived_data[["MaxValue"]][derived_data[["MaxValue"]] == -Inf] <- NA

# Do the same for non-continous non-averaged data
poll_data <- melt(poll_data, id.vars = "PublDate", parties,
                 variable.name = "Series", value.name = "Value")
poll_data[["Index"]]  <- poll_data[["PublDate"]]
poll_data[["Series"]] <- reorder_levels(poll_data[["Series"]], partyorder)
poll_data[["Series"]] <- revalue(poll_data[["Series"]], partynames)

poll_data[["MinValue"]] <- poll_data[["Value"]]
poll_data[["MaxValue"]] <- poll_data[["Value"]]

# Create data for election results
elections <- data.frame(
  PublDate = c(as.Date("2002-09-15"), as.Date("2006-09-17"),
               as.Date("2010-09-19"), as.Date("2014-09-14")),
  M  = c(15.26, 26.23, 30.06, 23.33),
  L = c(13.39, 7.54,  7.06,  5.42 ),
  C  = c(6.19,  7.88,  6.56,  6.11 ),
  KD = c(9.15,  6.59,  5.60,  4.57 ),
  S  = c(39.85, 34.99, 30.66, 31.01),
  V  = c(8.39,  5.85,  5.60,  5.72 ),
  MP = c(4.65,  5.24,  7.34,  6.89 ),
  SD = c(1.44,  2.93,  5.70,  12.86),
  FI = c(NA,    0.68,  0.40,  3.12 ),
  Uncertain  = c(NA, NA, NA, NA),
  RightBlock = c(NA, NA, NA, NA),
  LeftBlock  = c(NA, NA, NA, NA)
)
election_data <- melt(elections, id.vars = "PublDate", parties,
                variable.name = "Series", value.name = "Value")
election_data[["Index"]]  <- election_data[["PublDate"]]
election_data[["Series"]] <- revalue(election_data[["Series"]], partynames)
election_data[["Series"]] <-
  reorder_levels(election_data[["Series"]], partyorder)

election_data[["MinValue"]] <- election_data[["Value"]]
election_data[["MaxValue"]] <- election_data[["Value"]]
election_data <- subset(election_data, Index > as.Date("2003-01-01"))

# Actual plot
plot <- get_plot(derived_data, poll_data, election_data)

# Outputs
ggsave("polls.png", plot, width = 25.6, height = 14.4, units = "in", dpi = 75)
ggsave("polls.pdf", plot, width = 420,  height = 297,  units = "mm")


d <- data.frame(a=c(2,4,6), b = c(5,7,9))
attach(d)
b - a        #success
detach(d)
b - a        #produces error


source("modelaverage.r")

lasso_component <- lasso_component / max(abs(lasso_component))

indx <- which(de_component>0)
de_component[indx] <- de_component[indx] - min(abs(de_component[indx]))
indx <- which(de_component<0)
de_component[indx] <- de_component[indx] + min(abs(de_component[indx]))
de_component <- de_component / max(abs(de_component))
## Untrained Parameters
#combinedAdjMtr <- compute.model.average.new(betas,de_component,c(1,1,1,1,1,1,0.01,0.01))
## Trained Parameters
combinedAdjMtr <- compute.model.average.new(lasso_component,de_component,c(3,1,1,1,1,2,0.1,0.01))

# write.table(combinedAdjMtr,file.path(outputDirectory,combinedAdjMtrFileName),row.names=FALSE,col.names=FALSE,quote=FALSE,sep='\t')
write.table(combinedAdjMtr,combinedAdjMtrFileName,row.names=FALSE,col.names=FALSE,quote=FALSE,sep='\t')


# title: fleet_classtree_train.r
# author: SAS Institute
# date: May 7, 2020

# Control to print all 13 digits
options(digits = 13)

# Load the necessary libraries
library(rpart)
library(rpart.plot)

# Specify location of the analysis folder
analysisFolder = 'C:\\MyJob\\Projects\\ModelManager\\Test\\Truck\\'
analysisPrefix = 'fleet_classtree'

# Specify location of the JSON folder
jsonFolder = 'C:\\MyJob\\Projects\\ModelManager\\Test\\Truck\\ClassTree\\R\\'

# Specify location of the custom source folder
sourceFolder = 'C:\\Users\\minlam\\Documents\\Research\\R\\'

# Bring in custom codes for exporting model
source(paste(sourceFolder, 'export_binary_model.r', sep = ''))

# Read the CSV data
inputData <- read.table(paste(analysisFolder, 'Truck_Train.csv', sep = ''), header = TRUE, sep = ',')

# Specify the target variables, the nominal predictors, and the interval predictors
targetVar <- 'Maintenance_flag'
intervalVars <- c('Speed_sensor', 'Vibration', 'Engine_Load', 'Coolant_Temp', 'Intake_Pressure', 'Engine_RPM', 'Speed_OBD',
                  'Intake_Air', 'Flow_Rate', 'Throttle_Pos', 'Voltage', 'Ambient', 'Accel', 'Engine_Oil_Temp', 'Speed_GPS',
                  'GPS_Longitude', 'GPS_Latitude', 'GPS_Bearing', 'GPS_Altitude', 'Turbo_Boost', 'Trip_Distance', 'Litres_Per_km',
                  'Accel_Ssor_Total', 'CO2', 'Trip_Time')

myvars <- c(targetVar, intervalVars)

# Threshold for the misclassification error
threshPredProb <- mean(inputData[[targetVar]], na.rm = TRUE)
print(paste('Observed Probability that ', targetVar, '= 1 is', threshPredProb))

# Remove all observations where the target variable is missing
trainData <- na.omit(inputData)

# Get ready for training the classification tree model.
# 1. Get threshold for the misclassification error

# Specify target as a factor
trainData[[targetVar]] <- as.factor(trainData[[targetVar]])
print(paste('Categories of', targetVar))
print(levels(trainData[[targetVar]]))

# A classification tree, do not carry competitors along, no surrogate, no cross-validation
# split if more than 50 observations, maximum depth is 10
myFormula <- paste(noquote(targetVar), '~')
qNotFirst = 0
for (col in c(intervalVars))
{
    if (qNotFirst == 1)
    {
        sepChar = ' + '
    }
    else
    {
        sepChar = ' '
        qNotFirst = 1
    }
    myFormula <- paste(myFormula, noquote(col), sep = sepChar)
}
print(myFormula)

myClassTree <- rpart(formula = myFormula, method = 'class', data = trainData, na.action = na.omit,
                     control = rpart.control(maxcompete = 0, maxsurrogate = 0, xval = 0,
                                             minsplit = 25, maxdepth = 10))

# Display the tree diagram
rpart.plot(myClassTree)
rpart.rules(myClassTree)

# See the model fit summary
print(summary(myClassTree))

# Calculate the prediction and save then to an external CSV file

# See the Misclassification Rate of the training data
fitted.prob <- predict(myClassTree, newdata = trainData, type = 'prob')
fitted.results <- ifelse(fitted.prob[,2] >= threshPredProb, 1, 0)

# Save the predictions to CSV
write.csv(cbind(trainData, fitted.prob, fitted.results), paste(jsonFolder, analysisPrefix, '_r_pred.csv', sep = ''))

# Types of the columns
typeOfColumn <- as.data.frame(do.call(rbind, lapply(inputData, typeof)))
print(typeOfColumn)

# Invoke this function to generate the zip package
export_binary_model (
    targetVar = targetVar,
    intervalVars = intervalVars,
    nominalVars = NULL,
    nominalVarsLength = NULL,
    typeOfColumn = typeOfColumn,
    targetValue = trainData[[targetVar]],
    eventValue = 1,
    predEventProb = fitted.prob[,2],
    eventProbThreshold = threshPredProb,
    algorithmCode = 3,
    modelObject = myClassTree,
    analysisFolder = analysisFolder,
    analysisPrefix = analysisPrefix,
    jsonFolder = jsonFolder,
    analysisName = 'Truck Fleet Maintenance',
    analysisDescription = 'Classification Tree Model: minsplit = 25, maxdepth = 10',
    lenOutClass = 1,
    qDebug = 'Y')

# THE END


  shannon.diversity = function(x, base=2, getid=TRUE) {
    rs = rowSums(x, na.rm=T)
    good = which(rs>0)
    if (length(good)==0) {
      if (getid) {
        out = rep(NA,4)
      } else {
        out = rep(NA,3)
      }
    }

    if (length(good)>0) {
      rs = rs[good]
      x = x[ good , ]
      id = rownames( x )
      pr = x / rs

      if (is.array(x) ) {
        shannon = - rowSums( pr * log( pr, base=base ), na.rm=T )
      } else {
        shannon = - sum( pr * log( pr, base=base ), na.rm=T )
      }

      Hmax = - log( rs, base=base )
      evenness = shannon / Hmax

      if (getid) {
        out = data.frame( id=id, shannon=shannon, evenness=evenness, Hmax=Hmax )
      } else {
        out = data.frame( shannon=shannon, evenness=evenness, Hmax=Hmax )
      }
    }

    return(out)
  }


library(dplyr)
library(readr)
library(tidyr)
library(caret)

data_train <- read.csv('./data/processed/processed_train.csv')

# use the right folding pattern
source("./scr/my_folds.r")

# Create reusable trainControl object: myControl
fitControl <- trainControl(
    summaryFunction = twoClassSummary,
    classProbs = TRUE,
    verboseIter = TRUE,
    savePredictions = 'final',
    index = my_folds
)

target <- 'brand'
predictors <- names(data_train)[!names(data_train) %in% target]

fit_rf_egb <- caretList(
    data_train[, predictors],
    data_train[, target],
    trControl = fitControl,
    methodList = c('C5.0', 'ranger'),
    metric = 'ROC'
)

stack_rf_egb <-
    caretStack(fit_rf_egb,
               method = 'glm',
               metric = 'ROC',
               trControl = fitControl)

saveRDS(stack_rf_egb, './models/C5.0_RF.rds')


##For non-split BiSSE
##Load dependencies
library(diversitree)
library(ape)
options(stringsAsFactors=F)
#For this analysis, we use a data file that's been made a little smaller than the 8000-taxon data set. Load it.
data <- read.csv('./Data/PyronParityData.csv', row.names=1)
# Initialize vectors. These will be used for formatting output.
output_vector <- data.frame()
ovip_root_vector <- data.frame()
vivip_root_vector <- data.frame()

#File currently set up to accept input from Make, or if trees in working directory
a<- list.files(path='./Trees/MLE/Dated/', pattern="test.*.dated", full.names=TRUE)
#Main function to fit model to each tree in BS sample
model_fit <- function(tree_list){
for (x in tree_list){
#For each tree in our vector of trees, read it in and distill down the tree to the shared tips between it and the data set
	phy <- read.tree(x)
  	phy <- multi2di(phy, random = TRUE)
	pruned.tree<-drop.tip(phy, c(setdiff(phy$tip.label, row.names(data))))
	sorteddata <- data[phy$tip.label, ]
	no_na <- na.omit(sorteddata)
	names(no_na) <- pruned.tree$tip.label
	#Make the BiSSE function
    func <- make.bisse(pruned.tree,no_na)
    func1 <- make.bisse(pruned.tree,no_na, sampling.f = .42)
    func2 <- make.bisse(pruned.tree,no_na, sampling.f = c(.47, .63))
	sp<-starting.point.bisse(pruned.tree)
	# Find MLE and use it to do ancestral state reconstruction
	fit_bisse <- find.mle(func, sp)
	fit_bisse1 <- find.mle(func1, sp)
	fit_bisse2 <- find.mle(func2, sp)
	#Add root states to a vector of states
	st <- asr.marginal(func, coef(fit_bisse))
	st1 <- asr.marginal(func, coef(fit_bisse1))
	st2 <- asr.marginal(func, coef(fit_bisse2))

	output_vector <- rbind(output_vector, c('Complete Sampling', fit_bisse$par[1:6], fit_bisse$lnLik))
    colnames(output_vector) <- c('param', 'lambda','lambda1','mu','mu1','q','q1','lik')
	output_vector <- rbind(output_vector, c('One-Term Sampling', fit_bisse2$par[1:6], fit_bisse2$lnLik, stringsAsFactors=F))
	output_vector <- rbind(output_vector, c('Two-Term Sampling', fit_bisse2$par[1:6], fit_bisse2$lnLik, stringsAsFactors=F))

	ovip_root_vector <- rbind(ovip_root_vector, c('Oviparity - Complete Sampling', st[,2][1]))
    colnames(ovip_root_vector) <- c('ov', 'param')
	ovip_root_vector <- rbind(ovip_root_vector, c('Oviparity - One-Term Sampling', st1[,2][1], stringsAsFactors=F))
	ovip_root_vector <- rbind(ovip_root_vector, c('Oviparity - Two-Term Sampling', st2[,2][1], stringsAsFactors=F))

	vivip_root_vector <- rbind(vivip_root_vector, c('Viviparity - Complete Sampling', st[,2][2]))
	colnames(ovip_root_vector) <- c('vi', 'param')
    vivip_root_vector <- rbind(vivip_root_vector, c('Viviparity - Complete Sampling', st1[,2][2], stringsAsFactors=F))
	vivip_root_vector <- rbind(vivip_root_vector, c('Viviparity - Two-Term Sampling', st2[,2][2], stringsAsFactors=F))

	#Plot tree
#	plot(pruned.tree, show.tip.label=F)
##	fit_plot <- nodelabels(pie=t(st), piecol=1:2, cex=.5)
	pruned.tree$node.label <- st[1,]
	new_name <- paste('annotatedUnopt_0', basename(x), sep = '_')
	write.tree(pruned.tree, file = new_name, append = FALSE, digits = 10, tree.names = FALSE)
	pruned.tree$node.label <- st1[1,]
	new_name <- paste('annotatedUnopt_1', basename(x), sep = '_')
	write.tree(pruned.tree, file = new_name, append = FALSE, digits = 10, tree.names = FALSE)
	pruned.tree$node.label <- st2[1,]
	new_name <- paste('annotatedUnopt_2', basename(x), sep = '_')
	write.tree(pruned.tree, file = new_name, append = FALSE, digits = 10, tree.names = FALSE)
	#Output various parameters: the model and ancestral states

	write.csv(output_vector, file = "unoptimized_model_params.csv")
	write.csv(ovip_root_vector, file = "unoptimized_ovip_support.csv")
	write.csv(vivip_root_vector, file = "unoptimized_vivip_support.csv")

}
warnings()

}

#Call the function if you want
model_fit(a)


################################################################################################
# Dependencies

PastStat<-function(data,field,fun,name) {

	# For a specified dataset, field, and statistic, returns a dataset with a column of unique
	# subject ids and the corresponding statistic over the first 91 days for those subject ids
	#
	# Args:
	# 	data: name of dataset, a list where each element corresponds to a unique subject id
	#	field: name of variable of interest
	#	fun: function to be applied to variable; e.g: max, min, mean, number
	#	name: name to be used for column with statistic of interest
	#
	# Returns:
	#	A dataset in which for each row corresponds to a unique subject.id.
	#	The columns consist of subject.id and features derived from the fvc
	# 	data.
	#
	# Example usage:
	#	#source("Code/past_stat.R")
	#	past.stat<-PastStat(data,"fvc.delta",max,"last.fvc.date")

	# Apply the desired function to each element in the list
	data<-lapply(data,function(data){
		stat<-fun(data[,colnames(data)==field])})
	# Put it in matrix form with one column for subject id and one column for score
	names<-as.numeric(names(data))
	stat<-as.numeric(unlist(data))
	data<-cbind(names,stat)
	colnames(data)<-c("subject.id",name)
	return(data)
}


context("y-structure")
library(AscRtain)

test_that("simulation", {
	a <- simulate_y_structure(n=50000000, prop=0.02, or_sz=3, b_xy=0, rsq_xs=0.2, rsq_ys=0.2, vx=1, vy=1, vs=1, sig.level=5e-8)
	expect_true(all(!is.na(unlist(a))))
	b <- simulate_y_structure(n=NA, prop=0.02, or_sz=3, b_xy=0, rsq_xs=0.2, rsq_ys=0.2, vx=1, vy=1, vs=1, sig.level=5e-8)
	expect_true(is.na(b$pow) & !is.na(b$bh_xy))
})

test_that("plot1", {
	a <- plot_simulate_y_structure(0.02, -0.03)
	expect_true("ggplot" %in% class(a))
})

test_that("plot2", {
	a <- plot_simulate_y_structure_optim(0.02, -0.03)
	expect_true("ggplot" %in% class(a))
})


#  James Rekow

meanDOCCreatorSubgroupsCheck = function(MVec = NULL, lambdaVec = NULL, subgroupVec = NULL, N = 20,
                                        iStrength = 1, univ = 1, sigmaMax = 0.1,
                                        thresholdMult = 10 ^ (-4), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                        intTime = 1, interSmplMult = 0.01){

  #  ARGS: MVec - vector of M values to use when creating cohorts
  #        lambdaVec - vector of lambda values to use when creating cohorts
  #        subgroupVec - vector of values controlling how many subgroups the created cohort will have.
  #                      Samples in different subgroups are created as if they were from different cohorts,
  #                      but interact together as a single cohort.
  #
  #  RETURNS: meanDOC - data frame containing the mean overlap and mean dissimilarity of DOC points from
  #                     cohorts created from each treatment of MVec crossed with lambdaVec crossed with
  #                     subgroupVec. Also contains a row with the value of lambda / M and a row
  #                     called fitCurve with the value of 1 - exp(-lambda / M) for each cohort.

  source("DOCProcedure.r")
  source("subgroupsAbdListCreator.r")
  library(igraph)

  #  set default value of MVec
  if(is.null(MVec)){
    MVec = seq(40, 200, 80)
  } #  end if

  #  set default value of lambdaVec
  if(is.null(lambdaVec)){
    lambdaVec = seq(0, 200, 50)
  } #  end if

  #  set default value of subgroupVec
  if(is.null(subgroupVec)){
    #  total number of groups in the cohort, so 1 subgroup indicates that all samples in the cohort
    #  have the same interaction matrix
    subgroupVec = c(1, 2, 3, 5, 10)
  } #  end if

  meanVecProducer = function(inputVec){

    #  ARGS: inputVec - a vector of the form c(M, lambda, numSubgroups)
    #
    #  RETURNS: meanVec - a vector of the form c(meanOver, meanDiss) containing the mean overlap and
    #                     mean dissimilarity of DOC points from a cohort created with the values of M
    #                     lambda, and numSubgroups specified by inputVec. The number of samples in each
    #                     subgroup is equal to floor(M / numSubgroups) or floor(M / numSubgroups) + 1,
    #                     depending on divisibility.

    #  extract parameter values
    M = inputVec[1]
    lambda = inputVec[2]
    numSubgroups = inputVec[3]

    #  create abdList with parameter values
    abdList = fracturedAbdListCreator(M = M, numSubgroups = numSubgroups, N = N, iStrength = iStrength,
                                      univ = univ, sigmaMax = sigmaMax, thresholdMult = thresholdMult,
                                      maxSteps = maxSteps, tStep = tStep, intTime = intTime,
                                      interSmplMult = interSmplMult, lambda = lambda, returnParams = FALSE,
                                      conGraph = NULL)

    #  compute DOC
    doc = DOCProcedure(abdList)

    #  compute mean overlap and dissimilarity
    meanOver = mean(doc[[1]])
    meanDiss = mean(doc[[2]])

    #  store means in a vector
    meanVec = c(meanOver, meanDiss)

    return(meanVec)

  } #  end meanVecProducer function

  #  create a matrix of all unique combinations of elements from Mvec, lambdaVec, and subgroupVec
  inputMat = expand.grid(MVec, lambdaVec, subgroupVec)

  #  for each combination of inputs, compute the mean overlap and dissimilarity of a DOC produced using
  #  those input values and store these means in a matrix
  meanMat = apply(inputMat, 1, meanVecProducer)

  #  extract mean overlap and mean dissimilarity from meanMat
  meanOver = meanMat[1, ]
  meanDiss = meanMat[2, ]

  #  store data in a data.frame
  meanDOC = data.frame(M = inputMat[ , 1], lambda = inputMat[ , 2], numSubgroups = inputMat[ , 3],
                       meanOver = meanOver, meanDiss = meanDiss)

  #  add a column storing the value of lambda / M for each cohort
  meanDOC$lambdaOverM = meanDOC$lambda / meanDOC$M

  #  add a column storing the value of the 1 - exp(-lambda / M) for each cohort
  meanDOC$overFitCurve = 1 - exp(-meanDOC$lambdaOverM)

  return(meanDOC)

} #  end meanDOCCreatorSubgroupsCheck function


# Databricks notebook source exported at Sun, 26 Jun 2016 01:44:37 UTC
# MAGIC %md
# MAGIC
# MAGIC # [Scalable Data Science](http://www.math.canterbury.ac.nz/~r.sainudiin/courses/ScalableDataScience/)
# MAGIC
# MAGIC
# MAGIC ### Course Project by [Akinwande Atanda](https://nz.linkedin.com/in/akinwande-atanda)
# MAGIC
# MAGIC *supported by* [![](https://raw.githubusercontent.com/raazesh-sainudiin/scalable-data-science/master/images/databricks_logoTM_200px.png)](https://databricks.com/)
# MAGIC and
# MAGIC [![](https://raw.githubusercontent.com/raazesh-sainudiin/scalable-data-science/master/images/AWS_logoTM_200px.png)](https://www.awseducate.com/microsite/CommunitiesEngageHome)

# COMMAND ----------

# MAGIC %md
# MAGIC The [html source url](https://raw.githubusercontent.com/raazesh-sainudiin/scalable-data-science/master/db/studentProjects/02_AkinwandeAtanda/Tweet_Analytics/044_TA03_01_binary_classification.html) of this databricks notebook and its recorded Uji ![Image of Uji, Dogen's Time-Being](https://raw.githubusercontent.com/raazesh-sainudiin/scalable-data-science/master/images/UjiTimeBeingDogen.png "uji"):
# MAGIC
# MAGIC [![sds/uji/studentProjects/02_AkinwandeAtanda/Tweet_Analytics/044_TA03_01_binary_classification](http://img.youtube.com/vi/zJirlHAV6YU/0.jpg)](https://www.youtube.com/v/zJirlHAV6YU?rel=0&autoplay=1&modestbranding=1&start=0&end=1611)

# COMMAND ----------

# MAGIC %md
# MAGIC #Tweet Analytics
# MAGIC
# MAGIC [Presentation contents](https://github.com/aaa121/Spark-Tweet-Streaming-Presentation-May-2016).

# COMMAND ----------

# MAGIC %md
# MAGIC ## Explore the POS_NEG_CATEGORY DATASET
# MAGIC * Download the featured dataset ["pos_neg_category"](https://raw.githubusercontent.com/aaa121/Spark-Tweet-Streaming-Presentation-May-2016/master/pos_neg_category.csv)
# MAGIC * Upload as a Table and change the data type for the "category" column to double

# COMMAND ----------

# MAGIC %sql cache table pos_neg_category

# COMMAND ----------

# MAGIC %sql SELECT category, count(*) as wordCount FROM pos_neg_category group by category order by category

# COMMAND ----------

# MAGIC %sql SELECT if(category == 1, "positive", "negative") as classification, count(*) as wordCount
# MAGIC FROM pos_neg_category group by category order by category

# COMMAND ----------

# MAGIC %md
# MAGIC ## Featurization

# COMMAND ----------

classWords <-table(sqlContext,"pos_neg_category")
classWords

# COMMAND ----------

select(classWords, classWords$category, contains(classWords$review, "amazing"))

# COMMAND ----------

df <- select(classWords, classWords$category, alias(contains(classWords$review, "bad"), "has_word"))
crosstab(df, "category", "has_word")

# COMMAND ----------

# MAGIC %md
# MAGIC
# MAGIC # [Scalable Data Science](http://www.math.canterbury.ac.nz/~r.sainudiin/courses/ScalableDataScience/)
# MAGIC
# MAGIC
# MAGIC ### Course Project by [Akinwande Atanda](https://nz.linkedin.com/in/akinwande-atanda)
# MAGIC
# MAGIC *supported by* [![](https://raw.githubusercontent.com/raazesh-sainudiin/scalable-data-science/master/images/databricks_logoTM_200px.png)](https://databricks.com/)
# MAGIC and
# MAGIC [![](https://raw.githubusercontent.com/raazesh-sainudiin/scalable-data-science/master/images/AWS_logoTM_200px.png)](https://www.awseducate.com/microsite/CommunitiesEngageHome)


#' return_pD.r
#' Gets site-level ddirch model pD value.
#'
#' @param y            #matrix of observed relative abundances used to fit the original model.
#' @param x_mu         #matrix of predictors used to fit original model. No missing values allowed!
#' @param x.mm         #parameter matrix returned from original model.
#' @param alpha        #alpha parameter of original model.
#' @param silent.jags  #if TRUE then JAGS model fitting will shut up.
#'
#' @return             #returns the pD value.
#' @export
#'
#' @examples
#' y=y;x=x_mu; x.mm=fit$x.mm;alpha=fit$alpha;silent.jags=F
return_pD <- function(y, x_mu, x.mm, alpha, silent.jags = F){
  #Specify the JAGS model. This is all it is. can add in variation in x-predictors, return a pD probability distribution, but its really narrow.
  y <- as.matrix(y)
  x_mu <- as.matrix(x_mu)

  fix.model = "
  model{
  #mean center all predictors (except intercept).
  for(i in 1:N){
    x.center[i,1] <- 1
      for(j in 2:N.preds){
        x.center[i,j] <- x[i,j] - mean(x[,j])
    }
  }

  #fit species abundances as a linear combination of predictors and parameters.
  for(i in 1:N){
    for(j in 1:N.spp){
      log(a0[i,j]) <- alpha + inprod(x.mm[,j], x.center[i,])
    }
    y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }

  } #close model loop.
  "

  #setup new JAGS data object with parameters fixed at means.
  new.data <- list(y=y, x=x_mu, N=nrow(y), N.spp = ncol(y), N.preds = ncol(x_mu), x.mm=x.mm, alpha = alpha)

  #fit the JAGS model.
  jags.out <- runjags::run.jags(   model = fix.model,
                                   data = new.data,
                                   adapt = 0,
                                   burnin = 0,
                                   sample = 100,
                                   n.chains = 3,
                                   method = 'rjags',
                                   silent.jags = silent.jags,
                                   monitor = c('deviance'))
  jags.sum <- summary(jags.out)
  pD <- jags.sum[1,3]
  return(pD)
}