# Sample of ways to play with the assembly summaries

# Note that you should run this script piecemeal.
# Start by loading the data in BLOCK 1.

# things to try
#  - only look at specific types of errors (e.g., ignore coverage type errors)
#    do the results change?
#  - Can you see things better in log space?

########################
### BLOCK 1: Data input
########################
# Reading the summary file from VALET
datadir <- "../"
summary.hmp <- read.csv(paste0(datadir, "SRS014465_hmp_valet/summary.tsv"),
                        head=T, row.names=1, sep="\t", check.names=F)
summary.hmp[is.na(summary.hmp)] <- 0
sizes.hmp <- summary.hmp[,'contig_length', drop=FALSE] # all contig sizes

summary.soap <- read.csv(paste0(datadir, "SRS014465_soap_valet/summary.tsv"),
                         head=T, row.names=1, sep="\t", check.names=F)
summary.soap[is.na(summary.soap)] <- 0
sizes.soap <- summary.soap[,'contig_length', drop=FALSE]

summary.spades <- read.csv(paste0(datadir,"SRS014465_spades_valet/summary.tsv"),
                           head=T, row.names=1, sep="\t", check.names=F)
summary.spades[is.na(summary.spades)] <- 0
sizes.spades <- summary.spades[,'contig_length', drop=FALSE]

summary.idba <- read.csv(paste0(datadir, "SRS014465_idba_valet/summary.tsv"),
                         head=T, row.names=1, sep="\t", check.names=F)
summary.idba[is.na(summary.idba)] <- 0
sizes.idba <- summary.idba[,'contig_length', drop=FALSE]

errorCols <- c("low_cov", "high_cov", "reapr", "breakpoints") # total number of errors
errorBpsCols <- c("low_cov_bps", "high_cov_bps", "reapr_bps", "breakpoints_bps") # total number of basepairs in errors

##################################
### BLOCK 2: Contiguity statistics
##################################
# Compute general assembly statistics

contigs.tmp <- rev(sort(sizes.hmp[,1]))
n50.tmp <- contigs.tmp[cumsum(contigs.tmp) >= sum(contigs.tmp)/2][1]
stats.hmp <- c(length(sizes.hmp[,1]), mean(sizes.hmp[,1]), median(sizes.hmp[,1]), sum(sizes.hmp[,1]), n50.tmp)

contigs.tmp <- rev(sort(sizes.soap[,1]))
n50.tmp <- contigs.tmp[cumsum(contigs.tmp) >= sum(contigs.tmp)/2][1]
stats.soap <- c(length(sizes.soap[,1]), mean(sizes.soap[,1]), median(sizes.soap[,1]), sum(sizes.soap[,1]), n50.tmp)

contigs.tmp <- rev(sort(sizes.spades[,1]))
n50.tmp <- contigs.tmp[cumsum(contigs.tmp) >= sum(contigs.tmp)/2][1]
stats.spades <- c(length(sizes.spades[,1]), mean(sizes.spades[,1]), median(sizes.spades[,1]), sum(sizes.spades[,1]), n50.tmp)

contigs.tmp <- rev(sort(sizes.idba[,1]))
n50.tmp <- contigs.tmp[cumsum(contigs.tmp) >= sum(contigs.tmp)/2][1]
stats.idba <- c(length(sizes.idba[,1]), mean(sizes.idba[,1]), median(sizes.idba[,1]), sum(sizes.idba[,1]), n50.tmp)

all.contiguity.stats <- rbind(stats.hmp, stats.soap, stats.spades, stats.idba)
rownames(all.contiguity.stats) <- c("HMP", "SoapDenovo", "Spades", "IDBA-UD")
colnames(all.contiguity.stats) <- c("num", "mean size", "median size", "total size", "n50 size")

all.contiguity.stats

#########################################
#### BLOCK 3 - Size plots
#########################################
contigSizes.hmp <- summary.hmp[order(summary.hmp[, "contig_length"], decreasing=T), "contig_length"]
contigSums.hmp <- cumsum(contigSizes.hmp)
contigNum.hmp <- c(rep(1, length(contigSizes.hmp)))
contigNum.hmp <- cumsum(contigNum.hmp)

contigSizes.soap <- summary.soap[order(summary.soap[, "contig_length"], decreasing=T), "contig_length"]
contigSums.soap <- cumsum(contigSizes.soap)
contigNum.soap <- c(rep(1, length(contigSizes.soap)))
contigNum.soap <- cumsum(contigNum.soap)

contigSizes.spades <- summary.spades[order(summary.spades[, "contig_length"], decreasing=T), "contig_length"]
contigSums.spades <- cumsum(contigSizes.spades)
contigNum.spades <- c(rep(1, length(contigSizes.spades)))
contigNum.spades <- cumsum(contigNum.spades)

contigSizes.idba <- summary.idba[order(summary.idba[, "contig_length"], decreasing=T), "contig_length"]
contigSums.idba <- cumsum(contigSizes.idba)
contigNum.idba <- c(rep(1, length(contigSizes.idba)))
contigNum.idba <- cumsum(contigNum.idba)

par(mfrow=c(1,2))
# Size plots
# N50 plot - contig size by cumulative contig size (how much of the assembly is contained in contigs greater than x)
plot(contigSizes.hmp, contigSums.hmp, type='l', #log="y",
     xlim=rev(range(contigSizes.hmp, contigSizes.spades, contigSizes.soap, contigSizes.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.spades, contigSums.soap, contigSums.idba)),
     main="Cumulative contig sizes",
     xlab="Contig size",
     ylab="Cumulative contig size")
abline(h=max(contigSums.soap)/2, col='red')
abline(h=max(contigSums.idba)/2, col='green')
par(new=T)
plot(contigSizes.spades, contigSums.spades, type='l', #log="y",
     xlim=rev(range(contigSizes.hmp, contigSizes.spades, contigSizes.soap, contigSizes.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.spades, contigSums.soap, contigSums.idba)),
     main="Cumulative contig sizes", col="blue",
     xlab="Contig size",
     ylab="Cumulative contig size")
par(new=T)
plot(contigSizes.soap, contigSums.soap, type='l', #log="y",
     xlim=rev(range(contigSizes.hmp, contigSizes.spades, contigSizes.soap, contigSizes.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.spades, contigSums.soap, contigSums.idba)),
     main="Cumulative contig sizes", col="red",
     xlab="Contig size",
     ylab="Cumulative contig size")
par(new=T)
plot(contigSizes.idba, contigSums.idba, type='l', # log="y",
     xlim=rev(range(contigSizes.hmp, contigSizes.spades, contigSizes.soap, contigSizes.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.spades, contigSums.soap, contigSums.idba)),
     main="Cumulative contig sizes", col="green",
     xlab="Contig size",
     ylab="Cumulative contig size")
legend(x=80000, y=10000000,border="black",
       legend=c("HMP", "Soap", "spades", "IDBA-UD"),
       col=c("black", "red", "blue", "green"),
       pch=c(19,19,19,19))

# count50 plot - number of contigs needed to reach a certain total amount of sequence
# red line is half of the total sequence in the HMP assembly
plot(contigNum.hmp, contigSums.hmp, type='l', #log="y",
     xlim=c(0,max(contigNum.hmp, contigNum.soap, contigNum.spades, contigNum.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.soap, contigSums.spades, contigSums.idba)),
     main="Cumulative contig numbers",
     xlab="Number of contigs",
     ylab="Cumulative contig size")
abline(h=max(contigSums.soap)/2, col='red')
abline(h=max(contigSums.idba)/2, col='green')
par(new=T)
plot(contigNum.soap, contigSums.soap, type='l', #log="y",
     xlim=c(0,max(contigNum.hmp, contigNum.soap, contigNum.spades, contigNum.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.soap, contigSums.spades, contigSums.idba)),
     main="Cumulative contig numbers",
     col="red",
     xlab="Number of contigs",
     ylab="Cumulative contig size")
par(new=T)
plot(contigNum.spades, contigSums.spades, type='l', #log="y",
     xlim=c(0,max(contigNum.hmp, contigNum.soap, contigNum.spades, contigNum.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.soap, contigSums.spades, contigSums.idba)),
     col="blue",
     main="Cumulative contig numbers",
     xlab="Number of contigs",
     ylab="Cumulative contig size")
par(new=T)
plot(contigNum.idba, contigSums.idba, type='l', #log="y",
     xlim=c(0,max(contigNum.hmp, contigNum.soap, contigNum.spades, contigNum.idba)),
     ylim=c(1, max(contigSums.hmp, contigSums.soap, contigSums.spades, contigSums.idba)),
     col="green",
     main="Cumulative contig numbers",
     xlab="Number of contigs",
     ylab="Cumulative contig size")
legend(x=100, y=10000000,border="black",
       legend=c("HMP", "Soap", "spades", "IDBA-UD"),
       col=c("black", "red", "blue", "green"),
       pch=c(19,19,19,19))

##############################
### BLOCK 4: Basic scatterplot
##############################
# basic scatterplot - outliers are contigs with more errors than the 'baseline'
## Run each block of 2 lines separately

## Or put them all in one plot
par(mfrow=c(2,2))
totErrors.hmp<- rowSums(summary.hmp[,errorCols])
plot(summary.hmp[,"contig_length"], totErrors.hmp, main="HMP errors/bp", xlab="contig size", ylab="# errors")
totErrors.soap<- rowSums(summary.soap[,errorCols])
plot(summary.soap[,1], totErrors.soap, main="SOAP errors/bp", xlab="contig size", ylab="# errors")
totErrors.spades<- rowSums(summary.spades[,errorCols])
plot(summary.spades[,1], totErrors.spades, main="SPADES errors/bp", xlab="contig size", ylab="# errors")
totErrors.idba<- rowSums(summary.idba[,errorCols])
plot(summary.idba[,1], totErrors.idba, main="IDBA-UD errors/bp", xlab="contig size", ylab="# errors")

#####################################
### BLOCK 5 - Feature Response Curve
#####################################

# if you haven't run block 3 run this:
totErrors.hmp<- rowSums(summary.hmp[,errorCols])
totErrors.soap<- rowSums(summary.soap[,errorCols])
totErrors.spades<- rowSums(summary.spades[,errorCols])
totErrors.idba<- rowSums(summary.idba[,errorCols])

par(mfrow=c(1,1))

contigSizes.hmp <- summary.hmp[order(summary.hmp[, "contig_length"], decreasing=T), "contig_length"]
contigErrors.hmp <- totErrors.hmp[order(summary.hmp[,"contig_length"], decreasing=T)]

contigSums.hmp <- cumsum(contigSizes.hmp)
errorSums.hmp <- cumsum(contigErrors.hmp)

contigNum.hmp <- c(rep(1, length(contigSizes.hmp)))
contigNum.hmp <- cumsum(contigNum.hmp)

contigSizes.soap <- summary.soap[order(summary.soap[, "contig_length"], decreasing=T), "contig_length"]
contigErrors.soap <- totErrors.soap[order(summary.soap[,"contig_length"], decreasing=T)]

contigSums.soap <- cumsum(contigSizes.soap)
errorSums.soap <- cumsum(contigErrors.soap)

contigNum.soap <- c(rep(1, length(contigSizes.soap)))
contigNum.soap <- cumsum(contigNum.soap)

contigSizes.spades <- summary.spades[order(summary.spades[, "contig_length"], decreasing=T), "contig_length"]
contigErrors.spades <- totErrors.spades[order(summary.spades[,"contig_length"], decreasing=T)]

contigSums.spades <- cumsum(contigSizes.spades)
errorSums.spades <- cumsum(contigErrors.spades)

contigNum.spades <- c(rep(1, length(contigSizes.spades)))
contigNum.spades <- cumsum(contigNum.spades)

contigSizes.idba <- summary.idba[order(summary.idba[, "contig_length"], decreasing=T), "contig_length"]
contigErrors.idba <- totErrors.idba[order(summary.idba[,"contig_length"], decreasing=T)]

contigSums.idba <- cumsum(contigSizes.idba)
errorSums.idba <- cumsum(contigErrors.idba)

contigNum.idba <- c(rep(1, length(contigSizes.idba)))
contigNum.idba <- cumsum(contigNum.idba)

xrange <- max(max(errorSums.spades, na.rm=T),
              max(errorSums.hmp, na.rm=T),
              max(errorSums.soap,na.rm=T),
              max(errorSums.idba,na.rm=T))
yrange <- max(max(contigSums.hmp), max(contigSums.soap), max(contigSums.spades), max(contigSums.idba))

##  Plot the 'feature response curve' - # errors by cumulative contig size.
##
## For the rest of the plots, black line is HMP, blue is Spades and red is Soap

plot(errorSums.hmp, contigSums.hmp, #/contigSums.hmp[length(contigSums.hmp)],
     type='l', # log="y",
     main = "FRC",
     xlab="# errors",
     ylab="% assembly covered",
     ylim=c(1,yrange),
     xlim=c(0,xrange))

par(new=T)

plot(errorSums.soap, contigSums.soap, #/contigSums.soap[length(contigSums.soap)],
   type='l', #log="y",
     # main = "FRC HMP",
   #  xlab="# errors",
   #  ylab="% assembly covered")
   xlim=c(0,xrange),
   ylim=c(1,yrange),
   ylab="", xlab="", col="red")

par(new=T)

plot(errorSums.spades, contigSums.spades, #/contigSums.spades[length(contigSums.spades)],
     type='l', # log="y",
     # main = "FRC HMP",
     #  xlab="# errors",
     #  ylab="% assembly covered")
     xlim=c(0,xrange),
     ylim=c(1,yrange),
     ylab="", xlab="", col="blue")

par(new=T)

plot(errorSums.idba, contigSums.idba, #/contigSums.idba[length(contigSums.idba)],
     type='l', # log="y",
     # main = "FRC HMP",
     #  xlab="# errors",
     #  ylab="% assembly covered")
     xlim=c(0,xrange),
     ylim=c(1,yrange),
     ylab="", xlab="", col="green")

legend(x=100, y=10000000,border="black",
       legend=c("HMP", "Soap", "spades", "IDBA-UD"),
       col=c("black", "red", "blue", "green"),
       pch=c(19,19,19,19))


permutation.test.discrete <-
function (x, y=NULL, scores, alternative="greater", trials=1000)
{
	# set up x and y properly
	if(length(y)) {
		n <- length(y)
		if(length(x) != n) stop("x and y have different lengths")
	} else {
		if(ncol(x) != 2)
			stop("x does not have 2 columns and y is missing")
		y <- x[, 2]
		x <- x[, 1]
		n <- length(y)
	}
	x <- as.character(x)
	y <- as.character(y)

	# set up alternative
	if(length(alternative) != 1 || !is.character(alternative))
		stop("alternative must be a single character string")
	altnum <- pmatch(alternative, c("greater", "less"), nomatch=NA)
	if(is.na(altnum))
		stop("alternative must partially match 'greater' or 'less'")
	alternative <- c("greater", "less")[altnum]

	# set up scores properly
	orig.tab <- table(x, y)
	otd <- dim(orig.tab)
	odnam <- dimnames(orig.tab)
	scnam <- dimnames(scores)
	if(!is.matrix(scores) || length(scnam) != 2 || !is.numeric(scores))
		stop("scores must be a numeric matrix with dimnames")
	scd <- dim(scores)
	if(any(scd != otd) && any(rev(scd) != otd)) {
		stop(paste("scores is not the proper size, should be",
			otd[1], "by", otd[2]))
	}
	if(any(scd != otd)) {
		scores <- t(scores)
		scd <- dim(scores)
		scnam <- dimnames(scores)
		reverse <- TRUE
	} else {
		reverse <- FALSE
	}
	rownum <- match(scnam[[1]], odnam[[1]], nomatch=NA)
	if(any(is.na(rownum))) {
		if(reverse || otd[1] != otd[2])
			stop("bad dimnames for scores")
		scores <- t(scores)
		scd <- dim(scores)
		scnam <- dimnames(scores)
		rownum <- match(scnam[[1]], odnam[[1]], nomatch=NA)
		if(any(is.na(rownum))) stop("bad dimnames for scores")
	}
	colnum <- match(scnam[[2]], odnam[[2]], nomatch=NA)
	if(any(is.na(colnum))) stop("bad dimnames for scores")
	scores <- scores[rownum, colnum]

	# the main event
	ranseed <- .Random.seed
	orig.score <- sum(orig.tab * scores)
	perm.scores <- numeric(trials)
	for(i in 1:trials) {
		perm.scores[i] <- sum(table(x, sample(y)) * scores)
	}

	if(alternative == "greater") {
		extreme <- sum(perm.scores >= orig.score)
	} else {
		extreme <- sum(perm.scores <= orig.score)
	}
	ans <- list(original.score=orig.score, perm.scores=perm.scores,
		stats=c(nobs=n, trials=trials, extreme=extreme),
		alternative=alternative, random.seed=ranseed, call=match.call())
	class(ans) <- "permtstBurSt"
	ans
}
permutation.test.fun <-
function (x, y=NULL, fun=function(x, y) sum(x * y), alternative="greater",
	trials=1000)
{
	# set up x and y properly
	if(length(y)) {
		n <- length(y)
		if(length(x) != n) stop("x and y have different lengths")
		if(!is.numeric(y)) stop("y must be numeric")
	} else {
		if(ncol(x) != 2)
			stop("x does not have 2 columns and y is missing")
		x <- as.matrix(x)
		if(!is.numeric(x)) stop("x must be numeric")
		y <- x[, 2]
		x <- x[, 1]
		n <- length(y)
	}

	# set up alternative
	if(length(alternative) != 1 || !is.character(alternative))
		stop("alternative must be a single character string")
	altnum <- pmatch(alternative, c("greater", "less"), nomatch=NA)
	if(is.na(altnum))
		stop("alternative must partially match 'greater' or 'less'")
	alternative <- c("greater", "less")[altnum]

	# the main event
	ranseed <- .Random.seed
	orig.score <- fun(x, y)
	if(length(orig.score) != 1) stop("fun must return a single number")

	perm.scores <- numeric(trials)
	for(i in 1:trials) {
		perm.scores[i] <- fun(x, sample(y))
	}

	if(alternative == "greater") {
		extreme <- sum(perm.scores >= orig.score)
	} else {
		extreme <- sum(perm.scores <= orig.score)
	}
	ans <- list(original.score=orig.score, perm.scores=perm.scores,
		stats=c(nobs=n, trials=trials, extreme=extreme),
		alternative=alternative, random.seed=ranseed, call=match.call())
	class(ans) <- "permtstBurSt"
	ans
}
plot.permtstBurSt <-
function (x, col=c("black", "red"), width=10, uniqlim=40, main="",
	xlab="Scores", col.hist="yellow", ...)
{
	orig.score <- x$original.score
	ulen <- length(unique(x$perm.scores))
	if(ulen > uniqlim) {
		hist(x$perm.scores, xlim=range(x$perm.scores, orig.score),
			 main=main, xlab=xlab, col=col.hist,  ...)
		box()
		abline(v=orig.score, col=col[2])
	} else {
		ptab <- table(x$perm.scores)
		vals <- as.numeric(names(ptab))
		if(x$alternative == "greater") {
			extreme <- vals >= orig.score
		} else {
			extreme <- vals <= orig.score
		}
		if(all(vals > orig.score) || all(vals < orig.score)) {
			xrng <- range(vals, orig.score)
		} else {
			xrng <- range(vals)
		}
		plot(vals, as.vector(ptab), type="n", xlab=xlab, ylab="Count",
			xlim=xrng, ...)
		points(vals[!extreme], ptab[!extreme], type="h",
			col=col[1], lwd=width, ...)
		points(vals[extreme], ptab[extreme], type="h",
			col=col[2],  lwd=width, ...)
		if(nchar(main)) title(main=main)
	}
}
print.permtstBurSt <-
function (x, digits=4, ...)
{
	cat("Call:\n")
	print(x$call)
	cat("\nOriginal value:", x$original.score, "  Number of observations:",
		x$stats["nobs"], "\n")
	cat("Number of random permutations:", x$stats["trials"],
		"  Alternative:", x$alternative, "  p-value:",
		round(x$stats["extreme"] / x$stats["trials"], digits), "\n")
	invisible(x)
}
superscore <-
structure(c(1, 0, 0, 1), .Dim = c(2L, 2L), .Dimnames = list(c("Up",
"Down"), c("National", "American")))


View(mtcars)

mt1 = mtcars[mtcars$mpg>20,c('gear','mpg')]
View(mt1)

mt2 = aggregate(. ~ gear,mtcars[mtcars$mpg>20,c('gear','mpg')],mean)
View(mt2)

mt3 = subset(aggregate(. ~ gear,mtcars[mtcars$mpg>20,c('gear','mpg')],mean), mpg>25)
View(mt3)


library(R2WinBUGS)
library(BRugs)
dat=read.csv("c4photosynthesis.csv",header=T)
#dat2=read.csv('c4covariates.csv',header=T)

my.model  = function(){
  alpha ~ dlnorm(-3.21,3.7) 	    	## initial slope of photosynthesis light response
  vmax~dlnorm(3,3)                  ## maximum rubisco capacity
  r ~ dlnorm(-0.2,2.8)              ## leaf respiration
  k ~ dlnorm(11.5, 2.8)             ## initial slope of photosynthetic CO2 response
  tau ~ dgamma(0.1,0.1)
#  beta1 ~ dnorm(0,0.1)             ## chlorophyll effects
#  beta2 ~ dnorm(0,0.1)             ## SLA effects
#  beta5 ~ dnorm(0,0.1)             ## Vmax effects

#  tau.Vleaf~dgamma(0.01,0.01)      ## random leaf effects on vmax
#  tau.Kleaf~dgamma(0.01,0.01)      ## random leaf effects on k
#  tau.Vmon~dgamma(0.01,0.01)       ## month effects on vmax, fixed

#  for(i in 1:nrep){
#   Vleaf[i]~dnorm(0,tau.Vleaf)
#   Kleaf[i]~dnorm(0,tau.Kleaf)
#   }
#   Vmon[7]<-0                      ## reference month
#   Vmon[8]~ dnorm(0,tau.Vmon)
#   Vmon[5]~ dnorm(0,tau.Vmon)
#   Vmon[6]~ dnorm(0,tau.Vmon)
#   Vmon[9]~ dnorm(0,tau.Vmon)
#   Vmon[10]~ dnorm(0,tau.Vmon)

  for(i in 1:n  ){                 ## process model
#    al[i]<-(alpha+inc[1]*beta1*(chl[rep[i]]-chlave)+inc[2]*beta2*(sla[rep[i]]-slaave))*q[i]          ## light limited with chlorophyll, SLA and random leaf effects turned on
    al[i]<- alpha*q[i]                                                                                ## light limited without covariates
#    ac[i]<-(k + inc[3]*Kleaf[rep[i]])*pi[i]/100000                                                   ## CO2 limited with random leaf effects turned on
    ac[i]<-k*pi[i]/100000                                                    ## CO2 limited without covariates
#    ae[i]<-vmax + inc[4]*Vmon[month[i]]+inc[5]*beta5*(leafn[rep[i]]-leafnave)+inc[6]*Vleaf[rep[i]]   ## rubisco limited with leaf N, month and random leaf effects turned on
    ae[i]<-vmax                                                                                ## rubisco limited without covariates
    prean[i]<-min(min(al[i],ac[i]),ae[i])-r
    an[i]~dnorm(prean[i],tau)                                                                         ## likelihood
    pA[i] ~ dnorm(prean[i],tau)                                                                       ## prediction
    }
}

write.model(my.model,"c4model.txt")

init<-list()
 init[[1]]<-list(r=0.8, vmax=30,alpha=0.03, tau=10, k=0.7*100000)   ## ,tau.Vleaf=300,tau.Kleaf=1e-10, beta1=4, beta2=1,beta5=3,tau.Vmon=10
 init[[2]]<-list(r=1, vmax=20, alpha=0.07, tau=20, k=0.8*100000)    ## ,tau.Vleaf=200,tau.Kleaf=2e-9,beta1=1,beta2=1,beta5=-1,tau.Vmon=20
 init[[3]]<-list(r=2, vmax=15,alpha=0.06, tau=20, k=0.2*1000000)    ## ,tau.Vleaf=100,tau.Kleaf=3e-8,beta1=1,beta2=2,beta5=2,tau.Vmon=3

 spp.list = unique(as.character(dat$id))
 c4mcmc <- list()

 for(s in spp.list){
  sel = which(dat$id == s)
  an=dat$Photo[sel]
  pi=dat$Ci_Pa[sel]
  q=dat$PARi[sel]
#  rep=dat$rep[sel]      ## turn on random leaf effects
#  reps = unique(rep)
#  rep = match(rep,reps)
#  nrep = length(reps)
#  month=dat$month[sel]

## covariate data from dat2
#  sel2=which(dat2$id==s)
#  chl=dat2$chl[sel2]
#  leafn=dat2$leafn[sel2]
#  sla=dat2$sla[sel2]
#  rep2 = dat2$rep[sel2]  # didn't work
#  rep2 = match(rep2,reps)
#  chlave=mean(chl)
#  leafnave=mean(leafn)
#  slaave=mean(sla)

 c4 <- openbugs(data=list(an=an, pi=pi, q=q,n=length(an)),
#rep=rep,nrep=nrep, chl=chl,leafn=leafn, sla=sla, chlave=chlave,leafnave=leafnave,slaave=slaave,month=month
 init,
 model.file="c4model.txt",
 n.chains=3,
 n.iter=1000,
 n.burnin=500,
 n.thin =25,
 parameters.to.save=c("r","vmax","alpha", "k", "prean", "pA")
# "beta1","beta2","beta5","Vmon","Vleaf","Kleaf","tau","tau.Vmon","tau.Vleaf","tau.Kleaf",
 )
  c4mcmc[[s]]=c4
}
## make trace and density plots
for(s in spp.list){
pdf(paste(s, " model trace.pdf",sep=""))
plot(as.mcmc.list(c4mcmc[[s]]))
dev.off()
}

## predictions vs measurements
par(mfrow=c(1,2))
for(s in spp.list){
sel1=which(dat$id==s)
an=dat$Photo[sel1]
plot(an,c4mcmc[[s]]$mean$prean, ylim=c(-5,40),xlim=c(-5,40), pch=19,
main="Predicted photosynthesis vs measured phtosynthesis", xlab="Measured An (umol m-2 s-1)",
ylab="Predicted An (umol m-2 s-1)",cex.main=1.6,cex.lab=1.4)
abline(0,1, col="dark green",lwd=3)
}


library(fpp)
library(lubridate)
library(plyr)
library(stlplus)
library(pander)
library(xtable)
library(grid)
library(gridExtra)
library(gtable)
library(fpp)
library(ggfortify)

widthGraphs <- 10

plotTimeseries <- function(tserie, title, path, save = TRUE) {
  # Plot della serie storica passata in input
  #
  # Args:
  #   tserie: serie storica in formato ts
  #   tittle: titolo da visualizzare nel plot
  theme_set(theme_bw())
  df <- data.frame(Y=as.matrix(tserie), date=as.Date(as.yearmon(time(tserie))))

  ggplot(df, aes(x=date)) +
    geom_line(aes(y=Y), color="blue") +
    labs(title=title,
         y="Number of Flights", x = "Time",
         subtitle=paste("Time series"),
         color=NULL) +  # title and caption
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank())

  if(save){
    ggsave(paste(path,title,".jpg", sep=""), width = widthGraphs)
  }

  ggseasonplot(tserie, main=paste(sep="","Seasonal Plot ",title))

  if(save){
    ggsave(paste(path,"Boxplot ", title,".jpg", sep=""), width = widthGraphs)
  }

  autoplot(decompose(tserie), main= paste("Decomposition", title))

  if(save){
    ggsave(paste(path,"Decomposition ", title,".jpg", sep=""), width = widthGraphs)
  }

  dir.create(file.path(path, "CorrelationPlots//"), showWarnings = FALSE)

  #ACF e PACF
  require(cowplot)

  plot_grid(ggAcf(tserie, main=paste("ACF", title)), ggPacf(tserie, main=paste("PACF", title)))
  if(save){
    ggsave(paste(paste(path, "CorrelationPlots//", sep = ""),"1 ACF_PACF plot ", title,".jpg", sep=""), width = widthGraphs)
  }

  #detrend time series
  tserieDeTrend <- stl(tserie, s.window = 'periodic')$time.series[,2]
  tserieDeTrend <- tserie - tserieDeTrend
  autoplot(tserieDeTrend, main=paste("Detrend ", title), ylab = "Number of Flights", xlab="time")

  if(save){
    ggsave(paste(paste(path, "CorrelationPlots//", sep = ""),"2 Detrend ", title,".jpg", sep=""), width = widthGraphs)
  }

  #PACF e ACF detrend
  plot_grid(ggAcf(tserieDeTrend, main=paste("ACF Detrend", title)), ggPacf(tserieDeTrend, main=paste("PACF Detrend", title)))
  if(save){
    ggsave(paste(paste(path, "CorrelationPlots//", sep = ""),"3 ACF_PACF Detrend plot ", title,".jpg", sep=""), width = widthGraphs)
  }

  #remove season
  tserieDeTrendDeSeason <- diff(tserieDeTrend, lG = 12)
  autoplot(tserieDeTrendDeSeason, main=paste("Detrend, Deseason ", title), ylab = "Number of Flights", xlab="time")
  if(save){
    ggsave(paste(paste(path, "CorrelationPlots//", sep = ""),"4 Detrend, DeSeason ", title,".jpg", sep=""), width = widthGraphs)
  }
  #ACF e PACF
  plot_grid(ggAcf(tserieDeTrendDeSeason, main=paste("ACF Detrend, DeSeason", title)), ggPacf(tserieDeTrendDeSeason, main=paste("PACF Detrend, DeSeason", title)))
  if(save){
    ggsave(paste(paste(path, "CorrelationPlots//", sep = ""),"5 ACF_PACF Detrend, DeSeason plot ", title,".jpg", sep=""), width = widthGraphs)
  }

}

plotForecastTrainingSet <- function(tserie, tWindow = 36, title, path, save = TRUE){
  # Training di diversi modelli di previsione a partire dal training set. Dopo il training
  # viene effettuato il plot delle previsioni di ogni modello a partire dalla fine del training set.
  #
  # Args:
  #   tserie: serie storica in formato ts
  #   tWindow: periodo delle previsioni (in mesi), di default e' 36 mesi
  #   tittle: titolo da visualizzare nel plot
  #   save: salva il grafico invece di mostrarlo

  # training set
  sr <- window(tserie, start=c(2003,4), end=c(2014,4))
  # test set
  ser = window(tserie, start=c(2014,5), end=c(2017,3))

  # variabili che servono per calcolarmi il minimo e il massimo dei modelli (per il grafico)

  meanMethod <- meanf(sr,h=tWindow)
  naiveMethod <- rwf(sr,h=tWindow)
  sNaiveMethod <- rwf(sr,drift=TRUE,h=tWindow)
  driftMethod <- snaive(sr,h=tWindow)
  arimaMod <- auto.arima(sr, stepwise=FALSE, approximation=FALSE)
  arimaMod.Fr <- forecast(arimaMod, h=tWindow)

  dfMeanMethod <- data.frame(Y=as.matrix(meanMethod$mean), date=as.Date(as.yearmon(time(meanMethod$mean))))
  dfsNaiveMethod <- data.frame(Y=as.matrix(sNaiveMethod$mean), date=as.Date(as.yearmon(time(sNaiveMethod$mean))))
  dfnaiveMethod <- data.frame(Y=as.matrix(naiveMethod$mean), date=as.Date(as.yearmon(time(naiveMethod$mean))))
  dfdriftMethod <- data.frame(Y=as.matrix(driftMethod$mean), date=as.Date(as.yearmon(time(driftMethod$mean))))
  dfArimaMod <- data.frame(Y=as.matrix(arimaMod.Fr$mea), date=as.Date(as.yearmon(time(arimaMod.Fr$mea))))

  dfSr <- data.frame(Y=as.matrix(sr), date=as.Date(as.yearmon(time(sr))))
  dfSer <- data.frame(Y=as.matrix(ser), date=as.Date(as.yearmon(time(ser))))

  ggplot() +
    geom_line(data=dfMeanMethod, aes(date, Y, color="Mean Method"), size = 0.5) +
    geom_line(data=dfsNaiveMethod, aes(date, Y,  color="Naive Method"), size = 0.5)+
    geom_line(data=dfnaiveMethod, aes(date, Y,  color="Drift Method"), size = 0.5)+
    geom_line(data=dfdriftMethod, aes(date, Y,  color="SeasonalMaive Method"), size = 0.5)+
    geom_line(data=dfArimaMod, aes(date, Y,  color="Arima Method"), size = 0.5)+
    geom_line(data=dfSr, aes(date, Y,  color="Test Set"), size = 0.5)+
    labs(title=title,
         subtitle = "Prediction after Training Set",
         y="Number of Flights", x = "Time")+
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank()) +
    scale_colour_manual(name="Methods",
                        values=c("purple", "red", "green", "orange", "brown2", "blue"))

  if(save){
    ggsave(paste(path,"Predizioni Dopo Training Set-", title,".jpg", sep=""), width = widthGraphs)
  }

  ggplot() +
    geom_line(data=dfMeanMethod, aes(date, Y, color="Mean Method"), size = 0.5) +
    geom_line(data=dfsNaiveMethod, aes(date, Y,  color="Naive Method"), size = 0.5)+
    geom_line(data=dfnaiveMethod, aes(date, Y,  color="Drift Method"), size = 0.5)+
    geom_line(data=dfdriftMethod, aes(date, Y,  color="SeasonalMaive Method"), size = 0.5)+
    geom_line(data=dfArimaMod, aes(date, Y,  color="Arima Method"), size = 0.5)+
    geom_line(data=dfSer, aes(date, Y,  color="Test Set"), size = 0.5)+
    labs(title=title,
         subtitle = "Predictions Comparison Test Set",
         y="Number of Flights", x = "Time")+
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank())+
    scale_colour_manual(name="Methods",
                        values=c("purple", "red", "green", "orange", "brown2","blue"))

  if(save){
    ggsave(paste(path,"Confronto Predizioni su Test Set-", title,".jpg", sep=""), width = widthGraphs)
  }

  #plot predizioni serie completa
  meanMethod <- meanf(tserie,h=tWindow)
  naiveMethod <- rwf(tserie,h=tWindow)
  sNaiveMethod <- rwf(tserie,drift=TRUE,h=tWindow)
  driftMethod <- snaive(tserie,h=tWindow)
  arimaMod <- auto.arima(tserie, stepwise=FALSE, approximation=FALSE)
  arimaMod.Fr <- forecast(arimaMod, h=tWindow)

  dfMeanMethod <- data.frame(Y=as.matrix(meanMethod$mean), date=as.Date(as.yearmon(time(meanMethod$mean))))
  dfsNaiveMethod <- data.frame(Y=as.matrix(sNaiveMethod$mean), date=as.Date(as.yearmon(time(sNaiveMethod$mean))))
  dfnaiveMethod <- data.frame(Y=as.matrix(naiveMethod$mean), date=as.Date(as.yearmon(time(naiveMethod$mean))))
  dfdriftMethod <- data.frame(Y=as.matrix(driftMethod$mean), date=as.Date(as.yearmon(time(driftMethod$mean))))
  dfArimaMod <- data.frame(Y=as.matrix(arimaMod.Fr$mea), date=as.Date(as.yearmon(time(arimaMod.Fr$mea))))

  dfSerie <- data.frame(Y=as.matrix(tserie), date=as.Date(as.yearmon(time(tserie))))

  ggplot() +
    geom_line(data=dfMeanMethod, aes(date, Y, color="Mean Method"), size = 0.5) +
    geom_line(data=dfsNaiveMethod, aes(date, Y,  color="Naive Method"), size = 0.5)+
    geom_line(data=dfnaiveMethod, aes(date, Y,  color="Drift Method"), size = 0.5)+
    geom_line(data=dfdriftMethod, aes(date, Y,  color="SeasonalMaive Method"), size = 0.5)+
    geom_line(data=dfArimaMod, aes(date, Y,  color="Arima Method"), size = 0.5)+
    geom_line(data=dfSerie, aes(date, Y,  color="Test Set"), size = 0.5)+
    labs(title=title,
         subtitle = "Predictions Comparison Time Series",
         y="Number of Flights", x = "Time")+
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank())+
    geom_vline(xintercept = as.numeric(as.Date("2017-03-01")),color="red" ,size = 0.5,linetype=4)+
    scale_colour_manual(name="Methods",
                        values=c("purple", "red", "green", "orange", "brown2","blue"))

  if(save){
    ggsave(paste(path,"Confronto Predizioni su serie completa-", title,".jpg",sep=""), width = widthGraphs)
  }

}

plotArimaModel <- function(tserie, tWindow, title, path, save = TRUE){
  # Training del modello arima. Dopo il training viene effettuato il plot
  # delle previsioni di ogni modello a partire dalla fine del training set.
  #
  # Args:
  #   tserie: serie storica in formato ts
  #   tWindow: periodo delle previsioni (in mesi), di default e' 36 mesi
  #   tittle: titolo da visualizzare nel plot
  #   save: salva il grafico invece di mostrarlo

  trainData <- window(tserie, start=c(2003,4), end=c(2014,4))
  testData <- window(tserie, start=c(2014,5), end=c(2017,3))

  arimaMod <- auto.arima(trainData, stepwise=FALSE, approximation=FALSE)
  arimaMod.Fr <- forecast(arimaMod, h=tWindow)

  dfArimaMod <- data.frame(Y=as.matrix(arimaMod.Fr$mea), date=as.Date(as.yearmon(time(arimaMod.Fr$mea))))

  dfTrainData <- data.frame(Y=as.matrix(trainData), date=as.Date(as.yearmon(time(trainData))))
  dftestData <- data.frame(Y=as.matrix(testData), date=as.Date(as.yearmon(time(testData))))

  dfAllSeries <- data.frame(Y=as.matrix(tserie), date=as.Date(as.yearmon(time(tserie))))

  ggplot() +
    geom_line(data=dfArimaMod, aes(date, Y,  color="Arima Method"), size = 0.5)+
    geom_line(data=dfAllSeries, aes(date, Y,  color="Test Set"), size = 0.5)+
    labs(title=paste("Arima Predictions Comparison Training Set",title),
         subtitle = arimaMod.Fr$method,
         y="Number of Flights", x = "Time")+
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank())+
    scale_colour_manual(name="Methods",
                        values=c("red", "blue"))

  if(save){
    ggsave(paste(path, arimaMod.Fr$method , title,".jpg", sep=""), width = widthGraphs)
  }

  ggplot() +
    geom_line(data=dfArimaMod, aes(date, Y,  color="Arima Method"), size = 0.5)+
    geom_line(data=dftestData, aes(date, Y,  color="Test Set"), size = 0.5)+
    labs(title=paste("Arima Predictions Comparison Test Set",title),
         subtitle = arimaMod.Fr$method,
         y="Number of Flights", x = "Time")+
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank())+
    scale_colour_manual(name="Methods",
                        values=c("red", "blue"))

  if(save){
    ggsave(paste(path, "Confronto Arima su Test Set",title,".jpg", sep=""), width = widthGraphs)
  }

  #serie completa
  dfSerie <- data.frame(Y=as.matrix(tserie), date=as.Date(as.yearmon(time(tserie))))
  arimaMod <- auto.arima(tserie, stepwise=FALSE, approximation=FALSE)
  arimaMod.Fr <- forecast(arimaMod, h=tWindow)

  dfArimaMod <- data.frame(Y=as.matrix(arimaMod.Fr$mea), date=as.Date(as.yearmon(time(arimaMod.Fr$mea))))

  ggplot() +
    geom_line(data=dfArimaMod, aes(date, Y,  color="Arima Method"), size = 0.5)+
    geom_line(data=dfSerie, aes(date, Y,  color="Time Series"), size = 0.5)+
    labs(title=paste("Arima Predictions Comparison Time Series",title),
         subtitle = arimaMod.Fr$method,
         y="Number of Flights", x = "Time")+
    scale_x_date(date_labels="%b %Y", date_breaks  ="4 month") +  # line color
    theme(axis.text.x = element_text(angle = 90, vjust=0.5, size = 8),  # rotate x axis text
          panel.grid.minor = element_blank())+
    geom_vline(xintercept = as.numeric(as.Date("2017-03-01")),color="red" ,size = 0.5,linetype=4)+
    scale_colour_manual(name="Methods",
                        values=c("red", "blue"))

  if(save){
    ggsave(paste(path, "Confronto Arima su Serie Completa",title,".jpg", sep=""),width = widthGraphs)
  }

}

evaluateBesModel <- function(tserie, tWindow, title,path, save = TRUE){
  # Calcola il modello migliore in base alle misure di accuracy dei modelli.
  # Dopo il calcolo viene visualizzata la tabella con tutte le misure di errore
  #
  #
  # Args:
  #   tserie: serie storica in formato ts
  #   tWindow: periodo delle previsioni (in mesi), di default e' 36 mesi
  #   title: titolo da visulizzare nella tabella delle misure di errore
  #   save: salva il grafico invece di mostrarlo
  #
  # Returns:
  #   Il modello migliore in base alle metriche "ME", "RMSE", "MAE", "MPE", "MAPE"

  sr <- window(tserie, start=c(2003,4), end=c(2014,4))
  ser <- window(tserie, start=c(2014,5), end=c(2017,3))

  meanMethod <- meanf(sr,h=tWindow)
  naiveMethod <- rwf(sr,h=tWindow)
  sNaiveMethod <- rwf(sr,drift=TRUE,h=tWindow)
  driftMethod <- snaive(sr,h=tWindow)
  arimaMod <- auto.arima(sr, stepwise=FALSE, approximation=FALSE)
  arimaMod.Fr <- forecast(arimaMod, h=tWindow)

  a1 = accuracy(meanMethod, ser)
  a2 = accuracy(naiveMethod, ser)
  a3 = accuracy(sNaiveMethod, ser)
  a4 = accuracy(driftMethod, ser)
  a5 = accuracy(arimaMod.Fr, ser)

  keeps <- c("ME", "RMSE", "MAE", "MPE", "MAPE")
  a1 <- a1[2,keeps, drop = FALSE]
  a2 <- a2[2,keeps, drop = FALSE]
  a3 <- a3[2,keeps, drop = FALSE]
  a4 <- a4[2,keeps, drop = FALSE]
  a5 <- a5[2,keeps, drop = FALSE]

  temp.table <- as.data.frame(cbind(a1[1, ], a2[1, ], a3[1, ], a4[1, ], a5[1, ]))

  colnames(temp.table) <-
    c("Average Method",
      "Naive Method",
      "SNaive Method",
      "Drift method",
      "Arima")

  is.num <- sapply(temp.table, is.numeric)
  temp.table[is.num] <- lapply(temp.table[is.num], round, 10)

  t1 <- tableGrob(temp.table)
  titleTable <- textGrob(paste("Errori Test Set-", title), gp=gpar(fontsize=25))

  padding <- unit(5,"mm")

  table <- gtable_add_rows(
    t1,
    heights = grobHeight(titleTable) + padding,
    pos = 0)
  table <- gtable_add_grob(
    table,
    titleTable,
    1, 1, 1, ncol(table))

  if(save){
    ggsave(file=paste(path,"Errori Test Set-", title,".jpg", sep=""), grid.draw(table),width = widthGraphs)
  }else{
    grid.newpage()
    grid.draw(table)
  }

  dfEvalColumn <- c("ME", "RMSE", "MAE", "MPE", "MAPE")
  dfEvalRow <- c(names(temp.table)[which.min(apply(temp.table[1,],MARGIN=2,min))],
                 names(temp.table)[which.min(apply(temp.table[2,],MARGIN=2,min))],
                 names(temp.table)[which.min(apply(temp.table[3,],MARGIN=2,min))],
                 names(temp.table)[which.min(apply(temp.table[4,],MARGIN=2,min))],
                 names(temp.table)[which.min(apply(temp.table[5,],MARGIN=2,min))])
  dfEval <- data.frame(dfEvalColumn, dfEvalRow)

  tableEval <-  table(dfEval$dfEvalRow)

  return (names(tableEval)[which.max(tableEval)])

}

plotBestModel<- function(model, sr, tWindow, title,path, save = TRUE){
  if(model == 'Arima'){
    arimaMod <- auto.arima(sr, stepwise=FALSE, approximation=FALSE)
    arimaMod.Fr <- forecast(arimaMod, h=tWindow)
<<<<<<< HEAD
    if(save){
      jpeg(paste(path,"Best Model con Arima - ", title,".jpg", sep=""), width = 800)
    }
    plot(arimaMod.Fr, main=paste('Arima', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      dev.off()
=======
    autoplot(arimaMod.Fr, main=paste('Arima', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      ggsave(file=paste(path,"Best Model con Arima - ", title,".jpg", sep=""))
>>>>>>> devLorenzo
    }
  }
  if(model == 'Drift method'){
    driftMethod <- snaive(sr,h=tWindow)
    driftMethod.Fr <- forecast(driftMethod, h=tWindow)
<<<<<<< HEAD
    if(save){
      jpeg(paste(path,"Best Model con Drift method - ", title,".jpg", sep=""), width = 800)
    }
    plot(driftMethod.Fr, main=paste('Drift method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      dev.off()
=======
    autoplot(driftMethod.Fr, main=paste('Drift method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      ggsave(file=paste(path,"Best Model con Drift method - ", title,".jpg", sep=""))
>>>>>>> devLorenzo
    }
  }
  if(model == 'SNaive Method'){
    sNaiveMethod <- rwf(sr,drift=TRUE,h=tWindow)
    sNaiveMethod.Fr <- forecast(sNaiveMethod, h=tWindow)
<<<<<<< HEAD
    if(save){
      jpeg(paste(path,"Best Model con SNaive Method - ", title,".jpg", sep=""), width = 800)
    }
    plot(sNaiveMethod.Fr, main=paste('SNaive Method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      dev.off()
=======
    autoplot(sNaiveMethod.Fr, main=paste('SNaive Method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      ggsave(file=paste(path,"Best Model con SNaive Method - ", title,".jpg", sep=""))
>>>>>>> devLorenzo
    }
  }
  if(model == 'Naive Method'){
    naiveMethod <- rwf(sr,h=tWindow)
    naiveMethod.Fr <- forecast(naiveMethod, h=tWindow)
<<<<<<< HEAD
    if(save){
      jpeg(paste(path,"Best Model con Naive Method - ", title,".jpg", sep=""), width = 800)
    }
    plot(naiveMethod.Fr, main=paste('Naive Method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      dev.off()
      }
=======
    autoplot(naiveMethod.Fr, main=paste('Naive Method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      ggsave(file=paste(path,"Best Model con Naive Method - ", title,".jpg", sep=""))
    }
>>>>>>> devLorenzo
  }
  if(model == 'Average Method'){
    meanMethod <- meanf(sr,h=tWindow)
    meanMethod.Fr <- forecast(meanMethod, h=tWindow)
<<<<<<< HEAD
    if(save){
      jpeg(paste(path,"Best Model con Average Method - ", title,".jpg", sep=""), width = 800)
    }
    plot(meanMethod.Fr, main=paste('Average Method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      dev.off()
=======
    autoplot(meanMethod.Fr, main=paste('Average Method', title), ylab="Number of flights", xlab= 'Time')
    if(save){
      ggsave(file=paste(path,"Best Model con Average Method - ", title,".jpg", sep=""))
>>>>>>> devLorenzo
    }
  }
}


dyn.load(paste("structural", .Platform$dynlib.ext, sep=""))
source("structural.R")
cacheMetaData(1)

ConvertMatrix <- function(matrixIn, rowLabels, colLabels)
{
	numRows <- DoubleMatrix_numRows(matrixIn)
	numCols <- DoubleMatrix_numCols(matrixIn)

	out <- matrix(nrow=numRows, ncol=numCols)
	for (i in 1:numRows)
	{
		for (j in 1:numCols)
		{
			out[i,j] <- DoubleMatrix_get(matrixIn, i-1,j-1 )
		}
	}

	rowNames1 <- vector("character", numRows)
	colNames1 <- vector("character", numCols)

	for (i in 1:numRows)
	{
		rowNames1[i] <- rowLabels[i-1]
	}

	for (j in 1:numCols)
	{
		colNames1[j] <- colLabels[j-1]
	}

	colnames(out) <- colNames1;
	rownames(out) <- rowNames1;

	return(out)

}

LoadSBMLAndAnalyze <- function(struct, fileName)
{

	print(strsplit(LibStructural_loadSBMLFromFile(struct,fileName), "\n"))
	print(strsplit(LibStructural_getTestDetails(struct), "\n"))

	PrintFullyReorderedStoichiometryMatrix(struct)
}

PrintFullyReorderedStoichiometryMatrix <- function(struct)
{

	x <- LibStructural_getFullyReorderedStoichiometryMatrix(struct)
	rowLabels <- StringVector()
	colLabels <- StringVector()
	LibStructural_getFullyReorderedStoichiometryMatrixLabels(struct, rowLabels, colLabels)

	result <- ConvertMatrix(x, rowLabels, colLabels)
	print("Fully Reordered Stoichiometry Matrix")
	print(result)

}

LoadAndAnalyzeMatrix <- function(struct, stoich, speciesNames, speciesConcentrations, reactionNames)
{
	dMatrix <- CreateDoubleMatrix(stoich)
	vSpeciesNames <- CreateStringVector(speciesNames)
	vSpeciesConcentrations <- CreateDoubleVector(speciesConcentrations)
	vReactionNames <- CreateStringVector(reactionNames)

	LibStructural_loadStoichiometryMatrix(struct, dMatrix)
#	LibStructural_loadSpecies(struct,vSpeciesNames, vSpeciesConcentrations)
#	LibStructural_loadReactionNames(struct,vReactionNames)

	print(strsplit(LibStructural_analyzeWithQR(struct), "\n"))
	print(strsplit(LibStructural_getTestDetails(struct), "\n"))

	PrintFullyReorderedStoichiometryMatrix(struct)

}

CreateDoubleVector <- function(vector)
{

	vLength <- length(vector)
	result <- DoubleVector(vLength)
	for (i in (1:vLength))
	{
		result[i-1] <- vector[i]
	}
	return(result)
}

CreateStringVector <- function(vector)
{
	vLength <- length(vector)
	result <- StringVector(vLength)

	for (i in (1:vLength))
	{
		result[i-1] <- vector[i]
	}
	return(result)
}

CreateDoubleMatrix <- function(stoich)
{
	numRows <- dim(as.matrix(stoich))[1]
	numCols <- dim(as.matrix(stoich))[2]

	dMatrix <- DoubleMatrix(numRows, numCols)
	for (i in (1:numRows))
	{
		for (j in (1:numCols))
		{
			DoubleMatrix_set(dMatrix,i-1,j-1, stoich[i,j])
		}
	}
	return(dMatrix)
}

struct <- LibStructural()
LoadSBMLAndAnalyze(struct, "/Applications/SBW-2.7.8/SBML Models/BorisEJB.xml")

speciesNames <- c( "S2", "S3", "S4" )
speciesConcentrations <- c( 1.0, 0.0, 1.0 )
reactionNames <- c( "J1", "J2", "J3", "J4" )
stoich <- data.frame(
			c(1.0,              -1.0,               0.0,               0.0),
			c(0.0,               1.0,              -1.0,               0.0),
			c(0.0,               0.0,               1.0,              -1.0))

LoadAndAnalyzeMatrix(struct, stoich, speciesNames, speciesConcentrations, reactionNames)


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Coauthor networks: visualisation
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Shiny App: Visualising resource flow - from taxonomist country of residence to type locality

# Libraries
library(shiny)
library(data.table)
library(networkD3)

# Constants / parameters
DEFAULT_THRESHOLD <- 0

# Read data (residing in data folder)
# setwd('2019-06-19-jsa-type-shiny/eda2.1_shiny')
t <- fread("data/7.0-author-networks.csv", encoding="UTF-8", na.strings="")
auth <- fread("data/authors.csv", encoding="UTF-8", na.strings="")
t <- merge(t, auth[, c('last.name', 'full.name.of.describer.n')], by.x="p1", by.y="full.name.of.describer.n",
           all.x=T, all.y=F)
t <- merge(t, auth[, c('last.name', 'full.name.of.describer.n')], by.x="p2", by.y="full.name.of.describer.n",
           all.x=T, all.y=F, suffixes=c("_p1", "_p2"))
t$p1 <- NULL; t$p2 <- NULL
names(t) <- gsub("last.name_", "", names(t))

# Create labels for authors
nodes_lab <- sort(auth[last.name %in% unique(c(t$p1, t$p2))]$last.name)

# Update data function
update <- function(threshold=DEFAULT_THRESHOLD, author=NA) {

  t2 <- t[N>threshold]

  # Subset dataset
  if (!(is.na(author) | author == "All")) { t2 <- t2[(p1 == author | p2 == author)] }

  # Create network dataset - indexing from 0
  if (dim(t2)[1] == 0) {

    nodes <- data.frame(idx=integer(), label=character())
    t2 <- data.frame(ori=character(), des=character())

  } else {

    nodes <- unique(data.frame(label=c(t2$p1, t2$p2)))
    nodes <- data.table(nodes); nodes <- nodes[order(label)]
    nodes$idx <- seq(0, dim(nodes)[1]-1, 1)
    nodes <- merge(nodes, auth, by.x="label", by.y="last.name")

    t2 <- merge(t2, nodes[, c("label", "idx")], by.x="p1", by.y="label", all.x=T, all.y=F)
    t2 <- merge(t2, nodes[, c("label", "idx")], by.x="p2", by.y="label", all.x=T, all.y=F, suffixes=c("_p1", "_p2"))

  }

  list(t2=t2, nodes=nodes)

}

# UI component of shiny app
ui <- fluidPage(
  verticalLayout(
    inputPanel(
      sliderInput("thresholdInput", "Minimum threshold",
                  min=0, max=floor(sort(t$N)[length(t$N)-1]/10)*10,
                  value=DEFAULT_THRESHOLD, post=" N spp.",
                  step=5),
      selectInput("nodeColourInput", "Node colour by",
                  c("Gender", "Country of residence"), selected=NULL, multiple=F),
      selectInput("authorInput", "Authors", # sorted by Discover Life codes
                  c("All", nodes_lab), selected=NULL, multiple=F)
    ),
    mainPanel(
      sidebarLayout(
        sidebarPanel(tableOutput("networkTable"),
                     width=3),
        mainPanel(forceNetworkOutput("network", height="500px"), width=9)
      ),
      width=12
    )
  )
)

# Server component of shiny app
server <- function(input, output) {

  # Update data
  update_data <- reactive({
    if(input$authorInput == "All") {
      updated <- update(input$thresholdInput)
    } else {
      updated <- update(input$thresholdInput, input$authorInput)
    }
    updated
  })

  # Output plots
  clickJS <- 'd3.selectAll(".node").on("click", function(d){ alert(d.name + ": " + d.nodesize + "spp."); })'
  output$network <- renderForceNetwork({

    updated <- update_data()

    if (dim(updated$t2)[1] == 0) {

    } else {

      grouping <- ifelse(input$nodeColourInput == "Country of residence", "residence.country.describer.first",
        ifelse(input$nodeColourInput == "Gender", "describer.gender.n", ""))

      forceNetwork(
        Links = updated$t2, Nodes = updated$nodes,
        Source = "idx_p1", Target = "idx_p2", Value = "N",
        colourScale = JS("d3.scaleOrdinal(d3.schemeCategory10);"),
        NodeID = "label", Group=grouping, Nodesize="spp_N", zoom=T, opacity=.8,
        radiusCalculation = JS("Math.sqrt(d.nodesize)"),
        linkWidth = JS("function(d) { return d.value == 1 ? 1 : Math.log(d.value, 2); }"),
        charge=-2000/((input$thresholdInput/200+1)), fontFamily="Calibri",
        fontSize=40, opacityNoHover = 1, clickAction=clickJS, legend=TRUE, arrows=FALSE)
    }
  })

  output$networkTable <- renderTable({

    updated <- update_data()

    if(dim(updated$t2)[1] >=1) {
      tableshow <- updated$t2[,c("p1", "p2", "N")]
      names(tableshow) <- c("Author1", "Author2", "N spp.")
      tableshow
    } else { data.frame(Comment=c("No data")) }

  })

}

# Run app
shinyApp(ui = ui, server = server)


#----------------------------------------------------------------------------#
#' @title mean difference output from t-tests
#' @description return ttest results: effect sizes and pvalues
#' @param x group1
#' @param y group2
#' @param conf.level conf.level
#' @param alternative sided
#' @param digit digits for effect size
#' @param pdigits digits for p values
#' @param ... ...
#' @import stats
#' @export
mean_diff = function(x,y,conf.level = 0.95,alternative = "two.sided",digit = 2,pdigits = 3,...) {
  a = t.test(x,y,conf.level = conf.level,alternative = alternative)
  conf1 = a$conf.int %>% round(digit)
  mean_diff1 = (a$estimate[1]-a$estimate[2]) %>% round(digit)
  b1 = mean_sd(x,digit = digit)
  b2 = mean_sd(y,digit = digit)
  out1 = paste0(mean_diff1,"(",conf1[1],",",conf1[2],")")
  out2 = a$p.value %>% round(pdigits) %>% pformat()
  out3 = c(b1,b2,out1,out2)
  names(out3) = c("group1","group2","effect size","P")
  return(out3)
}


library(caret)

# Data splitting with createDataPartition()
inTrain <- createDataPartition(y=iris$Species, p=0.75, list=FALSE)

training <- iris[inTrain, ]
testing <- iris[-inTrain, ]

dim(training)

dim(testing)


# Following Guide on https://ase.tufts.edu/gsc/gradresources/guidetomixedmodelsinr/mixed%20model%20guide.html
# Following teacher value-added in https://www.nber.org/papers/w14607.pdf

# Load (possibly) required packages
require(lme4)
require(car)
require(MASS)
require(mlmRev)
require(ggplot2)
require(pscl)
require(fitdistrplus)
require(dplyr)
require(MCMCglmm)
require(glmmTMB)
require(DHARMa)

# No scientific notation (optional)
options(scipen=999)

# Load Data
model_data = read.csv("C:/Users/abeers/Documents/Projects/CampaignZero/CPZ/data/processed/nashville/nashville_model_formatted_citizen.csv")

# Change Data Types and Normalize
model_data$police_id = as.factor(model_data$police_id)
model_data$division = as.factor(model_data$division)
model_data$race = as.factor(model_data$race)
model_data$gender = as.factor(model_data$gender)
model_data$time_period = as.factor(model_data$time_period)
model_data$full_name = as.factor(model_data$full_name)
model_data$age = (model_data$age - mean(model_data$age)) / sd(model_data$age)
model_data$experience = (model_data$experience - mean(model_data$experience)) / sd(model_data$experience)
model_data$allegations.nonzero = model_data$allegations + 1
model_data = model_data[!(model_data$time_period == 19),] # Almost no data in this time period. Possible error in preprocessing.

# Check Data is loaded correctly.
head(model_data)

# Determine Distribution of Data.
fitn <- fitdist(model_data$allegations, "norm")
fitp <- fitdist(model_data$allegations, "pois")
fitnb <- fitdist(model_data$allegations, "nbinom")
denscomp(list(fitn, fitp, fitnb), main="Comparison of Distribution Fit for Allegations Data")
chosen_distribution = "negative_binomial"

# Visualize Data Histogram
ggplot(model_data) + geom_histogram(aes(allegations, y = ..density..), binwidth = 1)

# Compare Models by Distribution, No Controls
output_model_normal <- glmmTMB(allegations ~ (1 | police_id), data = model_data, family=gaussian(), verbose=2)
output_model_p <- glmmTMB(allegations ~ (1 | police_id), data = model_data, family=poisson(), ziformula=~1, verbose=2)
output_model_nb <- glmmTMB(allegations ~ (1 | police_id), data = model_data, family=nbinom1(), verbose=2)

# Compare Models by Controls
# We take the best model from the previous section. We don't exhaustively check every combination, but use some intuition to add them sequentially.
output_model <- glmmTMB(allegations ~ (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
output_model_division <- glmmTMB(allegations ~ division + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
output_model_time_period <- glmmTMB(allegations ~ time_period + division + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
output_model_experience <- glmmTMB(allegations ~ experience + time_period + division + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
output_model_race <- glmmTMB(allegations ~ race + experience + time_period + division + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
output_model_gender <- glmmTMB(allegations ~ gender + race + experience + time_period + division + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
output_model_age <- glmmTMB(allegations ~ age + gender + race + experience + time_period + division + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)

# My initial attempts at model comparisons via AIC indicate that division + time_period + experience is where model performance maxes out. The time_period parameter looks supicious though, because none of the fixed effects coefficients are significant, and the coefficients are very large. So, TBD! Someone with more stats experience can look into it.
  output_model_p <- glmmTMB(allegations ~ time_period + division + (1 | police_id), data = model_data, family=poisson(), ziformula=~1, verbose=2)
  output_model <- glmmTMB(allegations ~ division + experience + (1 | police_id), data = model_data, family=nbinom1(), verbose=2)
  output_model_normal <- glmmTMB(allegations ~ time_period + division + experience + race +(1 | police_id), data = model_data, family=gaussian(), verbose=2)

# View Model Summary
summary(output_model)

# P-Values if calculable.
Anova(output_model)

# Model Diagnostics. For more information, see https://cran.r-project.org/web/packages/DHARMa/vignettes/DHARMa.html.
res <- simulateResiduals(output_model)
plotResiduals(model_data$allegations, res$scaledResiduals)
plot(res)
testResiduals(res)
testZeroInflation(res)

# Create results data frames.
# This is a little messy.
random_effects = data.frame(ranef(output_model))
random_effects$n = count(model_data, police_id)$n
time_period_level_data = data.frame("police_id" = model_data$police_id, "residual" = resid(output_model), "predictions"=predict(output_model), "allegations"=model_data$allegations)
time_period_level_data = merge(random_effects, time_period_level_data, by.x="grp", by.y="police_id")
time_period_level_data$residual_randomeffect = time_period_level_data$residual + exp(time_period_level_data$condval)
time_period_level_data$condsd_transformed = exp(time_period_level_data$condsd)
time_period_level_data$predictions_transformed = exp(time_period_level_data$predictions)
time_period_level_data$full_name = model_data$full_name
time_period_level_data$force_count = model_data$force_count
colnames(time_period_level_data)[1] = "police_id"

cop_level_data = aggregate(time_period_level_data[, 2:15], list(time_period_level_data$police_id), mean)
names = aggregate(full_name~police_id, data=time_period_level_data, paste, collapse = ",") # I don't know how to do this better. Something with dplyr would work.
residual_sd = aggregate(time_period_level_data$residual, list(time_period_level_data$police_id), sd)
cop_level_data = merge(cop_level_data, residual_sd, by.y="Group.1", by.x="Group.1")
cop_level_data = merge(cop_level_data, names, by.x="Group.1", by.y="police_id")
colnames(cop_level_data)[1] = "police_id"

# Empirical Bayes Estimation / "Shrinkage" is a work in progress. This is incorrect, but captures the spirit of the operation, which is to multiply random effect estimates by a value which represents their reliability, as captured by the number of instances in the dataset and the variance of the random effect estimate.
# shrinkage_numerator = sqrt(exp(cop_level_data$condsd))
# shrinkage_denominator =  sqrt(cop_level_data$x)
# cop_level_data$reliability = shrinkage_numerator / (shrinkage_numerator + shrinkage_denominator)
# cop_level_data$reliability = sqrt(cop_level_data$condsd) / .662
cop_level_data$reliability = 1 / sqrt(cop_level_data$condsd)
cop_level_data$shrunken_metric = cop_level_data$condval * cop_level_data$reliability
cop_level_data$shrunken_metric2 = cop_level_data$residual_randomeffect * cop_level_data$reliability

# Scratch for Force Prediction, not finished.
cop_level_data$s1_time_adjusted = cop_level_data$shrunken_metric * cop_level_data$n
cop_level_data$s2_time_adjusted = cop_level_data$shrunken_metric2 * cop_level_data$n
cop_level_data$force_time_adjusted = cop_level_data$force_count / cop_level_data$n
cops_with_force = cop_level_data[cop_level_data$force_count > 0,]
force_model1 <- glmmTMB(force_count ~ s1_time_adjusted, data = cops_with_force, family=nbinom1(), verbose=2)
force_model2 <- glmmTMB(force_count ~ s2_time_adjusted, data = cops_with_force, family=nbinom1(), verbose=2)
cops_with_force$force_predictions = exp(predict(force_model1))
cops_with_force$force_predictions2 = exp(predict(force_model2))
ggplot(cops_with_force, aes(x=force_predictions, y=force_count)) + geom_point() + geom_abline()

# Save out results..
write.csv(time_period_level_data, file = "C:/Users/abeers/Documents/Projects/CampaignZero/CPZ/data/processed/nashville/nashville_time_period_results.csv")
write.csv(cop_level_data, file = "C:/Users/abeers/Documents/Projects/CampaignZero/CPZ/data/processed/nashville/nashville_police_id_results.csv")

# Scratch Code
ggplot(cop_level_data) + geom_histogram(aes(s2_time_adjusted))
ggplot(cop_level_data) + geom_histogram(aes(shrunken_metric))
ggplot(cop_level_data, aes(x=condval, y=shrunken_metric)) + geom_point() + geom_abline()
ggplot(time_period_level_data) + geom_histogram(aes(residual_randomeffect), binwidth=.1)
ggplot(random_effects) + geom_histogram(aes(condval))
qqp(police_residuals, "norm")
gamma <- fitdistr(police_residuals, "gamma")
qqp(police_residuals, "gamma", shape = gamma$estimate[[1]], rate = gamma$estimate[[2]])
# output_model <- glmer(allegations ~ time_period + division + age + experience + race + gender + (1 | police_id), data = model_data, family = poisson(link = "log"), nAGQ = 1, control=glmerControl(optimizer = "nloptwrap"), verbose=2)  # Set nAGQ to # of desired iterations
# output_model = MCMCglmm(allegations ~ time_period + division + age + experience + race + gender, random = ~police_id, data = model_data)


#' f_h1
#'
#' Construct the $K_\tau K_1$ vector $h_1$
#'
#' @param n1 matrix n1 output from f_n1
#' @param g1 $G_1$ diagonal matrix
#' @param g2 $G_2$ diagonal matrix
#' @param sigmatau $\Sigma_tau$ diagonal matrix
#'
#'
#' @return $K_\tau K_1$ vector $H_1$
#'
#' @examples
#' \dontrun{
#' v_taustar <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
#' m_s <- f_mats(ktau + mtau, k1 + m1, rep(1, 3))
#' m_g1 <- f_g1(ktau, mtau)
#' m_g2 <- f_g2(ktau, mtau)
#' m_sigmatau <- f_sigmatau(ktau + mtau)
#' m_h1 <- f_h1(n1, m_g1, m_g2, m_sigmatau)
#' m_h2 <- f_h2(n1, m_ntaustar, m_g1, m_sigmatau)
#' }
f_h1 <- function(n1, g1, g2, sigmatau) {
    #form N^{m_tau+2}(\tau)|_0^1
    nm2 <- rep(0, nrow(sigmatau)); nm2[nrow(sigmatau)] <- 1
    #Calculate $H_1$
    h_1 <- tcrossprod(g1, sigmatau) %*% tcrossprod(g2, sigmatau)
    h_1 <- -h_1 %*% nm2
    h_1 <- kronecker(h_1, t(n1))
    h_1 <- rowSums(h_1)
    return(h_1)
}

#' f_h2
#'
#' Construct the $K_\tauK_1$ vector $H_2$
#'
#' @param n1 matrix n1 output from f_n1
#' @param ntaustar matrix ntau output from f_ntaustar
#' @param g1 $G_1$ diagonal matrix
#' @param sigmatau $\Sigma_tau$ diagonal matrix
#'
#'
#' @return $K_\tau K_1$ vector $H_2$
#'
#' @import mgcv
#'
#' @examples
#' \dontrun{
#' v_taustar <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
#' m_s <- f_mats(ktau + mtau, k1 + m1, rep(1, 3))
#' m_g1 <- f_g1(ktau, mtau)
#' m_g2 <- f_g2(ktau, mtau)
#' m_sigmatau <- f_sigmatau(ktau + mtau)
#' m_h1 <- f_h1(n1, m_g1, m_g2, m_sigmatau)
#' m_h2 <- f_h2(n1, m_ntaustar, m_g1, m_sigmatau)
#' }
f_h2 <- function(n1, ntaustar, g1, sigmatau) {
    h_2 <- tcrossprod(g1, sigmatau) %*% t(ntaustar)
#ptm <- proc.time()# Start the clock!
    h_2 <- mgcv::tensor.prod.model.matrix(list(t(h_2), n1))
    h_2 <- colSums(h_2)
#print(proc.time() - ptm)# Stop the clock

    return(h_2)
}

#' f_lossderiv
#'
#' Construct the $K_\tau K_1$ gradient vector for the loss
#'
#' @param til_beta the current estimation fro $\tilde{\beta}$
#' @param v_dim vector contain the dimension of covariates
#'             $(K_\tau, K_1, K_2, K_3, \cdots)$
#'
#' @param m_sigma $K_\tau K_1K_2 \times K_1K_2 \Sigma$ diagonal block matix.
#' @param h1 $K_\tau K_1K_2$ spline vector for the first covariate
#' @param h2 $K_\tau K_1K_2$ spline vector for the tau covariate
#'
#'
#' @return the $K_\tau K_1$ gradient vector for the loss
#'
#' @examples
#' \dontrun{
#' v_taustar <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
#' m_s <- f_mats(ktau + mtau, k1 + m1, rep(1, 3))
#' m_g1 <- f_g1(ktau, mtau)
#' m_g2 <- f_g2(ktau, mtau)
#' m_sigmatau <- f_sigmatau(ktau + mtau)
#' m_h1 <- f_h1(n1, m_g1, m_g2, m_sigmatau)
#' m_h2 <- f_h2(n1, m_ntaustar, m_g1, m_sigmatau)
#' v_lossderiv <- f_lossderiv(til_beta, c(ktau + mtau, k1 + m1), m_sigma, m_h1, m_h2)
#' }
f_lossderiv <- function(til_beta, v_dim, m_sigma, h1, h2) {
    m_c <- f_matc(v_dim, til_beta)
    lossderiv <- - m_c %*% crossprod(m_sigma, (h1 + h2))
    return(c(lossderiv))
}

#' f_grad
#'
#' Construct the $K_\tau K_1K_2$ gradient vector for $\beta$
#'
#' @param beta the current estimation fro $\beta$
#' @param loss_deriv the derivative of the loss
#' @param s $K_\tau K_1K_2 \times K_1K_2$ $S$ matrix
#'
#'
#' @return the $K_\tau K_1K_2$ gradient vector for $\beta$
#'
#' @examples
#' \dontrun{
#' v_taustar <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
#' m_s <- f_mats(ktau + mtau, k1 + m1, rep(1, 3))
#' m_g1 <- f_g1(ktau, mtau)
#' m_g2 <- f_g2(ktau, mtau)
#' m_sigmatau <- f_sigmatau(ktau + mtau)
#' m_h1 <- f_h1(n1, m_g1, m_g2, m_sigmatau)
#' m_h2 <- f_h2(n1, m_ntaustar, m_g1, m_sigmatau)
#' v_lossderiv <- f_lossderiv(til_beta, c(ktau + mtau, k1 + m1), m_sigma, m_h1, m_h2)
#' f_grad(beta, v_lossderiv, m_s)
#' }
f_grad <- function(beta, loss_deriv, s) {
    loss_deriv + c(s %*% beta)
}

#' f_hess
#'
#' Construct the $K_\tau K_1K_2 \times K_\tau K_1K_2$ Hessian matrix for $\beta$
#'
#' @param loss_deriv the derivative of the loss
#' @param v_dim vector contain the dimension of covariates
#'             $(K_\tau, K_1, K_2, K_3, \cdots)$
#' @param s $K_\tau K_1K_2 \times K_\tau K_1K_2$ $S$ matrix
#'
#'
#' @return the $K_\tau K_1K_2$ gradient vector for $\beta$
#'
#' @examples
#' \dontrun{
#' v_taustar <- f_tausearch(y, n1, til_beta, m_sigma, ktau, mtau)
#' m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
#' m_s <- f_mats(ktau + mtau, k1 + m1, rep(1, 3))
#' m_g1 <- f_g1(ktau, mtau)
#' m_g2 <- f_g2(ktau, mtau)
#' m_sigmatau <- f_sigmatau(ktau + mtau)
#' n_m2 <- rep(0, ktau + mtau)
#' n_m2[ktau + mtau] <- 1
#' m_h1 <- f_h1(n1, m_g1, m_g2, m_sigmatau, n_m2)
#' m_h2 <- f_h2(n1, m_ntaustar, m_g1, m_sigmatau)
#' v_lossderiv <- f_lossderiv(til_beta, c(ktau + mtau, k1 + m1), m_sigma, m_h1, m_h2)
#' f_grad(beta, v_lossderiv, m_s)
#' m_hess <- f_hess(v_lossderiv, c(ktau + mtau, k1 + m1), m_s)
#' }
f_hess <- function(loss_deriv, v_dim, s) {
    v_idx <- seq_len(v_dim[2])
    loss_deriv[v_idx] <- 0
    return(diag(loss_deriv) + s)
}


# Copyright 2017 Province of British Columbia
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and limitations under the License.

###############################################################################
# Fit a Bayesian model for the replicated observations at the same species
# using data cloning.
#
# This function can be used for different distributions
# by selectively extracting the code with the tag number at the right

model {
  # Input data for logConc - log-concentration
  #                SpeciesNum - species number to link replicate observations
  #                NData - number of data values
  #                NSpecies - number of unique species
  #
  # Parameters for distributions vary depending on the distribution
  #    lnorm   -   mu, sigma - intercept and slope (on log scale) - lognormal

  # Parameters for observal error
  #       sigma_obs - sd of observational error
  #

  # observed data comes from underlying mean with a lognormal distribution
  # this is true regardless of the distribution of the mu_species whose
  # distributions can change
  # We want separate latent variables for each clone because this sample size
  # is NOT increasing as we increase the number of chemicals tested.
  for(k in 1:K){
     for(i in 1:NData){
        logConc[i,k]  ~ dnorm(log_mu_species[SpeciesNum[i],k], tau_obs)
     }
  }
  # Contributions to the likelihood from the observed data#
#  for(i in 1:NData){
#     likc.data[i] <- dnorm(logConc[i,1], mu_species[SpeciesNum[i]], tau_obs)
#  }
#  lik.data <- prod(likc.data[])  # total contribuiton to the likelihood from data
  # priors and derived variables for the observation process
  tau_obs <- 1/(sigma_obs*sigma_obs)
  sigma_obs ~dunif(.01, 5)

  #--------------------------------------------------------------------
  # LOGNORMAL distribution for the "mean" of each species
  # fit a distribution to the mean of each observation
  for(k in 1:K){
     for(i in 1:NSpecies){
        mu_species[i,k] ~ dlnorm(mu, tau)
        log_mu_species[i,k] <- log(mu_species[i,k])
#        likc.latent[i] <- dlnorm(mu_species[i], mu, tau) # contribution from the likelihoo
     }
  }
#  lik.latent <- prod(likc.latent[])  # total contribution to the likelihood from latent species value
  tau <- 1/(sigma*sigma)
  sigma ~ dunif(.01,5)

  mu ~ dnorm(0, .001)

  # estimate the average ranking of the species for each clone
  for(k in 1:K){
     rank_mu_species[1:NSpecies,k] <- rank(mu_species[1:NSpecies,k])
  }

  # estimate the HC[5]
  hc     <- qlnorm(.05, mu, tau)  # the HC[5]
  hc.log <- log(hc)
  #------------------------------------------------------------------

  # total complete-data likelihood
#  lik <- lik.data * lik.latent
}  # end of model.jags


library(igraph)

e <- read.csv("../edges.csv", header=FALSE)
names(e) <- c("from", "to")

v <- read.csv("../vertices.csv", header=FALSE)
names(v) <- c("name", "timestamp")

mask1 <- e$from %in% v$name
mask2 <- e$to %in% v$name
mask <- mask1 & mask2
e <- e[mask,]
g <- graph.data.frame(e, vertices = v)
g <- delete.vertices(g, V(g)[degree(g)==0])

la <- layout_with_fr(g)
g <- add_layout_(g, in_circle(), component_wise())
memberships.eigen <- cluster_leading_eigen(as.undirected(g))$membership

indegrees <- degree(g, mode="in")
q_degree <- quantile(indegrees, 0.9)

V(g)$label.cex <- ifelse(degree(g, mode="in")>0, 1+0.5*tanh(indegrees-q_degree), 0)
V(g)$name[degree(g, mode="in")<10] = ""

# Size proportional to degree
V(g)$size <- 1+0.5*tanh(indegrees-q_degree)

plot(g,
     layout = la,
     vertex.color = memberships.eigen,
     edge.width = 0.2,
     edge.arrow.size=0.02,
     asp=9/16,
     margin=-0.15)


#!/usr/bin/env Rscript
#
# This function calculates a silly phylogenetic signal score that
# I made up for use on unrooted trees.
#
# For each split in the tree with >= N taxa on each side, it calculates
# the mean trait value on each side of the split, and takes the absolute
# value of the difference. I made this statistic up.
#
# It is important that there not be any duplicated names in the tree or
# in the traits.
#

silly_phy_signal = function(tree, traits, N) {
    #
    # tree should be a phylo object
    # traits should be a two column data.frame - 1st column is
    #   taxa names, 2nd column is trait values
    # N is the minimum number of leaves on each side of the
    #   split to allow for testing

    require(ape)
    require(picante)

    traits = traits[!is.na(as.numeric(traits[, 2])), ]
    traitv = as.numeric(traits[, 2])
    names(traitv) = traits[, 1]

    if(any(duplicated(traits[, 1])))
        stop('Duplicated taxa in traits file')
    if(any(duplicated(tree$tip.label)))
        stop('Duplicated names in tree')

    traitv = traitv[tree$tip.label]
    splits = prop.part(tree)
    ntip = Ntip(tree)
    maxval = 0
    for(s in splits) {
        n1 = sum(!is.na(traitv[s]))
        n2 = sum(!is.na(traitv[-s]))
        if(n1 < N || n2 < N)
            next
        m1 = mean(traitv[s], na.rm=TRUE)
        m2 = mean(traitv[-s], na.rm=TRUE)
        v  = abs(m1 - m2)
        if(v > maxval)
            maxval = v
    }
    maxval
}


rm(list=ls())
library(ggplot2)
library(stargazer)
library(quantmod)
library(dplyr)

start <- as.Date("2010-01-01")
end <- as.Date("2020-10-01")

trade_code <- c(
  "000001.SS",
  "600606.SS", # * Green Land Coporation Ltd
  "002499.SZ", # * Kelin Environmental Protection Equipment, Inc
  "000571.SZ", # * Sundiro Holding Co., Ltd.
  "002259.SZ", # * Sichuan Shengda Forestry Industry Co., Ltd
  "600666.SS", # * Aurora Optoelectronics Co.,Ltd
  "002356.SZ", # * Shenzhen Hemei Group Co.,LTD
  "600289.SS", # * Bright Oceans Inter-Telecom Corporation
  "002418.SZ", # * Zhe Jiang Kangsheng Co.,Ltd.
  "002766.SZ", # * Shenzhen Soling Industrial Co.,Ltd
  "000677.SZ"  # * CHTC Helon Co., Ltd
)

data <- getSymbols(
  trade_code,
  src = "yahoo", from = start, to = end, na.omit = TRUE)

symbolData <- lapply(trade_code,function(x){
  y <- as.data.frame(get(x))
  colnames(y) <- c("open","high","low","close","volume","adjusted", "monmthly_returns")
  y$date <- rownames(y)
  y$symbol <- x
  y
})

combinedData <- do.call(rbind,symbolData)
rownames(combinedData) <- 1:nrow(combinedData)

ggplot(data=combinedData, aes(x=as.Date(date), y=close, color = symbol)) +
  geom_line() +
  labs(x = "", y = "Daily Close Price (RMB)",
       title = "Stock performance of 10 blacklisted companies",
       subtitle = "",
       caption = "Source: yahoo finance") +
  scale_x_date(date_labels="%b %y",date_breaks  ="5 month") +
  theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1), legend.position='none')+
  annotate(geom = "rect", xmin = as.Date("2019-3-1", "%Y-%m-%d"),
           xmax = as.Date("2019-12-31", "%Y-%m-%d"),
           ymin = 0,
           ymax = 50,
           ,fill = "red", alpha = 0.5) +
  annotate("text", x = as.Date("2019-8-15", "%Y-%m-%d"), y = 40, label = "Blacklisted")

# plot the index fund performance;

# pacman::p_load(TTR)
#
# getSymbols("AAPL")
#
# chartSeries(to.weekly(AAPL))
# addMACD()
# addBBands()

Stock_Data <- trade_code %>% lapply(function(x) getSymbols(x,auto.assign=FALSE)) %>%
  lapply(function(x) monthlyReturn(Ad(x)))

plot(Stock_Data[[11]],
     main = "Index ")

#


############# REGRESSION #############

visualize_fit <- function(model, names){

  # Bind ground truth and predicted values
  bind_cols(tibble(truth = test_y_reg), # Ground truth
            predict(model, test_x_reg)) %>% # Predicted values

    # Visualize the residuals
    ggplot(aes(x = truth, y = .pred)) +
    # Diagonal line
    geom_abline(lty = 2) +
    geom_point(alpha = 0.5) +
    # Make X- and Y- scale uniform
    coord_obs_pred() +
    labs(title = glue::glue("{names}"))

}

# Build an evaluation function
evaluate_reg <- function(model){

  # Bind ground truth and predicted values
  bind_cols(tibble(truth = test_y_reg), # Ground truth
            predict(model, test_x_reg)) %>% # Predicted values

    # Calculate root mean-squared error
    metrics(truth = truth, estimate = .pred)
}

############# CLASSIFICATION #############

evaluate_class <- function(model){

  # Bind ground truth and predicted values
  df <- bind_cols(tibble(truth = test_y_class), # Ground truth
                  predict(model, test_x_class)) # Predicted values

  # Calculate metrics
  df %>% metrics(truth = truth, estimate = .pred_class)
}

# The following visualization code draws on [Diego Usai's medium post](https://towardsdatascience.com/modelling-with-tidymodels-and-parsnip-bae2c01c131c).

visualize_class_eval <- function(model){
  evaluate_class(model) %>%
    ggplot(aes(x = fct_reorder(glue("{toupper(.metric)}"), .estimate), y = .estimate)) +
    geom_col() +
    labs(x = "Metrics",
         y = "Estimate") +
    ylim(c(0,1)) +
    geom_text(aes(label = round(.estimate, 2)),
              size = 10,
              color = "red")
}

visualize_class_conf <- function(model){
  bind_cols(tibble(truth = test_y_class), # Ground truth
            predict(model, test_x_class)) %>%
    conf_mat(truth, .pred_class) %>%
    pluck(1) %>% # Select index
    as_tibble() %>% # Vector -> data.frame
    ggplot(aes(Prediction, Truth, alpha = n)) +
    geom_tile(show.legend = FALSE) +
    geom_text(aes(label = n),
              color = "red",
              alpha = 1,
              size = 13)
}


my_df <- data.frame(project_id ,senario_id , year_end , year_id ,year_end_discounted, paste(project_id,senario_id) , Revenue, Risk , Discount_rate, Priority, Commodity, Total_Capex);
#write.xlsx(my_df, "MyData_In.xlsx")
#my_df <- subset(my_df , my_df$year_id>2015);
my_df <- subset(my_df , my_df$year_id>2015  & my_df$year_id<=time_horizon);

my_df <- my_df[with(my_df, order(project_id, senario_id, year_id)), ]

#write.xlsx(my_df, "MyData_In.xlsx")
names(my_df)[6]="combined_id"

out <- split( my_df , f = my_df$combined_id)
#out <- split( my_df , f = my_df$paste.project_id..senario_id.)

irr <- NULL

for( i in 1:length(out))
{
  year_end_list = out[[i]]$year_end
  year_end_discounted_list = out[[i]]$year_end_discounted
  y = cf(year_end_list)
  out[[i]]$irr =max(y$irr[y$irr!=Inf] )
  out[[i]]$NPV =sum(year_end_discounted_list)
}

my_df_new <- unsplit(out, f = my_df$combined_id)
#my_df_new <- unsplit(out, f = my_df$paste.project_id..senario_id.)
my_df_new$PI = my_df_new$NPV/Mod(my_df_new$Total_Capex)
write.csv(my_df_new, "my_df_new_MyData_loc1.csv")

if (levels(my_df_new$Priority) =="1") {

#my_df1a = sqldf("select project_id, senario_id, sum(year_end) as year_end ,  sum(irr) as irr, sum(NPV) as NPV, combined_id
#               from my_df_new group by project_id ,senario_id having max(NPV) ")

my_df1a = sqldf(paste("select project_id, senario_id, year_id, sum(year_end) as year_end ,  sum(irr) as irr, sum(NPV) as NPV, combined_id
            from my_df_new where year_id <="
            ,time_horizon[1],
            "group by project_id ,senario_id, year_id having max(NPV)", sep=" "))

my_df1b <- transform(my_df1a, irr = ifelse(irr == -Inf, 0, irr))
my_df1b <- transform(my_df1b, NPV = ifelse(NPV == -Inf, 0, NPV))

#write.csv(my_df1b, "my_df1b.csv")
#write.csv(my_df_new, "my_df_new.csv")

## Automatation Code 01
my_df_overall = sqldf("select project_id, senario_id  from my_df group by project_id ,senario_id  ")
my_df_project_id = sqldf("select distinct( project_id) from my_df")

num_of_variables=nrow(my_df_overall)

lprec <- make.lp(0, num_of_variables)
lp.control(lprec,sense="max")
set.type(lprec, 1:num_of_variables, type = "binary")

#set.objfn(lprec, my_df1b$irr[1:num_of_variables])
NPV_df = sqldf("select NPV, combined_id from my_df1b group by combined_id")
set.objfn(lprec, NPV_df$NPV[1:num_of_variables])

#add.constraint(lprec, my_df1b$year_end[1:num_of_variables] , ">=", capex_limit)
RowNames_1 = NULL
for( i in 2016:time_horizon[1])
{
  #print(i)
  RowNames_1 = c(RowNames_1 , paste("C_",i,  sep = ""))
  my_df1b_temp <- my_df1b[my_df1b$year_id==i,]
  add.constraint(lprec, my_df1b_temp$year_end[1:num_of_variables] , ">=", -1*capex_limit)
  rm(my_df1b_temp)
}
#add.constraint(lprec, c(1,1,1,0,0,0,0,0,0), "<=", 1)
#add.constraint(lprec, c(0,0,0,1,1,1,0,0,0), "<=", 1)
#add.constraint(lprec, c(0,0,0,0,0,0,1,1,1), "<=", 1)

## Automatic Equation Generating Code 02

x=NULL
number_of_project = nrow(my_df_project_id)
number_of_scenarios = 4
n <- nrow(my_df_overall)
a <- rep(alist(,)[1], n)
a[1:n]=0
b=unlist(a)

#
for (i in 1:number_of_project) x=rbind(x, b);

#
j=1
for (i in 1:number_of_project) {
  c=x[i,]
  number_of_scenarios = unlist(sqldf(paste("select count(distinct(senario_id)) from my_df where project_id=",my_df_project_id[i,], sep=)))

  #print(j)
  print(c[j:(j+number_of_scenarios-1)])
  c[j:(j+number_of_scenarios-1)]=1
  print(c[j:(j+number_of_scenarios-1)])
  x[i,]=c
  j=j+number_of_scenarios
  print(x[i,])
  print(j)
}

for (k in 1:nrow(x)){
add.constraint(lprec, x[k,], "<=", 1)
}

# m1 = c(1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
# m2 = c(0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
# m3 = c(0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
# m4 = c(0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
# m5 = c(0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0)
# m6 = c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0,0,0,0)
# m7 = c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0,0,0,0)
# m8 = c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,0,0,0)
# m9 = c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1)
#
# add.constraint(lprec, m1, "<=", 1)
# add.constraint(lprec, m2, "<=", 1)
# add.constraint(lprec, m3, "<=", 1)
# add.constraint(lprec, m4, "<=", 1)
# add.constraint(lprec, m5, "<=", 1)
# add.constraint(lprec, m6, "<=", 1)
# add.constraint(lprec, m7, "<=", 1)
# add.constraint(lprec, m8, "<=", 1)
# add.constraint(lprec, m9, "<=", 1)
#

ColNames <- c("P1", "P2", "P3","P4","P5","P6","P7","P8","P9","P10","P11","P12","P13","P14","P15", "P16"
				,"P17","P18","P19","P20","P21","P22","P23","P24","P25","P26","P27","P28","P29","P30","P31","P32","P33","P34","P35","P36","P37","P38","P39","P40","P41","P42","P43")
RowNames_0 <- c("C1", "C2", "C3", "C4", "C5", "C6", "C7", "C8", "C9", "C10", "C11", "C12", "C13", "C14", "C15")
RowNames <- c(RowNames_1 , RowNames_0[1:number_of_project])
dimnames(lprec) <- list(RowNames, ColNames[1:num_of_variables])
lprec
write.lp(lprec, "lpfilename.lp", "lp") #write it to a file in LP format

solve(lprec)
get.objective(lprec)
get.primal.solution(lprec)
get.variables(lprec)

combined_id_unique = unique(my_df1b$combined_id)
Selected_id = data.frame(combined_id_unique[get.variables(lprec)==1])
#write.csv(Selected_id , "Selected_id.csv")

rm(lprec)

my_df_1 = sqldf("select * from my_df_new
                    where combined_id in Selected_id
                    group by project_id ,senario_id, year_id
                 having max(NPV)
                order by NPV desc, project_id ,year_id
                ")

#
#my_df_2 = my_df_1[order(my_df_1$NPV , decreasing = TRUE),][1:250,]
my_df_2 <- sqldf("select my_df_new.project_id , my_df_new.senario_id , my_df_new.year_id , my_df_1.year_end_discounted,my_df_1.combined_id,my_df_1.Revenue,my_df_1.Risk, my_df_1.Discount_rate,my_df_1.Priority,my_df_1.Commodity,my_df_1.Total_Capex,my_df_1.irr,my_df_1.NPV,my_df_1.PI
from my_df_new  left outer join my_df_1 USING(project_id, senario_id,
			 year_id)       			")

##"my_df_1.year_end_discounted,my_df_1.combined_id,my_df_1.Revenue,my_df_1.Risk",my_df_1.Discount_rate,my_df_1.Priority,my_df_1.Commodity,my_df_1.Total_Capex,my_df_1.irr,my_df_1.NPV,my_df_1.PI

#my_df_2x = merge(x=my_df_new, y=my_df_1, by = c("project_id","senario_id","year_id") , all.x = TRUE)
write.csv(my_df_2	, "my_df_2x.csv")
#my_df_2 = my_df_1

#[my_df_1$year_id<=as.numeric(gsub(",","",time_horizon)),]

} else if  (levels(my_df_new$Priority) =="2") {
my_df_1 = sqldf("select * from my_df_new group by project_id ,year_id
                 having max( irr) order by irr desc, project_id ,year_id
       ")
#my_df_2 =my_df_1[order(my_df_1$irr, decreasing = TRUE),][1:250,]
my_df_2 <- my_df_1
#[my_df_1$year_id<=as.numeric(gsub(",","",time_horizon)), ]
} else if  (levels(my_df_new$Priority) =="3") {
my_df_1 = sqldf("select * from my_df_new group by project_id ,year_id
                   having max(Revenue) order by Revenue desc, project_id ,year_id
       ")
#my_df_2 =my_df_1[order(my_df_1$Revenue, decreasing = TRUE),][1:250,]
my_df_2 <- my_df_1
#[my_df_1$year_id<=as.numeric(gsub(",","",time_horizon)), ]
} else if  (levels(my_df_new$Priority) =="5") {
my_df_1 = sqldf("select * from my_df_new group by project_id ,year_id
                 having max(PI) order by Revenue desc, project_id ,year_id
       ")
#my_df_2 =my_df_1[order(my_df_1$Revenue, decreasing = TRUE),][1:250,]
my_df_2 <- my_df_1[my_df_1$year_id<=as.numeric(gsub(",","",time_horizon)), ]
} else if  (levels(my_df_new$Priority) =="4") {
my_df_1 = sqldf("select * from my_df_new group by project_id ,year_id
				having min(Risk) order by Revenue desc, project_id ,year_id
       ")
#my_df_2 =my_df_1[order(my_df_1$Revenue, decreasing = TRUE),][1:250,]
my_df_2 <- my_df_1
#[my_df_1$year_id<=as.numeric(gsub(",","",time_horizon)), ]
} else {
my_df_2 = sqldf(" select * from my_df_new group by project_id ,year_id
                   having max(NPV)       ")
}

#write.csv(my_df_1, "my_df_1_Prioritized.csv")
#write.csv(my_df_2, "my_df_2_Prioritized.csv")

# create a connection # save the password that we can "hide" it as best as we can by collapsing it
pw <- {  "password" }

# loads the PostgreSQL driver
drv <- dbDriver("PostgreSQL")

# Disconnect a previous connection
dbDisconnect(con)

# creates a connection to the postgres database
# note that "con" will be used later in each connection to the database
con <- dbConnect(drv, dbname = "Rio_1",
                 host = "localhost", port = 5432,
                 user = "postgres", password = pw)
rm(pw) # removes the password

dbExistsTable(con, "Scenario")
# TRUE
# query the data from postgreSQL
#df_Commodities <- dbGetQuery(con, "SELECT * from \"Commodities\" ")

dbGetQuery(con, "drop table  \"Prioritized\" ")

dbWriteTable(con, "Prioritized", my_df_2, row.names=FALSE)
dbDisconnect(con)


library("animation")
library("plyr")
library("MASS")
#
# ################################################################################
# #   0
# ################################################################################
#
# library("ElemStatLearn")
# require("class")
# mixture.example$xnew
# x <- mixture.example$x
# g <- mixture.example$y
# xnew <- mixture.example$xnew
# mod15 <- knn(x, xnew, g, k=15, prob=TRUE)
# prob <- attr(mod15, "prob")
# prob <- ifelse(mod15=="1", prob, 1-prob)
# px1 <- mixture.example$px1
# px2 <- mixture.example$px2
# prob15 <- matrix(prob, length(px1), length(px2))
# par(mar=rep(2,4))
# contour(px1, px2, prob15, levels=0.5, labels="", xlab="", ylab="", main=
#         "15-nearest neighbour", axes=FALSE)
# points(x, col=ifelse(g==1, "coral", "cornflowerblue"))
# gd <- expand.grid(x=px1, y=px2)
# points(gd, pch=".", cex=1.2, col=ifelse(prob15>0.5, "coral", "cornflowerblue"))
# box()

# spirals
spiral <- function (radius, theta, sequence, col) {
    r <- radius(sequence)
    t <- theta(sequence)
    x <- r * sin(t)
    y <- r * cos(t)
    return(data.frame(x=x, y=y))
    # points(x, y, col=col)
}
sigmoid <- function (n) 1/(1 + exp(-n))

computeLayer <- function (input, weights) {
    sums <- colSums(input * weights)
    return(sigmoid(sums))
}

computeAll <- function (input, weights) {
    numberOfLayers <- length(weights)
    output <- list()
    output[[1]] <- input
    for (i in 1:numberOfLayers) {
        output[[i + 1]] <- computeLayer(output[[i]], weights[[i]])
    }
    return(output)
}

classify <- function (input, weights) {
    numberOfLayers <- length(weights)
    output <- input
    for (i in 1:numberOfLayers) {
        output <- computeLayer(output, weights[[i]])
    }
    return(output)
}

mse <- function (target, output) {
    diff <- target - output
    return(sum(diff * diff)/2)
}

learn <- function (weights, input, target, learningRate = 0.5) {

    outputs <- computeAll(input, weights)
    numberOfLayers <- length(weights)

    # linear programming, tabulate deltas
    deltas <- list()

    # tabulate the output layer first
    output <- outputs[[numberOfLayers + 1]]
    deltas[[numberOfLayers]] <- (target - output) * output * (1 - output)
    # tabulate the rest
    if (numberOfLayers > 1) {
        for (layer in (numberOfLayers - 1):1) {
            output <- outputs[[layer + 1]]
            weight <- weights[[layer + 1]]

            sums <- rowSums(deltas[[layer + 1]] * weights[[layer + 1]])
            deltas[[layer]] <- sums * output * (1 - output)
        }
    }

    for (layer in 1:numberOfLayers) {
        weights[[layer]] <- weights[[layer]] + outputs[[layer]] %o% deltas[[layer]] * learningRate
    }

    return(list(
        weights = weights,
        error = mse(target, outputs[[numberOfLayers + 1]])
        ))
    # return(weights)
}

plotErrors <- function (errors) {
    if (length(errors) > 0) {
        plot(errors, xlab="iteration", ylab="error", type="h")
        title("error / iteration")
    }
}

reconstruct <- function (weights) {
    structure <- c()
    for (i in 1:length(weights)) {
        structure <- c(structure, nrow(weights[[i]]))
    }
    structure <- c(structure, ncol(weights[[i]]))
    return(structure)
}

identityWeights <- function (nodes) {
    weights <- list()
    for (i in 1:(length(nodes) - 1)) {
        rows <- nodes[i]
        cols <- nodes[i + 1]
        weights[[i]] <- matrix(0, rows, cols)
    }
    return(weights)
}

initializeWeights <- function (nodes) {
    weights <- list()
    for (i in 1:(length(nodes) - 1)) {
        rows <- nodes[i]
        cols <- nodes[i + 1]
        size <- rows * cols
        weights[[i]] <- matrix(sigmoid(rexp(size)), rows, cols)
    }
    return(weights)
}

accumulateWeights <- function (acc, x) {
    for (i in 1:length(acc)) {
        acc[[i]] <- acc[[i]] + x[[i]]
    }
    return(acc)
}

train <- function (weights, callback, iteration = 100000, until = 0.1, every = 1000) {

    errors <- c()
    learningRate <- 1

    for (i in 1:iteration) {
        accumulatedError <- 0

        # class 0
        size <- length(class0$x)
        for (j in 1:size) {
            data <- class0[j, ]
            result <- learn(weights, c(data$x, data$y, 1), c(1, 0), learningRate)
            weights <- result$weights
            accumulatedError <- accumulatedError + result$error
        }
        # class 1
        size <- length(class1$x)
        for (j in 1:size) {
            data <- class1[j, ]
            result <- learn(weights, c(data$x, data$y, 1), c(0, 1), learningRate)
            weights <- result$weights
            accumulatedError <- accumulatedError + result$error
        }
        errors <- c(errors, accumulatedError)

        if (accumulatedError < until) {
            print(i)
            break
        }

        if (i %% every == 0) {
            callback(i, weights, errors)
        }
    }
    return(list(
        weights = weights,
        errors = errors
        ))
}

drawGrid <- function (weights) {
    grid <- expand.grid(x=seq(-8, 8, by=0.2), y=seq(-8, 8, by=0.2))
    gridResult <- aaply(grid, 1, function (data) {
            result <- classify(c(data$x, data$y, 1), weights)
            return(ifelse(result[1] > result[2], "cornflowerblue", "coral"))
        })
    points(grid, pch=".", cex=3, col=gridResult)
}

################################################################################
#   1
################################################################################

plot(NA, NA, xlim=c(-8,8), ylim=c(-8,8),
    xlab="x", ylab="y",
    axes=FALSE, asp=1)
axis(side=1, at=seq(-8, 8, by=2), cex.axis=0.8)
axis(side=2, at=seq(-8, 8, by=2), cex.axis=0.8)
title("Two Spiral Problem")

# class0 <- spiral(function (i) (6.5 * (104 - i) / 104),
#     function (i) (pi * i / 8),
#     40:52)
#
# class1 <- spiral(function (i) (6.5 * (104 - i) / -104),
#     function (i) (pi * i / 8),
#     40:52)
# class0 <- spiral(function (i) (6.5 * (104 - i) / 104),
#     function (i) (pi * i / 8),
#     0:10)
#
# class1 <- spiral(function (i) (6.5 * (104 - i) / -104),
#     function (i) (pi * i / 8),
#     0:10)
class0 <- data.frame(x=c(-5), y=c(-2))
class1 <- data.frame(x=c(1), y=c(-1))

# class0 <- data.frame(x=c(-4, -4, 4, 0), y=c(-4, 4, 4, 0))
# class1 <- data.frame(x=c(4), y=c(-4))

# class0 <- data.frame(x=c(-4, -4, 4, 0), y=c(-4, 4, -4, 0))
# class1 <- data.frame(x=c(4, -2, 0, 2, 4), y=c(4, -2, -2, -2, -2))
# class0 <- data.frame(x=c(-4, 4), y=c(4, -4))
# class1 <- data.frame(x=c(4, -4), y=c(4, -4))

points(class0, col="cornflowerblue", cex=2)
points(class1, col="coral", cex=2)

layers <- c(3, 5, 2)
# weights <- initializeWeights(layers)

weights <- list()
weights[[1]] <- matrix(
    c(1.716595448658756, 1.1764761912424921, 1.557118196208473, 1.7041037817911824, 1.6406029506187856,
     0.6146408255673677, 1.2674559523877986, 0.8036832609525906, 0.4969173598004548, 0.7056984961660893,
     0.978526932134667, 0.3158700142016504, 0.7265454504592824, 0.6660428783020633, 0.6623111268153622),
     3, 5, byrow = TRUE)
weights[[2]] <- matrix(
    c(-1.3136394181316513, 1.0616230793282784,
     -0.1289445413211639, 1.0017360756800076,
     -0.9759845197492095, 1.0231283450037518,
     -1.276113700799778, 1.1112948075375635,
     -1.325443401614583, 1.1986825244676422), 5, 2, byrow = TRUE)

# print(computeLayer(c(1, -1, 1), weights[[1]]))

result <- train(weights, function (i, weights, errors) {
    print(errors[i])
    }, 10000)
print(result$weights)
drawGrid(result$weights)
plotErrors(result$errors)


# Compare means with Kruskal-Wallis test (nonparametric, because non-normal distribution)

dataq <- read.csv('../../results/in_vs_out_band/data_all.csv', sep = ';')

# Means
aggregate(dataq$time, list(dataq$combination), median)

#boxplot(time ~ combination, data = data, ylab="Exec (ms)", xlab="Combination")

# H0: Equal means between combinations
kruskal.test(time ~ combination, data = dataq)
# p: 0.7323
# => Accept H0, equal means

datahttp <- read.csv('../../results/in_vs_out_band/data_http.csv', sep = ';')
# H0: Equal means between combinations
kruskal.test(requests ~ combination, data = datahttp)
# p: 0.406
# => Accept H0, equal means


#create labels for plots
articulationlabel <- "Articulation rate (syl/phonation)"
labparticipantslabel <- "Lab Participants"
bloggingpodcasterslabel <- "Blogging Podcasters"
nusableparticipants <- "(n=5)"
nallparticipants <- "(n=12)"

#read in data
aublog <- read.table("/Users/gina/Documents/aublog/results/resultsboxplotformat.csv", header=TRUE, sep="," )
aublogall <- read.table("/Users/gina/Documents/aublog/results/results.csv", header=TRUE, sep="," )

# histogram for all lab participant aritculation rate
pdf("/Users/gina/Documents/aublog/results/histogramalllab.pdf",width=6,height=6,paper='special')
x <- aublogall$artirate
title <-paste(labparticipantslabel,nallparticipants, sep = " ", collapse = NULL)
h<-hist(x, breaks=10, col="red", xlab=articulationlabel, yaxt="n",
  	 main=title)
xfit<-seq(min(x),max(x),length=40)
yfit<-dnorm(xfit,mean=mean(x),sd=sd(x))
yfit <- yfit*diff(h$mids[1:2])*length(x)
lines(xfit, yfit, col="blue", lwd=2)
dev.off()

#Box plot comparing articulation rate in the two blog drafts
# http://www.statmethods.net/graphs/boxplot.html
pdf("/Users/gina/Documents/aublog/results/boxplotusablelab.pdf",width=6,height=6,paper='special')
title <-paste(labparticipantslabel,nusableparticipants,"p = 0.2662", sep = " ", collapse = NULL)
boxplot(artirate~draft,data=aublog, notch=TRUE, col=(c("red","darkgreen")), main=title,  xlab="(Insignificant Tendency for faster syllable timing in second Blog Draft)", ylab=articulationlabel)
dev.off()

#boxplot(phonationtime~draft,data=aublog, main=title,  xlab="Blog Draft", ylab=articulationlabel)
#boxplot(nsyll~draft,data=aublog, main=title,  xlab="Blog Draft", ylab=articulationlabel)
#boxplot(speechrate~draft,data=aublog, main=title,  xlab="Blog Draft", ylab=articulationlabel)

#Compaire groups via kernal density
pdf("/Users/gina/Documents/aublog/results/densityusablelab.pdf",width=6,height=6,paper='special')
title <-paste(labparticipantslabel,"density distribution",nusableparticipants, sep = " ", collapse = NULL)
sm.density.compare(aublog$artirate, aublog$draft, xlab=articulationlabel)
title(main=title)
# add legend via mouse click
drafts.f <- factor(aublog$draft, levels= c(1,2), labels = c("1st Draft","2nd Draft"))
colfill<-c(2:(2+length(levels(drafts.f))))
#legend(locator(1), levels(drafts.f), fill=colfill)
legend("topright", levels(drafts.f), fill=colfill)

dev.off()

#skeptoid histogram
skeptoid <- read.table("/Users/gina/Documents/aublog/results/praatresultsskeptoid.csv", header=TRUE, sep="," )
pdf("/Users/gina/Documents/aublog/results/histogrambloggingpodcasters.pdf",width=6,height=6,paper='special')
x <- skeptoid$artirate
title <-paste(bloggingpodcasterslabel,"(n=47)", sep = " ", collapse = NULL)
h<-hist(x, breaks=10, col="red", xlab=articulationlabel, yaxt="n",
     main=title)
xfit<-seq(min(x),max(x),length=40)
yfit<-dnorm(xfit,mean=mean(x),sd=sd(x))
yfit <- yfit*diff(h$mids[1:2])*length(x)
lines(xfit, yfit, col="blue", lwd=2)
dev.off()

#Paired t-test insignificant (too small sample size and too much variance): test Hypothesis1 that draft1 has slower articulation rate than draft2
aublogttest <- read.table("/Users/gina/Documents/aublog/results/resultsttestarticulationrate.csv", header=TRUE, sep="," )

t.test(aublogttest$draft1,aublogttest$draft2,paired=TRUE, alt="less")

	Paired t-test

data:  aublogttest$draft1 and aublogttest$draft2
t = -0.6826, df = 4, p-value = 0.2662
alternative hypothesis: true difference in means is less than 0
95 percent confidence interval:
      -Inf 0.3057439
sample estimates:
mean of the differences
                 -0.144

#Compare all participant data to skeptoid

 t.test(aublogall$artirate,skeptoid$artirate)

	Welch Two Sample t-test

data:  articulationrate and skeptoid$artirate
t = -6.0765, df = 21.333, p-value = 4.649e-06
alternative hypothesis: true difference in means is not equal to 0
95 percent confidence interval:
 -1.2350082 -0.6056605
sample estimates:
mean of x mean of y
 4.002857  4.923191


library(mclust) # contains an ARI function

mse <- function(y_test, P_test, traces_coefficients, traces_intercept, traces_noise_inv){
  n_sample <- dim(traces_coefficients)[1]
  error <- 0
  locs <-  t(P_test) %*% t(traces_coefficients) # y_pred without intercept
  locs <- t(apply(locs, 1, function(x) x+t(traces_intercept))) # add intercept
  for(j in 1:n_sample){
    error <- error + sum((y_test-locs[,j])^2)
  }
  error/(n_sample*length(y_test))
}

loglike <- function(y_test, P_test, traces_coefficients, traces_intercept, traces_noise_inv){
  n_sample = dim(traces_coefficients)[1]
  loglike = 0
  locs <-  t(P_test) %*% t(traces_coefficients) # y_pred without intercept
  locs <- t(apply(locs, 1, function(x) x+t(traces_intercept))) # add intercept
  sd_noise = 1/sqrt(traces_noise_inv)
  for(j in 1:n_sample){
    loglike <- loglike + sum(dnorm(y_test,
                                   mean = locs[,j],
                                   sd = sd_noise[j],
                                   log=TRUE)
    )
  }
  1.0*loglike/(n_sample*length(y_test))
}