context("Check against OLS for k-class")

test_that("OLS estimates from lm should be identical to k-class with k = 0, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  olsfit = lm(Y ~ D - 1)
  estcoef = as.numeric(coef(olsfit)); estvar = as.numeric(diag(vcov(olsfit)))
  estfit = as.numeric(predict(olsfit)); estresid = as.numeric(residuals(olsfit))
  ivfit = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  estcoef_iv = as.numeric(as.numeric(coef(ivfit)["OLS","Estimate"]));
  estvar_iv = as.numeric(vcov(ivfit)["OLS",2])
  estfit_iv = as.numeric(fitted(ivfit)[,"OLS"]); estresid_iv = as.numeric(residuals(ivfit)[,"OLS"])

  expect_equal(estcoef,estcoef_iv)
  expect_equal(estvar,estvar_iv)
  expect_equal(estfit,estfit_iv)
  expect_equal(estresid,estresid_iv)

  olsfit = lm(Y ~ D)
  estcoef = as.numeric(coef(olsfit)); estvar = as.numeric(diag(vcov(olsfit)))
  estfit = as.numeric(predict(olsfit)); estresid = as.numeric(residuals(olsfit))
  ivfit = ivmodel(Y=Y,D=D,Z=Z)
  estcoef_iv = c(as.numeric(coefOther(ivfit)$OLS[,"Estimate"]),as.numeric(coef(ivfit)["OLS","Estimate"]))
  estvar_iv = c(as.numeric(vcovOther(ivfit)["OLS",-1]),as.numeric(vcov(ivfit)["OLS",2]))
  estfit_iv = as.numeric(fitted(ivfit)[,"OLS"]); estresid_iv = as.numeric(residuals(ivfit)[,"OLS"])

  expect_equal(estcoef,estcoef_iv)
  expect_equal(estvar,estvar_iv)
  expect_equal(estfit,estfit_iv)
  expect_equal(estresid,estresid_iv)

  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X= as.matrix(card.data[,Xname])

  olsfit = lm(Y ~ D + X)
  estcoef = as.numeric(coef(olsfit)); estvar = as.numeric(diag(vcov(olsfit)))
  estfit = as.numeric(predict(olsfit)); estresid = as.numeric(residuals(olsfit))
  ivfit = ivmodel(Y=Y,D=D,Z=Z,X=X)
  estcoef_iv = c(as.numeric(coefOther(ivfit)$OLS[nrow(coefOther(ivfit)$OLS),"Estimate"]),
                 as.numeric(coef(ivfit)["OLS","Estimate"]),
                 as.numeric(coefOther(ivfit)$OLS[-nrow(coefOther(ivfit)$OLS),"Estimate"]))
  estvar_iv = c(as.numeric(vcovOther(ivfit)["OLS","intercept"]),
                as.numeric(vcov(ivfit)["OLS",2]),
                as.numeric(vcovOther(ivfit)["OLS",-c(1,ncol(vcovOther(ivfit)))]))
  estfit_iv = as.numeric(fitted(ivfit)[,"OLS"]); estresid_iv = as.numeric(residuals(ivfit)[,"OLS"])

  expect_equal(estcoef,estcoef_iv)
  expect_equal(estvar,estvar_iv)
  expect_equal(estfit,estfit_iv)
  expect_equal(estresid,estresid_iv)
})

test_that("AR test without exogeneous covariates and intercept, mult-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]

  olsfit = lm(Y ~ D - 1)
  estcoef = as.numeric(coef(olsfit)); estvar = as.numeric(diag(vcov(olsfit)))
  estfit = as.numeric(predict(olsfit)); estresid = as.numeric(residuals(olsfit))
  ivfit = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  estcoef_iv = as.numeric(as.numeric(coef(ivfit)["OLS","Estimate"]));
  estvar_iv = as.numeric(vcov(ivfit)["OLS",2])
  estfit_iv = as.numeric(fitted(ivfit)[,"OLS"]); estresid_iv = as.numeric(residuals(ivfit)[,"OLS"])

  expect_equal(estcoef,estcoef_iv)
  expect_equal(estvar,estvar_iv)
  expect_equal(estfit,estfit_iv)
  expect_equal(estresid,estresid_iv)

  olsfit = lm(Y ~ D)
  estcoef = as.numeric(coef(olsfit)); estvar = as.numeric(diag(vcov(olsfit)))
  estfit = as.numeric(predict(olsfit)); estresid = as.numeric(residuals(olsfit))
  ivfit = ivmodel(Y=Y,D=D,Z=Z)
  estcoef_iv = c(as.numeric(coefOther(ivfit)$OLS[,"Estimate"]),as.numeric(coef(ivfit)["OLS","Estimate"]))
  estvar_iv = c(as.numeric(vcovOther(ivfit)["OLS",-1]),as.numeric(vcov(ivfit)["OLS",2]))
  estfit_iv = as.numeric(fitted(ivfit)[,"OLS"]); estresid_iv = as.numeric(residuals(ivfit)[,"OLS"])

  expect_equal(estcoef,estcoef_iv)
  expect_equal(estvar,estvar_iv)
  expect_equal(estfit,estfit_iv)
  expect_equal(estresid,estresid_iv)

  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X= as.matrix(card.data[,Xname])

  olsfit = lm(Y ~ D + X)
  estcoef = as.numeric(coef(olsfit)); estvar = as.numeric(diag(vcov(olsfit)))
  estfit = as.numeric(predict(olsfit)); estresid = as.numeric(residuals(olsfit))
  ivfit = ivmodel(Y=Y,D=D,Z=Z,X=X)
  estcoef_iv = c(as.numeric(coefOther(ivfit)$OLS[nrow(coefOther(ivfit)$OLS),"Estimate"]),
                 as.numeric(coef(ivfit)["OLS","Estimate"]),
                 as.numeric(coefOther(ivfit)$OLS[-nrow(coefOther(ivfit)$OLS),"Estimate"]))
  estvar_iv = c(as.numeric(vcovOther(ivfit)["OLS","intercept"]),
                as.numeric(vcov(ivfit)["OLS",2]),
                as.numeric(vcovOther(ivfit)["OLS",-c(1,ncol(vcovOther(ivfit)))]))
  estfit_iv = as.numeric(fitted(ivfit)[,"OLS"]); estresid_iv = as.numeric(residuals(ivfit)[,"OLS"])

  expect_equal(estcoef,estcoef_iv)
  expect_equal(estvar,estvar_iv)
  expect_equal(estfit,estfit_iv)
  expect_equal(estresid,estresid_iv)
})


library(nlme,lib.loc="~/RPackages")

library(spTimer,lib.loc="~/RPackages")
library(R.matlab,lib.loc="~/RPackages")
library(sp,lib.loc="~/RPackages")
library(iterators,lib.loc="~/RPackages")
library(foreach,lib.loc="~/RPackages")
library(doParallel,lib.loc="~/RPackages")

setwd("~/RProject")
rm(list=ls())

#data
temp <- readMat("Longhurst_180.mat")
Longhurst <- temp$Longhurst

area <- sort(unique(Longhurst[!is.na(Longhurst)]))#list of longhurst areas to iterate through
area <- area[-c(1,2,4,6,7,8,10,11,12,13,17,18,19,22,25,26,27,29,30,31,34,35,36,40,43,41,42,47,50,53,54)] #remove polar,coastal, GoM, Archipelagic Deep basin, Mediterranean

part <- seq(1,41,1)
######create function for running burn in
dothisburn <- function(j){
savename <- paste0(j,"_BGC_input.Rdata")
load(savename)

####Simple model
time.data <- spT.time(t.series=196,segments=1)

Model<- spT.Gibbs(
  formula = chl ~ TT+SST+M,
  data=spTmodel, model="GPP",
  coords=~Longitude+Latitude,knots.coords=knotgrid,
  distance.method="geodetic:km", time.data=time.data, report=1,
  nItr =1000, nBurn=0,  scale.transform="LOG",
  priors=spT.priors(model="GPP", inv.var.prior=Gamm(a=2,b=1),
  beta.prior=Norm(0,10^2), rho.prior=Norm(0,10^2)),
  spatial.decay=spT.decay(distribution="FIXED", value=(3/1500)))

  savename <- paste0(j,"_BGC_burn.Rdata")

  #save used components of model (including what was previously saved in sptmodel input)
  betap <- Model$betap
  fitted <- Model$fitted
  model_input <- Model$data
   PMCC <- Model$PMCC
    rhop <- Model$rhop
  sig2eps <- Model$sig2eps
  sig2etap <- Model$sig2etap
  comp <- Model$computation.time

  save(betap,fitted,model_input,PMCC,rhop,sig2eps,sig2etap,comp,init,file=savename)

   rm(list=c("Model","betap","fitted","model_input","PMCC","rhop","sig2eps","sig2etap"))

}
######create function for whole run
run_parallel <- function(i,j){
savename <- paste0(j,"_BGC_input.Rdata")
load(savename)
if(i>1)
{
  savename <- paste0(j,"_BGC_model_pt",i-1,".Rdata")#load last iteration
load(savename)

####Subsequent sets of model iterations
time.data <- spT.time(t.series=196,segments=1)

Model<- spT.Gibbs(
  formula = chl ~ TT+SST+M,
  data=spTmodel, model="GPP",
  coords=~Longitude+Latitude,knots.coords=knotgrid,
  distance.method="geodetic:km", time.data=time.data, report=1,
  nItr =1000, nBurn=0,  scale.transform="LOG", initials=init,
  priors=spT.priors(model="GPP", inv.var.prior=Gamm(a=2,b=1),
  beta.prior=Norm(0,10^2), rho.prior=Norm(0,10^2)),
  spatial.decay=spT.decay(distribution="FIXED", value=(3/1500)))

  savename <- paste0(j,"_BGC_model_pt",i-1,".Rdata")

  #save used components of model (including what was previously saved in sptmodel input)
  betap <- Model$betap
  fitted <- Model$fitted
  model_input <- Model$data
   PMCC <- Model$PMCC
    rhop <- Model$rhop
  sig2eps <- Model$sig2eps
  sig2etap <- Model$sig2etap
  comp <- Model$computation.time
      leg <- length(rhop)
  init=spT.initials(model="GPP",sig2eps=sig2eps[leg],sig2eta=sig2etap[leg],rho=rhop[leg],beta=betap[,leg])#initials from starting off next leg
  save(betap,fitted,model_input,PMCC,rhop,sig2eps,sig2etap,comp,file=savename)

   rm(list=c("Model","betap","fitted","model_input","PMCC","rhop","sig2eps","sig2etap"))
 } else{
 ####First 1000 model iterations
time.data <- spT.time(t.series=196,segments=1)

Model<- spT.Gibbs(
  formula = chl ~ TT+SST+M,
  data=spTmodel, model="GPP",
  coords=~Longitude+Latitude,knots.coords=knotgrid,
  distance.method="geodetic:km", time.data=time.data, report=1,
  nItr =1000, nBurn=0,  scale.transform="LOG",
  priors=spT.priors(model="GPP", inv.var.prior=Gamm(a=2,b=1),
  beta.prior=Norm(0,10^2), rho.prior=Norm(0,10^2)),
  spatial.decay=spT.decay(distribution="FIXED", value=(3/1500)))

  savename <- paste0(j,"_BGC_model_pt",(i-1),".Rdata")

  #save used components of model (including what was previously saved in sptmodel input)
  betap <- Model$betap
  fitted <- Model$fitted
  model_input <- Model$data
   PMCC <- Model$PMCC
    rhop <- Model$rhop
  sig2eps <- Model$sig2eps
  sig2etap <- Model$sig2etap
  comp <- Model$computation.time
      leg <- length(rhop)
  init=spT.initials(model="GPP",sig2eps=sig2eps[leg],sig2eta=sig2etap[leg],rho=rhop[leg],beta=betap[,leg])#initials from starting off next leg
  save(betap,fitted,model_input,PMCC,rhop,sig2eps,sig2etap,comp,file=savename)

   rm(list=c("Model","betap","fitted","model_input","PMCC","rhop","sig2eps","sig2etap"))
 }
}
 #multi core setup

 registerDoParallel(cores=8)

 #run subsequent iterations
 foreach(i=part,.packages="spTimer")  %:%
foreach(j=area,.packages="spTimer")  %dopar%

{
  run_parallel(i,j)
}


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

GbmPredictionsTrain<- function(train.name="train",method.list,num.cv=10) {

	# Calculates GBM combinations based on the cv prediction files made
	#	by other methods, ie, regresses cv test predictions on the truth
	#	(Note: GetPredictionData function is in the average_predictions file)
	#
	# Args:
	#	train.name: base name of training data from which splits are created
	# 	method.list: a list, where each element is a list of method args used for
	#   	each prediction to be averaged and the name of each element is the  method
	#
	# Returns:
	#	  A GBM model
	#
	# Example usage:
	if(FALSE) {
		features <- c("static","alsfrs","fvc","svc","vital")
		slope.features <- NULL
		glm.args <- list(R=1,pls=FALSE,prune=FALSE,std=FALSE,features=features,
			slope.features=slope.features)
		rf.args <- c(corr.bias=FALSE, glm.args)
		gbm.args <- glm.args
		bag.args <- glm.args
		# glm.prune.args <- glm.args; glm.prune.args$prune = TRUE
		# rf.prune.args <- rf.args; rf.prune.args$prune = TRUE
		# gbm.prune.args <- glm.prune.args
		# bag.prune.args <- glm.prune.args

		method.list<-list(
			# "RandomForestTrain"=rf.prune.args,
			# "GlmnetTrain"=glm.prune.args,
			# "GbmTrain"=gbm.prune.args,
			# "BaggingTrain"=bag.prune.args,
			"RandomForestTrain"=rf.args,
			"GlmnetTrain"=glm.args,
			"GbmTrain"=gbm.args,
			"BaggingTrain"=bag.args
		)

		model<-GbmPredictionsTrain("train", method.list)
		predictions<-model("test")
	}
	############################################################################

	# Get vector of train names corresponding to cv splits
	train.names<-paste(train.name,"-cvtrain_",1:num.cv,"of",num.cv,sep="")

	# Get vector of test names corresponding to cv splits
	test.names<-paste(train.name,"-cvtest_",1:num.cv,"of",num.cv,sep="")

	# Function that gets prediction data from each set of arguments for one cv split
	GetCvPredictions<-function(train.name.cv,test.name.cv,method.list) {
		return(sapply(names(method.list),GetPredictionData,train.name.cv,
			test.name.cv,method.list))
	}
    # Get prediction data for all cv splits
    train.preds<-mapply(GetCvPredictions,train.names,test.names,list(method.list))

    # Stack prediction data
    train.preds<-do.call(rbind,train.preds)

    # Get subject ids in same order
    subject.ids<-do.call(rbind,lapply(test.names,GetSubjectIds))

    # Put together prediction data with subject ids
    train.preds<-cbind(subject.ids,train.preds)

    # Sort by subject id
    train.preds<-train.preds[order(train.preds$subject.id),]

    # Get targets
    target<-Slopes(GetAlsfrsData(train.name),3,12,"f")

    # Use Gbm on predictions
   	object <- gbm(target~.,data=train.preds[,-1],distribution="gaussian",
   		n.trees=20000,cv.folds=10,verbose=FALSE)

    # Find optimal number of iterations
    best.iter<-gbm.perf(object,method="cv",plot.it=FALSE)

    # Report relative influence
    print(summary(object,plot=FALSE))
    # Report CV internal error
    print(paste("Internal CV error:",sqrt(min(object$cv.error))))

    # Report error on our CV splits
    train.err <- Rmsd(target, predict(object,train.preds[,-1],best.iter))

    print(paste("Error on our CV splits:",train.err))

    return(list(object = object, param = best.iter))

	GbmPredictionsPredict<- function(test.name="test",save.preds=TRUE) {
		#	Makes predictions based on a ridge regression on predictions from
		#	other methods
		#
		# Args:
		#	test.name: base name of test data
		# 	save.preds: saves to file if TRUE
		#
		# Returns:
		#	 A matrix of subject ids and corresponding predictions
		#
		# Side effects:
		# 	Writes to a file in the predictions folder

		# Get test prediction data
		test.preds<-sapply(names(method.list),GetPredictionData,train.name,
			test.name,method.list)

       	# Make test predictions
       	predictions<-predict(object,test.preds,param)

		# Get subject ids for test set
		subject.ids<-GetSubjectIds(test.name)

		predictions <- cbind(subject.ids,predictions)

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("GbmPredictionsTrain",train.name,
				test.name,method.list)
			WritePredictions(predictions, out.file)
		}

		return(predictions)
	}

	return(GbmPredictionsPredict)
}


###############################################################################
#  Copyright (C) 1994 - 2009, Performance Dynamics Company                    #
#                                                                             #
#  This software is licensed as described in the file COPYING, which          #
#  you should have received as part of this distribution. The terms           #
#  are also available at http://www.perfdynamics.com/Tools/copyright.html.    #
#                                                                             #
#  You may opt to use, copy, modify, merge, publish, distribute and/or sell   #
#  copies of the Software, and permit persons to whom the Software is         #
#  furnished to do so, under the terms of the COPYING file.                   #
#                                                                             #
#  This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY  #
#  KIND, either express or implied.                                           #
###############################################################################

# Load the library
library("pdq")
#
# T/put bounds for closed tandem QNM with increasing Z
# Created by NJG on Fri Feb 27, 2009
#
clients = 300
thinkZ  = 800 * 10^(-3) # ms as seconds
stime   = 20  * 10^(-3) # ms as seconds
node1   = "n1"
node2   = "n2"
node3   = "n3"
work    = "w"
for(z in 1:3) {
   xc<-0 # prudent to reset these
   yc<-0
   for (i in 1:clients) {
      Init("")
      if (z==1) {think<-thinkZ * 0}
      if (z==2) {think<-thinkZ * 2}
      if (z==3) {think<-thinkZ * 4}
      CreateClosed(work, TERM, as.double(i), think)
      CreateNode(node1, CEN, FCFS)
      CreateNode(node2, CEN, FCFS)
      CreateNode(node3, CEN, FCFS)
      SetDemand(node1, work, stime)
      SetDemand(node2, work, stime)
      SetDemand(node3, work, stime)
      Solve(APPROX)
      xc[i]<-as.double(i)
      yc[i]<-GetThruput(TERM, work)
      nopt<-(3*stime + think)/stime
     }
    if (z==1) {
    	# establish plot frame and first curve
        plot(xc, yc, type="l", ylim=c(0,1/stime), lwd=2, xlab="N Clients",
             ylab="Throughput X(N)")
        title("Increasing Z Values")
      	abline(0, 1/(nopt*stime), lty="dashed",  col = "blue")
      	abline(1/stime, 0, lty="dashed",  col = "red")
      	abline(v=nopt, lty="dashed", col="gray50")
        text(20+nopt, 35, paste("Z=", as.numeric(think)))
      	text(3+nopt, 6, paste("N*=", as.numeric(nopt)))
    } else {
    	# add the other curves
      	points(xc, yc, type="l", lwd=2)
      	abline(0, 1/(nopt*stime), lty="dashed",  col = "blue")
      	abline(v=nopt, lty="dashed", col="gray50")
      	format(think, scientific = TRUE)
      	text(4+nopt, 35, paste("Z=", as.numeric(think)))
      	text(3+nopt, 6, paste("N*=", as.numeric(nopt)))
    }
}


startest <- function(y,x,x.n=NULL,tvar,tvar.lag=6,ascending=F,diag.lag=6,crit=.05,contemp=T){

  y <- as.matrix(y)
  n.y <- nrow(y)

  x <- as.matrix(x)
  n.l <- nrow(x)
  m.l <- ncol(x)

  if(is.null(x.n)){
    x.n <- x
  }
  x.n <- as.matrix(x.n)
  n.n <- nrow(x.n)
  m.n <- ncol(x.n)

  tv     <- as.matrix(tvar)
  tvar.num <- ncol(tv)
  if(tvar.num==1){
    tv.mat <- as.matrix(embed(tv,tvar.lag+1))
  }else{
    tv.mat <- tv
  }
  n.t    <- nrow(tv.mat)

  if(contemp==T){
    if(tvar.lag==0 & tvar.num==1){
      colnames(tv.mat)   <- "s.0"
    }else if(tvar.lag!=0 & tvar.num==1){
      colnames(tv.mat)   <- c(paste0("s.0"),colnames(tv.mat[,-1],do.NULL=F,prefix="s."))
    }else{
      colnames(tv.mat)   <- colnames(tv.mat,do.NULL=F,prefix="s.")
    }
  }else{
    if(tvar.lag==0 & tvar.num==1){
      colnames(tv.mat)   <- "s.1"
    }else{
      colnames(tv.mat)   <- colnames(tv.mat,do.NULL=F,prefix="s.")
    }
  }

  n <- min(c(n.y,n.l,n.n,n.t))

  if(n.y > n){y      <- as.matrix(y[-c(1:(n.y-n)),])}
  if(n.l > n){x      <- as.matrix(x[-c(1:(n.l-n)),])}
  if(n.n > n){x.n    <- as.matrix(x.n[-c(1:(n.n-n)),])}
  if(n.t > n){
    tv.mat <- as.matrix(tv.mat[-c(1:(n.t-n)),])
    if(tvar.lag==0){
      colnames(tv.mat)   <- "s.0"
    }
  }

  e <- as.matrix(lm(y~x-1)$resid)

  e.mat <- matrix(0,n,diag.lag)
  for(i in 1:diag.lag){
    e.mat[(i+1):n,i] <- e[1:(n-i),]
  }
  e2.mat <- e.mat^2
  ac.vec <- matrix(NA,diag.lag,1)
  arch.vec <- matrix(NA,diag.lag,1)
  for(i in 1:diag.lag){
    x.e          <- cbind(e.mat[,1:i],x)
    ac.vec[i,]   <- round(anova(lm(e~x.e-1),lm(e~x-1))[2,6],4)
    e2           <- as.matrix(e^2)
    x.e2         <- cbind(1,e2.mat[,1:i])
    x.r2         <- matrix(1,n,1)
    arch.vec[i,] <- round(anova(lm(e2~x.e2-1),lm(e2~x.r2-1))[2,6],4)
  }
  rownames(ac.vec)   <- rownames(ac.vec,do.NULL=F,prefix="AC.")
  rownames(arch.vec) <- rownames(arch.vec,do.NULL=F,prefix="ARCH.")
  colnames(ac.vec)   <- 'AC'
  colnames(arch.vec) <- 'ARCH'

  nl.out <- matrix(NA,ncol(tv.mat),4)

  for(i in 1:ncol(tv.mat)){

    s.1 <- as.matrix(tv.mat[,i])
    s.2 <- s.1^2
    s.3 <- s.1^3

    t.1 <- as.matrix(c(1:n)/n)
    t.2 <- t.1^2
    t.3 <- t.1^3

    zs.1 <- as.numeric(s.1)*x.n
    zs.2 <- as.numeric(s.2)*x.n
    zs.3 <- as.numeric(s.3)*x.n

    zt.1 <- as.numeric(t.1)*x.n
    zt.2 <- as.numeric(t.2)*x.n
    zt.3 <- as.numeric(t.3)*x.n

    x.0  <- cbind(x)

    xs.1 <- cbind(x,zs.1)
    xs.2 <- cbind(x,zs.1,zs.2)
    xs.3 <- cbind(x,zs.1,zs.2,zs.3)

    xt.1 <- cbind(x,zt.1)
    xt.2 <- cbind(x,zt.1,zt.2)
    xt.3 <- cbind(x,zt.1,zt.2,zt.3)

    xs.1 <- xs.1[,!duplicated(t(xs.1))]
    xs.2 <- xs.2[,!duplicated(t(xs.2))]
    xs.3 <- xs.3[,!duplicated(t(xs.3))]

    xt.1 <- xt.1[,!duplicated(t(xt.1))]
    xt.2 <- xt.2[,!duplicated(t(xt.2))]
    xt.3 <- xt.3[,!duplicated(t(xt.3))]

    reg.0 <- lm(y~x.0-1)

    regs.1 <- lm(y~xs.1-1)
    regs.2 <- lm(y~xs.2-1)
    regs.3 <- lm(y~xs.3-1)

    regt.1 <- lm(y~xt.1-1)
    regt.2 <- lm(y~xt.2-1)
    regt.3 <- lm(y~xt.3-1)

    ps.n <- round(anova(regs.3,reg.0)[2,6],4)
    ps.3 <- round(anova(regs.3,regs.2)[2,6],4)
    ps.2 <- round(anova(regs.2,regs.1)[2,6],4)
    ps.1 <- round(anova(regs.1,reg.0)[2,6],4)

    pt.n <- round(anova(regt.3,reg.0)[2,6],4)
    pt.3 <- round(anova(regt.3,regt.2)[2,6],4)
    pt.2 <- round(anova(regt.2,regt.1)[2,6],4)
    pt.1 <- round(anova(regt.1,reg.0)[2,6],4)

    nl.out[i,] <- c(ps.n,ps.3,ps.2,ps.1)
    sc.out <- matrix(c(pt.n,pt.3,pt.2,pt.1),1,4)

  }

  rownames(nl.out) <- colnames(tv.mat)
  rownames(sc.out) <- 't*'

  # if(contemp == FALSE){
  #   nl.out <- nl.out[-1,]
  # }

  if(ascending == TRUE){
    if(ncol(tv.mat)!=0){
      nl.out <- nl.out[order(nl.out[,1]),]
    }
  }

  nl.rows <- min(ncol(tv.mat),nrow(nl.out))

  if(nl.rows==1){
    nl.out <- matrix(nl.out,1,4)
    rownames(nl.out) <- colnames(tv.mat)
  }

  nl.lab <- matrix(NA,nl.rows,1)
  for(k in 1:nl.rows){
    if(nl.out[k,1] >= crit){
      nl.lab[k,] <- paste('')
    }else if(((nl.out[k,2] < crit) | (nl.out[k,4] < crit)) & (nl.out[k,3] < crit)){
      nl.lab[k,] <- paste('b')
    }else if(((nl.out[k,2] == min(nl.out[k,2:4])) & (nl.out[k,2] < crit)) | ((nl.out[k,4] == min(nl.out[k,2:4])) & (nl.out[k,4] < crit))){
      nl.lab[k,] <- paste('l')
    }else if((nl.out[k,3] == min(nl.out[k,2:4])) & (nl.out[k,3] < crit)){
      nl.lab[k,] <- paste('e')
    }else{
      nl.lab[k,] <- paste('')
    }
  }

  if(sc.out[,1] >= crit){
    sc.lab <- paste('')
  }else if(((sc.out[,2] == min(sc.out[,2:4])) & (sc.out[,2] < crit)) | ((sc.out[,4] == min(sc.out[,2:4])) & (sc.out[,4] < crit))){
    sc.lab <- paste('l')
  }else if((sc.out[,3] == min(sc.out[,2:4])) & (sc.out[,3] < crit)){
    sc.lab <- paste('e')
  }else{
    sc.lab <- paste('')
  }

  nl.out <- formatC(nl.out,format="e",digits=3)
  sc.out <- formatC(sc.out,format="e",digits=3)

  nl.mat <- as.data.frame(cbind(nl.out,nl.lab),stringsAsFactors=F)
  sc.mat <- as.data.frame(cbind(sc.out,sc.lab),stringsAsFactors=F)

  colnames(nl.mat) <- c('p.0','p.3','p.2','p.1','MODEL')
  colnames(sc.mat) <- c('p.0','p.3','p.2','p.1','MODEL')

  res.list <- return(list(star=nl.mat,tvar=sc.mat,ac=ac.vec,arch=arch.vec))
}


library(shiny)
library(knitr)
library(ggplot2)
library(scales)
library(Matrix)
source("./util.R")

shinyServer(function(input, output) {

  observeEvent(input$text,{

    output$distPlot <- renderPlot({
        input_list <- ShinnyInput(exp = exp, tsne = tsne,
                                  Dataset1 = input$Dataset1)
        exp_dat = input_list$exp
        coord_dat = input_list$tsne

      ### if there is an update of gene name then do the following below

      if(input$update) {
        ## Printing the Error statement if the gene name is not present
        validate(
          need(input$text %in% row.names(exp_dat), 'Error: the requested gene was not detected in any cell!')
        )

        gene_exp_coordinates <- PrepareExpTsne(exp_dat=exp_dat, coord_dat=coord_dat, input=input)
      ## Create a table for printing out values in Plot 1 in the below section
      gene_exp_coordinates_sub=gene_exp_coordinates[,c("x","y","Sample","gene")]
      colnames(gene_exp_coordinates_sub)=c("tSNE_1","tSNE_2","Sample",input$text)
      rownames(gene_exp_coordinates_sub)=gene_exp_coordinates_sub[,c("Sample")]
      gene_exp_coordinates_sub=gene_exp_coordinates_sub[,-3]

        output$info3 <- renderPrint({
        # With base graphics, need to tell it what the x and y variables are.
        nearPoints(gene_exp_coordinates_sub, input$plot_click,xvar="tSNE_1",yvar="tSNE_2")
        nearPoints(gene_exp_coordinates_sub, input$plot_hover,xvar="tSNE_1",yvar="tSNE_2")
        # nearPoints() also works with hover and dblclick events
      })
    ######################
        g <- Shinnyplot(data = gene_exp_coordinates, input = input)
        ChangeColorScale(g, alpha.use = 1,
                        scaled.expression.threshold = as.numeric(input$threshold),
                        gradient.use = c("grey", input$Color1))
      }
      ### Default view of the plot is there in else statement

      else {
        ## Create a table for printing out values in Plot 1 in the below section
        output$info <- renderText({
          xy_str <- function(e) {
            if(is.null(e)) return("NULL\n")
            paste0("x=", round(e$x, 1), " y=", round(e$y, 1)," Sample=", e$z, "\n")
          }
          paste0(
            "click: ", xy_str(input$plot_click),
            "dblclick: ", xy_str(input$plot_dblclick),
            "hover: ", xy_str(input$plot_hover)
          )
        })

        output$info3 <- renderPrint({
          # With base graphics, need to tell it what the x and y variables are.
          nearPoints(coord_dat, input$plot_click,xvar="tSNE_1",yvar="tSNE_2")
          nearPoints(coord_dat, input$plot_hover,xvar="tSNE_1",yvar="tSNE_2")
          # nearPoints() also works with hover and dblclick events
        })
        gene_exp_coordinates = as.data.frame(tsne[samples[1]])
        colnames(gene_exp_coordinates) = c("x","y")
        gene_exp_coordinates$gene = 1
        g <- Shinnyplot(data = gene_exp_coordinates, input = input)
        ChangeColorScale(g, alpha.use = 1,
                         scaled.expression.threshold = as.numeric(input$threshold),
                         gradient.use = c("grey", input$Color1))
      } ### end of else
      ##until here

    }) ### end of render Plot

    ###write the function plot for downloading the figure ###
    plotfunc <- function(){
      if(input$update) {
        input_list <- ShinnyInput(exp = exp, tsne = tsne,
                            Dataset1 = input$Dataset1)
        exp_dat = input_list$exp
        coord_dat = input_list$tsne

        gene_exp_coordinates <- PrepareExpTsne(exp_dat=exp_dat, coord_dat=coord_dat, input=input)
        g <- Shinnyplot(data = gene_exp_coordinates, input = input)
        ChangeColorScale(g, alpha.use = 1,
                         scaled.expression.threshold = as.numeric(input$threshold),
                         gradient.use = c("grey", input$Color1))
      }
      ### Default view of the pot is there in else statement
      else {
            input_list <- ShinnyInput(exp = exp, tsne = tsne,
                                    Dataset1 = input$Dataset1)
            coord_dat = as.data.frame(input_list$tsne)
            colnames(coord_dat) =c("x","y")
            coord_dat$gene = 1
            Shinnyplot(data = coord_dat, input = input)
      }
    }
    ### Download plot ###

    output$downloadplot <- downloadHandler(
      filename = function() { paste('Plot', '.png') },
      content = function(file) {
        png(file, units="in", width=10, height=7,res=600)
        print(plotfunc())
        dev.off()
      })
  })
})


install.packages(c("zoo", "sandwich", "MASS", "quadprog", "tseries", "strucchange", "fracdiff", "forecast", "iterators", "codetools", "foreach", "bfast", "mailR", "parallel"), repos="https://rweb.crmda.ku.edu/cran/")

library(zoo)
library(sandwich)
library(MASS)
library(quadprog)
library(tseries)
library(strucchange)
library(fracdiff)
library(forecast)
library(iterators)
library(codetools)
library(foreach)
library(bfast)
library(mailR)
library(parallel)


#===============================================================================
#  File:    02-choosing-number-topics.R
#  Date:    May 3, 2019
#  Paper:   Who Leads? Who Follows? Measuring Issue Attention and Agenda Setting
#           by Legislators and the Mass Public Using Social Media Data
#  Journal: American Political Science Review
#  Authors: Pablo Barbera, Andreu Casas, Jonathan Nagler, Patrick J. Egan,
#           Richard Bonneau, John Jost, Joshua A. Tucker
#  Purpose: run multiple LDA models to choose number of topics based on
#           logLikelihood and perplexity
#  Data In:
#           ./data/tweets/text/* & data/dfm/congress-*
#  Data Out:
#           appendix figure with cross-validated model fit
#===============================================================================

# PACKAGES
#===============================================================================
library(slam)
library(Matrix)
library(tm)
library(topicmodels)
library(cvTools)
library(reshape)
library(ggplot2)
library(grid)

# DATA
#===============================================================================
## preparing Congress matrix
fls <- scan("data/dfm/fls-list.txt", what="character", sep="\n")
ind <- scan("data/dfm/congress-dtm-indices.txt")
pointers <- scan("data/dfm/congress-dtm-pointers.txt")
values <- scan("data/dfm/congress-dtm-values.txt")
words <- scan("data/dfm/congress-words.txt", what="character", sep="\n")

X <- sparseMatrix(j=ind, p=pointers, x=values,
	dims=c(length(fls), length(words)), index1=FALSE)
dimnames(X)[[2]] <- words

mat <- as.simple_triplet_matrix(X)
dtm <- as.DocumentTermMatrix(mat, weighting=function(x) weightTf(x))

# FUNCTIONS
#===============================================================================
# cross-validated LDA
cvLDA <- function(Ntopics,dtm,K=10) {
  folds<-cvFolds(nrow(dtm),K,1)
  perplex <- rep(NA,K)
  llk <- rep(NA,K)
  for(i in unique(folds$which)){
    cat(i, " ")
    which.test <- folds$subsets[folds$which==i]
    which.train <- {1:nrow(dtm)}[-which.test]
    dtm.train <- dtm[which.train,]
    dtm.test <- dtm[which.test,]
    lda.fit <- LDA(dtm.train, k=Ntopics, method="Gibbs",
                   control=list(verbose=50L, iter=100))
    perplex[i] <- perplexity(lda.fit,dtm.test)
    llk[i] <- logLik(lda.fit)
  }
  return(list(K=Ntopics,perplexity=perplex,logLik=llk))
}

# MAIN
#===============================================================================

## running LDA with different number of topics
K <- c(10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130)
results <- list()
i = 1
for (k in K){
    cat("\n\n\n##########\n\n\n ", k, "topics", "\n\n\n")
    res <- cvLDA(k, dtm)
    results[[i]] <- res
    save(results, file="topics/k_topics_results_cv.Rdata")
    i = i + 1
}

save(results, file="topics/k_topics_results_cv.Rdata")

# PLOT
#===============================================================================
df <- data.frame(
    k = rep(K, each=10),
    perp =  unlist(lapply(results, '[[', 'perplexity')),
    loglk = unlist(lapply(results, '[[', 'logLik')),
    stringsAsFactors=F)
min(df$perp)
df$ratio_perp <- df$perp / max(df$perp)
df$ratio_lk <- df$loglk / min(df$loglk)
df <- data.frame(cbind(
    aggregate(df$ratio_perp, by=list(df$k), FUN=mean),
    aggregate(df$ratio_perp, by=list(df$k), FUN=sd)$x,
    aggregate(df$ratio_lk, by=list(df$k), FUN=mean)$x,
    aggregate(df$ratio_lk, by=list(df$k), FUN=sd)$x),
    stringsAsFactors=F)
names(df) <- c("k", "ratio_perp", "sd_perp", "ratio_lk", "sd_lk")

pd <- melt(df[,c("k","ratio_perp", "ratio_lk")], id.vars="k")
pd2 <- melt(df[,c("k","sd_perp", "sd_lk")], id.vars="k")
pd$sd <- pd2$value
levels(pd$variable) <- c("Perplexity", "LogLikelihood")

p <- ggplot(pd, aes(x=k, y=value, linetype=variable))
pq <- p + geom_line() + geom_point(aes(shape=variable),
        fill="white", shape=21, size=1.40) +
    geom_errorbar(aes(ymax=value+sd, ymin=value-sd), width=4) +
    scale_y_continuous("Ratio wrt worst value") +
    scale_x_continuous("Number of topics",
        breaks=c(10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120)) +
    theme_bw() +
    scale_shape_discrete(guide="none") +
    scale_linetype_discrete(guide="none") +
        theme(axis.line = element_line(colour = "black"),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    panel.border = element_blank(),
    panel.background = element_blank(),
    legend.key.size=unit(0.5, "cm"), legend.position=c(0.70,.90),
    legend.box.just = "left", legend.direction="horizontal",
    legend.title=element_blank()) +
        annotate("text", x=100, y=0.86, label="Perplexity", size=3) +
        annotate("text", x=100, y=0.945, label="logLikelihood", size=3)
pq

ggsave("plots/appendix-choosing-k.pdf", pq, height=4, width=6)


context("Test WSS")

# Create data
n <- 150 #size of dataset
nyr <- 20 # number of years in data
nSamples <- 20 # set number of dates
set.seed(seed = 125)

# Create somes dates
first <- as.POSIXct(strptime("2003/01/01", "%Y/%m/%d"))
last <- as.POSIXct(strptime(paste(2003+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
dt <- last-first
rDates <- first + (runif(nSamples)*dt)

# taxa are set as random letters
taxa <- sample(letters, size = n, TRUE)

# three sites are visited randomly
site <- sample(c('one', 'two', 'three'), size = n, TRUE)

# the date of visit is selected at random from those created earlier
time_period <- sample(rDates, size = n, TRUE)

# combine this to a dataframe
df <- unique(data.frame(taxa, site, time_period))

test_that("Test WSS2", {

  set.seed(seed = 125)
  suppressWarnings(results <- WSS(df$taxa,
                 df$site,
                 df$time_period,
                 minL = 4,
                 minTP = 3))

  expect_is(results, 'data.frame')
  expect_equal(colnames(results),
               c("species_name", "intercept.estimate", "year.estimate", "intercept.stderror",

                 "year.stderror", "intercept.zvalue", "year.zvalue", "intercept.pvalue",
                 "year.pvalue", "observations"))
  expect_equal(nrow(results), 25)

})


#Start off by loading up some of the libraries that might be useful
#Manipulation
library(tidyr)
library(dplyr)
#Modeling
library(rpart)
library(randomForest)
library(rattle)
library(car)
library(caret)
library(e1071)
library(C50)
library(RWeka)
#Visualization
library(rpart.plot)
library(RColorBrewer)
library(ggplot2)
library(reshape2)

#import the train and test datasets from the directory

#import the test data from the file name test_orig
newtest <- test_orig
#insert a blank column to hold future values for Survived
newtest$Survived <- ""
#combine test and train into one dataset
titanicData <- rbind(train_orig,newtest)
#check out what the total dataset looks like now
str(titanicData)
View(titanicData)
#refactor the features Survived and Pclass into factors
titanicData$Survived <- as.factor(titanicData$Survived)
titanicData$Pclass <- as.factor(titanicData$Pclass)
#verify the changes
str(titanicData)

#Add some new features to the dataset for future use

#the first is to create a new feature called family_size to account for the family size of each passenger
  #wherein the famil is the number of siblings and spouses, parents and children, and the individual
titanicData$family_size <- titanicData$SibSp + titanicData$Parch + 1

#Next, add a feature to account for the passengers title.  There are several passengers that are the only
  #ones with individual titles.  This presents a problem for classification algorithms.
titanicData$Title <- sub(pattern = ".*,\\s(.*\\.)\\s.*", replacement = "\\1", x = titanicData$Name)
titanicData$Title[titanicData$Title %in% c("Don.", "Dona.", "the Countess.")] <- "Lady."
titanicData$Title[titanicData$Title %in% c("Ms.", "Mlle.")] <- "Miss."
titanicData$Title[titanicData$Title %in% c("Mme.", "Mrs. Martin (Elizabeth L.")] <- "Mrs."
titanicData$Title[titanicData$Title %in% c("Jonkheer.", "Don.")] <- "Sir."
titanicData$Title[titanicData$Title %in% c("Col.", "Capt.", "Major.")] <- "Officer."
titanicData$Title <- factor(titanicData$Title)

ggplot(titanicData[1:891,], aes(x=family_size, fill=Survived)) +
  geom_histogram(binwidth = 1) +
  facet_wrap(~Pclass + Title) +
  ggtitle("Pclass, Title") +
  xlab("family size") +
  ylab("Total count") +
  ylim(0,300) +
  labs(fill = "Survived")

#Check for NA values in each feature of the dataset
table(is.na(titanicData$PassengerId))
table(is.na(titanicData$Survived))
table(is.na(titanicData$Pclass))
table(is.na(titanicData$Name))
table(is.na(titanicData$Sex))
table(is.na(titanicData$Age)) #NAs found
table(is.na(titanicData$SibSp))
table(is.na(titanicData$Parch))
table(is.na(titanicData$Ticket))
table(is.na(titanicData$Fare)) #NAs found
table(is.na(titanicData$Cabin))
table(is.na(titanicData$Embarked))
table(is.na(titanicData$family_size))
table(is.na(titanicData$Title))

#So Age has some NA values in the feature vector.  One cannot exactly not have an age, so let's impute
  #these missing values by predicting them based on values we know
predicted_age <- rpart(Age ~ Pclass
                       + Sex
                       + SibSp
                       + Parch
                       + Fare
                       + Embarked
                       + Title #new
                       + family_size #new
                       , data = titanicData[!is.na(titanicData$Age),]
                       , method = "anova")
titanicData$Age[is.na(titanicData$Age)] <- predict(predicted_age, titanicData[is.na(titanicData$Age),])

#Fare also has some NA values in the feature vector.  This is not helpful for solving the problem, so
  #impute these missing variables as well using the median value (not the average) of the non-normal distribution
titanicData$Fare[is.na(titanicData$Fare)==TRUE] <- median(titanicData$Fare,na.rm=TRUE)

#In the dataset, two passengers do not have an embarked location.  They had to come from somewhere, assuming
  #they did not spawn from the ocean itself.  Because most passengers embarked from "S," let's say these two
  #did as well
titanicData$Embarked[c(62, 830)] <- "S"
titanicData$Embarked <- factor(titanicData$Embarked)

#Now add some new features to practice feature engineering and to see what may or may not be helpful
  #These are all be binomials that might help us with our classification
titanicData$Child[titanicData$Age>=18] <- 0
titanicData$Child[titanicData$Age<18] <- 1

titanicData$Elder[titanicData$Age>=55] <- 1
titanicData$Elder[titanicData$Age<55] <- 0

titanicData$HighFare[titanicData$Fare>=200] <- 1
titanicData$HighFare[titanicData$Fare<200] <- 0

titanicData$LowFare[titanicData$Fare<=8] <- 1
titanicData$LowFare[titanicData$Fare>8] <- 0

#The group of features below are categorical in nature and polynomial
titanicData$TicketAB<-substring(titanicData$Ticket,1,1)
titanicData$TicketAB<-factor(titanicData$TicketAB)

titanicData$FamCat[titanicData$family_size == 1] <- 0
titanicData$FamCat[titanicData$family_size < 5 & titanicData$family_size > 1] <- 1
titanicData$FamCat[titanicData$family_size > 4] <- 2

titanicData$AgeGrp[titanicData$Age <= 10] <- 1
titanicData$AgeGrp[titanicData$Age > 10 & titanicData$Age <= 19] <- 2
titanicData$AgeGrp[titanicData$Age > 19 & titanicData$Age <=50] <- 3
titanicData$AgeGrp[titanicData$Age > 50] <- 4

titanicData$FareGrp[titanicData$Fare <=10] <- 1
titanicData$FareGrp[titanicData$Fare >10 & titanicData$Fare <=50] <- 2
titanicData$FareGrp[titanicData$Fare >50 & titanicData$Fare <=100] <- 3
titanicData$FareGrp[titanicData$Fare >100] <- 4

#Look at the Cabin feature
str(titanicData$Cabin)
table(titanicData$Cabin)
#This beast has 187 levels, which can lower the performance of classification algorithms
titanicData$Cabin <- as.character(titanicData$Cabin)
titanicData$Cabin[is.na(titanicData$Cabin)] <- "U"
titanicData$Cabin[titanicData$Cabin==""] <- "U"
titanicData$Cab<-substring(titanicData$Cabin,1,1)
titanicData$Cab<-factor(titanicData$Cab)
titanicData$Cabin<-factor(titanicData$Cabin)
#Our new feature, Cab, has only 9 levels and still represents most of the information from
  #the Cabin feature vector
str(titanicData$Cab)

#Add some categorical features to group families into types by their size
titanicData$FamType[titanicData$family_size == 1] <- 'single'
titanicData$FamType[titanicData$family_size < 5 & titanicData$family_size > 1] <- 'small'
titanicData$FamType[titanicData$family_size > 4] <- 'large'
titanicData$FamType<-factor(titanicData$FamType)

#Some passengers are actually registered to multiple cabins.  This can be related to a passengers
  #socioeconomic status which can affect survivability
titanicData$MultiCab <- as.factor(ifelse(str_detect(titanicData$Cabin, " "), "Y", "N"))

#The features for Fare and Age have values that are outliers and values that disturb the distribution
  #so create two new features that are normalized representations of both
  #probably will not use them, but making them anyway for now
titanicData$FareNorm <- data.Normalization(titanicData$Fare, type="n1",normalization="column")
titanicData$AgeNorm <- data.Normalization(titanicData$Age, type="n12",normalization="column")

#Check on the structure of the dataset now
str(titanicData)
#Refactor some of the new features
titanicData$Child<-factor(titanicData$Child)
titanicData$Elder<-factor(titanicData$Elder)
titanicData$HighFare<-factor(titanicData$HighFare)
titanicData$LowFare<-factor(titanicData$LowFare)
titanicData$FamCat<-factor(titanicData$FamCat)
titanicData$AgeGrp<-factor(titanicData$AgeGrp)
titanicData$FareGrp<-factor(titanicData$FareGrp)
#Transform some of the others from num to int
titanicData$Age <- as.integer(titanicData$Age)
titanicData$family_size <- as.integer(titanicData$family_size)

#Now split the data back into training and test sets
train <- titanicData[1:891,]
train$Survived <- factor(train$Survived)
str(train)

test <- titanicData[892:1309,]
test$Survived <- factor(test$Survived)
str(test)

#Set seed for reproducibility
set.seed(1)

#First trying the random forest algorithm with cross validation
estPerformance <- c(0,0,0,0,0,0,0,0,0,0)
for(h in 1:10){
  #For each of the ten
  accs<-c(0,0,0,0)
  n <- nrow(train)
  shuffled <- train[sample(n),]
  for (i in 1:4) {
    indices <- (((i-1) * round((1/4)*nrow(shuffled))) + 1):((i*round((1/4) * nrow(shuffled))))

    # Exclude them from the train set
    train2 <- shuffled[-indices,]

    # Include them in the test set
    test2 <- shuffled[indices,]

    m <- randomForest(as.factor(Survived) ~ Title +
                        Sex + #
                        Age + #
                        TicketAB + #
                        Pclass+
                        family_size+
                        FareGrp #+ #
                        ,ntree=1500, data=train,importance=TRUE)

    #Make a prediction on the test set using tree
    pred <- predict(m, test2, type="class")

    #Assign the confusion matrix to conf
    conf<-table(test2$Survived,pred)

    #Assign the accuracy of this model to the ith index in accs
    accs[i]<-sum(diag(conf))/sum(conf)
  }
  estPerformance[h] <- mean(accs)
}
#Check out the confusion matrix
conf
#Have a look at the different features used and their performance power
varImpPlot(m)
#Check out the average of all of the folded results using this model and ensuring the records
#are shuffled prior to each evaluation
mean(estPerformance)
#The random forest performance averages around .892
#Create predictions based on the model above
myPrediction <- predict(m, test)
#Generate the solution file for the competition
mySolution <- data.frame(PassengerID=test$PassengerId, Survived=myPrediction)
write.csv(mySolution,file="my_solution(rForest).csv", row.names=FALSE)

#Now trying a J48 classification tree from Weka
m <- J48(as.factor(Survived) ~ Title
         +Sex
         +Age
         +TicketAB
         +Pclass
         +family_size
         +FareGrp
         ,data=train)
#Use the built-in evaluation methods to analyze the performance of the J48
e <- evaluate_Weka_classifier(m,cost = matrix(c(0,2,1,0), ncol = 2),
                              numFolds = 10, complexity = TRUE, #newdata=test,
                              seed = 123, class = TRUE)
#View the summary of the performance results
e$details
#Even though it is still looking at the training set, the performance is around 83%, which is a
  #pretty good sign

#Now use some cross validation to further test the performance of the J48 model
estPerformance <- c(0,0,0,0,0,0,0,0,0,0)
for(h in 1:10){
  #For each of the ten
  accs<-c(0,0,0,0)
  n <- nrow(train)
  shuffled <- train[sample(n),]
  for (i in 1:4) {
    indices <- (((i-1) * round((1/4)*nrow(shuffled))) + 1):((i*round((1/4) * nrow(shuffled))))

    # Exclude them from the train set
    train2 <- shuffled[-indices,]

    # Include them in the test set
    test2 <- shuffled[indices,]

    m <- J48(as.factor(Survived) ~ Title
             +Age
             +TicketAB
             +FamType
             +Fare
             +Sex
             +Pclass
             +Cab
             +FamCat
             +family_size
             +MultiCab
             ,train)

    #Make a prediction on the test set using tree
    pred <- predict(m, test2, type="class")

    #Assign the confusion matrix to conf
    conf<-table(test2$Survived,pred)

    #Assign the accuracy of this model to the ith index in accs
    accs[i]<-sum(diag(conf))/sum(conf)
  }
  estPerformance[h] <- mean(accs)
}
#Check out the confusion matrix
conf
#Check out the average of all of the folded results using this model and ensuring the records
  #are shuffled prior to each evaluation
mean(estPerformance)
#Performance average hovers around .866, which seems good enough to make a submission to the contest
#Use the built-in evaluation methods to analyze the performance of the J48
e <- evaluate_Weka_classifier(m,cost = matrix(c(0,2,1,0), ncol = 2),
                              numFolds = 10, complexity = TRUE,
                              seed = 123, class = TRUE)
#View the summary of the performance results
e$details
#The built-in performance measurement gives the model around .829, which is still okay
#Create predictions based on the model above
myPrediction <- predict(m, test)
#Generate the solution file
mySolution <- data.frame(PassengerID=test$PassengerId, Survived=myPrediction)
write.csv(my_solution,file="my_solution(J48).csv", row.names=FALSE)


library(sf)
library(purrr)
library(ggplot2)

ozbig <- read_sf("data/gadm36_AUS_shp/gadm36_AUS_1.shp")
oz <- thin(ozbig)

llg_fun <- function(y) {
  data <- data.frame(long = y[, 1],
                     lat  = y[, 2],
                     groups = rep(1,length(y)))
}

matrix <- oz$geometry %>% flatten() %>% flatten()

ozplus <- matrix %>% purrr::map_df(.x = ., .id ="group", .f = llg_fun)

ozplus %>% ggplot(aes(x = long, y = lat, group = group)) + geom_polygon()


# experiments nv4test-alllocus (all locus copying) vs. evtest4m (random locus copying) at 4MM steps rather than 1MM steps
# otherwise all priors and parameters the same.

library(dplyr)
library(mmadsenr)
library(ggplot2)

# look at richness per locus first
evtest4m.rich <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/simulations/excessvariation-nonstationary-test/evtest4m-pop-richness-locus-data.csv")
nv4test.rich <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/simulations/excessvariation-nonstationary-test/nv4test-alllocus-pop-richness-locus-data.csv")
nv8test.rich <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/simulations/excessvariation-nonstationary-test/nv8test-alllocus-pop-richness-locus-data.csv")
nv8test.rand.rich <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/simulations/excessvariation-nonstationary-test/nv8test-randlocus-pop-richness-locus-data.csv")
nv1test.rich <- read.csv("~/Dropbox/Research/projects/coarsegraining/experiment-ctmixtures/simulations/excessvariation-nonstationary-test/nv1test-alllocus-pop-richness-locus-data.csv")

# pull in the 1MM richness data from equifinality-2-small for comparison
# pull in the per-locus richness data, this can be compared to Ewens 1972, equation 4
eq2s.rich <- read.csv(file="~/local-research/diss/experiments/experiment-ctmixtures/eq2s-pop-richness-locus-data.csv")
eq2s.rich.neutral <- filter(eq2s.rich, model_class_label == 'allneutral')

# mark the experiment with a label

nv1test.rich$exp <- 'allloci-1mm'
nv4test.rich$exp <- 'allloci-4mm'
nv8test.rich$exp <- 'allloci-8mm'

eq2s.rich.neutral$exp <- 'randomlocus-1mm'
evtest4m.rich$exp <- 'randomlocus-4mm'
nv8test.rand.rich$exp <- 'randomlocus-8mm'

# now, take a random sample of the 1MM richness data, so we have equal samples
# there are 4K samples, we want 100, so we want 0.025 as the sample fraction
eq2s.split <- random_split_dataset(eq2s.rich.neutral, 0.025)

# combine these into one dataset
combined.rich <- rbind(evtest4m.rich, nv4test.rich, nv8test.rich, eq2s.split$test, nv8test.rand.rich, nv1test.rich)

popsize <- 100
innov_rates_for_abline <- c(0.1, 0.5, 1.0, 2.0, 3.0, 4.0, 5.0)
# expected K for innovation rates
expected_k <- numeric(length(innov_rates_for_abline))
for (i in 1:length(innov_rates_for_abline)) { expected_k[i] <- expected_k_pop(popsize, innov_rates_for_abline[i])}
expected_k_abline <- data.frame(innov_rates_for_abline, expected_k)

plt <- ggplot(data=combined.rich, aes(x=innovation_rate, y=richness_locus_value, color=factor(exp))) + stat_smooth(method="lm") + geom_point()
plt + geom_abline(data=expected_k_abline, color="black")
ggsave("figure/combined-excess-richness.png")


pdf_file<-"pdf/maps_germany_choropleth_counties_1x2.pdf"
cairo_pdf(bg="grey98", pdf_file,width=15,height=8)

par(omi=c(0.5,0,0,0), mai=c(0,6,1,1),family="Lato Light",las=1)
library(maptools)
library(RColorBrewer)
library(gdata)

myC0<-rgb(0,0,0,0,maxColorValue=255)
myC1a<-rgb(68,90,111,50,maxColorValue=255)
myC1b<-rgb(68,90,111,150,maxColorValue=255)
myC1c<-rgb(68,90,111,250,maxColorValue=255)
myC2a<-rgb(255,97,0,50,maxColorValue=255)
myC2b<-rgb(255,97,0,150,maxColorValue=255)
myC2c<-rgb(255,97,0,250,maxColorValue=255)

# first the right map

x<-readShapeSpatial("myData/VG250_Kreise_Shapefile_UTM32_VZ_2011.shp")
myDistrict_structure_data<-read.xls("myData/konfession_vz_2011.xls",sheet=1, encoding="latin1")
n<-length(x)
myNo<-as.numeric(as.character(x$RS))
position<-vector()
for (i in 1:n){
	position[i]<-match(myNo[i], myDistrict_structure_data$AGS)
}
myColour_no<-cut(100*myDistrict_structure_data$RKAT[position]/ myDistrict_structure_data$BEV[position],c(0,50,70,90,100))
myColourPalette<-c(myC0,myC1a,myC1b,myC1c)
plot(x,col=myColourPalette[myColour_no],border=grey(.8),lwd=.3)

myColour_no<-cut(100*myDistrict_structure_data$EVANG[position]/ myDistrict_structure_data$BEV[position],c(0,50,70,90,100))
myColourPalette<-c(myC0,myC2a,myC2b,myC2c)
plot(x,col=myColourPalette[myColour_no],border=grey(.8),lwd=.3,add=T)

# then the left map

par(mai=c(0,0,0,7),plt=c(0,0.5,0,0.95),new=T)
x<-readShapeSpatial("myData/OGP86/SDE2_GERMAN1895ELECTORALDISTRICTS.shp")
myDistrict_structure_data<-read.xls("myData/ZA8145_1912.xlsx",sheet=1, encoding="latin1")
n<-length(x)
myNo<-x$DISTRICT_N
position<-vector()
for (i in 1:n){
	position[i]<-match(myNo[i], myDistrict_structure_data$wkr_nr)
}
myColour_no<-cut(myDistrict_structure_data$kat05p[position],c(0,50,70,90,100))
myColourPalette<-c(myC0,myC1a,myC1b,myC1c)
plot(x,col=myColourPalette[myColour_no],border=grey(.8),lwd=.3,xpd=T)

myColour_no<-cut(myDistrict_structure_data$ev05p[position], c(0,50,70,90,100))
myColourPalette<-c(myC0,myC2a,myC2b,myC2c)
plot(x,col=myColourPalette[myColour_no],border=grey(.8),lwd=.3,add=T,xpd=T)

# Titling

mtext("Protestant and Catholic counties 1905... ",3,line=-2.75,adj=0.05,family="Lato Black",outer=T,cex=2,xpd=T)
mtext("... and 2011",3,line=-2.75,adj=0.65,family="Lato Black",outer=T,cex=2,xpd=T)
mtext("map 1905: geodata.tutfts.edu (goo.gl/Lq3QU); data 1905: Schmädeke (GESIS: doi:10.4232/1.1845);map 2011: www.zensus2011.de; data 2011: destatis.de",1,line=-0.7,adj=0.04,cex=0.95,font=3,outer=T,xpd=T)

# Lastly, the bar charts as legend

par(mai=c(0.75,5,5.5,9),fg="white",new=T)
myDistrict_structure_data<-read.xls("myData/ZA8145_1912.xlsx",sheet=1, encoding="latin1")

protestant<-myDistrict_structure_data[myDistrict_structure_data$ev05p>50,]
attach(protestant)
myClasses<-c(50,70,90,100)
levels(myClasses)<-c("50 to 70 %","70 to 90 %","over 90  %")
barplot(table(cut(ev05p,myClasses)),col=myColourPalette<-c(myC2a,myC2b,myC2c),xlim=c(-150,150),names.arg=levels(myClasses),main="",cex.axis=0.75,cex.names=0.75,cex.main=0.75,col.axis="black",col.main="red",horiz=T)
text(130,4.5,"Protestant",pos=1,col="black",xpd=T,cex=1)

catholic<-myDistrict_structure_data[myDistrict_structure_data$kat05p>50,]
attach(catholic)
myClasses<-c(50,70,90,100)
levels(myClasses)<-c("50 to 70 %","70 to 90 %","over 90  %")
barplot(-table(cut(kat05p,myClasses)),col=myColourPalette<-c(myC1a,myC1b,myC1c),names.arg=levels(myClasses),main="",cex.axis=0.75,cex.names=0.75,cex.main=0.75,col.axis="black",col.main="red",horiz=T,add=T)
text(-120,4.5,"Catholic",pos=1,col="black",xpd=T,cex=1)

par(mai=c(0.75,13,5.5,1),fg="white",new=T)
myDistrict_structure_data<-read.xls("myData/konfession_vz_2011.xlsx",sheet=1)

protestant<-myDistrict_structure_data[myDistrict_structure_data$PEVANG>50,]
attach(protestant)
myClasses<-c(50,70,90,100)
levels(myClasses)<-c("50 to 70 %","70 to 90 %","over 90  %")
barplot(table(cut(PEVANG,myClasses)),col=myColourPalette<-c(myC2a,myC2b,myC2c),xlim=c(-150,150),names.arg=levels(myClasses),main="",cex.axis=0.75,cex.names=0.75,cex.main=0.75,col.axis="black",col.main="red",horiz=T)
text(130,4.5,"Protestant",pos=1,col="black",xpd=T,cex=1)

catholic<-myDistrict_structure_data[myDistrict_structure_data$PRKAT>50,]
attach(catholic)
myClasses<-c(50,70,90,100)
levels(myClasses)<-c("50 to 70 %","70 to 90 %","over 90  %")
barplot(-table(cut(PRKAT,myClasses)),col=myColourPalette<-c(myC1a,myC1b,myC1c),names.arg=levels(myClasses),main="",cex.axis=0.75,cex.names=0.75,cex.main=0.75,col.axis="black",col.main="red",horiz=T,add=T)
text(-120,4.5,"Catholic",pos=1,col="black",xpd=T,cex=1)
dev.off()


#' heat_index
#'
#' Calculate the heat index following NOAA scheme.
#'
#' @param numeric t Air temperature in Celsius Degrees.
#' @param numeric rh Air Relative humidity .
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  NOAA heat index
#' @references NOAA index from George Winterling based on SteadMan's work.
#'
#' @export

heat_index <- function(t, rh) {
    .Call('biometeoR_heatindex', PACKAGE = 'biometeoR', t, rh)
}


# Prediction data frame
# Get predictions with standard errors into data frame
#
# @keyword internal
# @alias predictdf.default
# @alias predictdf.glm
# @alias predictdf.loess
# @alias predictdf.locfit
predictdf <- function(model, xseq, se, level) UseMethod("predictdf")

#' @export
predictdf.default <- function(model, xseq, se, level) {
  pred <- stats::predict(model, newdata = new_data_frame(list(x = xseq)), se.fit = se,
    level = level, interval = if (se) "confidence" else "none")

  if (se) {
    fit <- as.data.frame(pred$fit)
    names(fit) <- c("y", "ymin", "ymax")
    base::data.frame(x = xseq, fit, se = pred$se.fit)
  } else {
    base::data.frame(x = xseq, y = as.vector(pred))
  }
}

#' @export
predictdf.glm <- function(model, xseq, se, level) {
  pred <- stats::predict(model, newdata = data_frame(x = xseq), se.fit = se,
    type = "link")

  if (se) {
    std <- stats::qnorm(level / 2 + 0.5)
    base::data.frame(
      x = xseq,
      y = model$family$linkinv(as.vector(pred$fit)),
      ymin = model$family$linkinv(as.vector(pred$fit - std * pred$se.fit)),
      ymax = model$family$linkinv(as.vector(pred$fit + std * pred$se.fit)),
      se = as.vector(pred$se.fit)
    )
  } else {
    base::data.frame(x = xseq, y = model$family$linkinv(as.vector(pred)))
  }
}

#' @export
predictdf.loess <- function(model, xseq, se, level) {
  pred <- stats::predict(model, newdata = data_frame(x = xseq), se = se)

  if (se) {
    y <- pred$fit
    ci <- pred$se.fit * stats::qt(level / 2 + .5, pred$df)
    ymin <- y - ci
    ymax <- y + ci
    base::data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit)
  } else {
    base::data.frame(x = xseq, y = as.vector(pred))
  }
}

#' @export
predictdf.locfit <- function(model, xseq, se, level) {
  pred <- stats::predict(model, newdata = data_frame(x = xseq), se.fit = se)

  if (se) {
    y <- pred$fit
    ci <- pred$se.fit * stats::qt(level / 2 + .5, model$dp["df2"])
    ymin <- y - ci
    ymax <- y + ci
    base::data.frame(x = xseq, y, ymin, ymax, se = pred$se.fit)
  } else {
    base::data.frame(x = xseq, y = as.vector(pred))
  }
}


#################################
###   Alpha and Turn  ###########
#################################

alpha_and_turn_fam_std = c();

for (i in 1:ncol(alpha_scored_family)){
  alpha_and_turn_fam_std <- append(alpha_and_turn_fam_std,sd(alpha_scored_family[,i]))
}

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/alpha_and_turn_fam_std.pdf")
hist( alpha_and_turn_fam_std,
      main="Alpha and Turn: Standard Deviation Distribution",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

alpha_turn_dTIM_m_mean_std <- (alpha_and_turn_dTIM_means-alpha_and_turn_fam_means) / alpha_and_turn_fam_std

write.csv(alpha_turn_dTIM_m_mean_std,file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/alpha_turn_dTIM_m_mean_std.csv")

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/alpha_turn_dTIM_m_mean_std.pdf")
hist( alpha_turn_dTIM_m_mean_std,
      main="Alpha and Turn: dTIM Minus Family Mean (Standardized)",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

#################################
###   Beta Propensity  ##########
#################################

beta_fam_std = c();

for (i in 1:ncol(beta_scored_family)){
  beta_fam_std <- append(beta_fam_std,sd(beta_scored_family[,i]))
}

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/beta_fam_std.pdf")
hist( beta_fam_std,
      main="Beta: Standard Deviation Distribution",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

beta_dTIM_m_mean_std <- (beta_dTIM_means - beta_fam_means) / beta_fam_std

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/beta_dTIM_m_mean_std.pdf")
hist( beta_dTIM_m_mean_std,
      main="Beta: dTIM Minus Family Mean (Standardized)",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

#################################
######  Composition  ############
#################################

comp_fam_std = c();

for (i in 1:ncol(comp_scored_family)){
  comp_fam_std <- append(comp_fam_std,sd(comp_scored_family[,i]))
}

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/comp_fam_std.pdf")
hist( comp_fam_std,
      main="Composition: Standard Deviation Distribution",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

comp_dTIM_m_mean_std <- (comp_dTIM_means - comp_fam_means) / comp_fam_std

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/comp_dTIM_m_mean_std.pdf")
hist( comp_dTIM_m_mean_std,
      main="comp: dTIM Minus Family Mean (Standardized)",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

#################################
###### Hydrophobicity  ##########
#################################

hydro_fam_std = c();

for (i in 1:ncol(hydro_scored_family)){
  hydro_fam_std <- append(hydro_fam_std,sd(hydro_scored_family[,i]))
}

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/hydro_fam_std.pdf")
hist( hydro_fam_std,
      main="Hydrophobicity: Standard Deviation Distribution",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

hydro_dTIM_m_mean_std <- (hydro_dTIM_means - hydro_fam_means) / hydro_fam_std

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/hydro_dTIM_m_mean_std.pdf")
hist( hydro_dTIM_m_mean_std,
      main="Hydrophobicity: dTIM Minus Family Mean (Standardized)",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

#################################
#### Other Properties  ##########
#################################
other_fam_std = c();

for (i in 1:ncol(other_scored_family)){
  other_fam_std <- append(other_fam_std,sd(other_scored_family[,i]))
}

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/other_fam_std.pdf")
hist( other_fam_std,
      main="Other Properties: Standard Deviation Distribution",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

other_dTIM_m_mean_std <- (other_dTIM_means - other_fam_means) / other_fam_std

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/other_dTIM_m_mean_std.pdf")
hist( other_dTIM_m_mean_std,
      main="Other Properties: dTIM Minus Family Mean (Standardized)",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

#################################
# Physicochemical Properties  ###
#################################
physico_fam_std = c();

for (i in 1:ncol(physico_scored_family)){
  physico_fam_std <- append(physico_fam_std,sd(physico_scored_family[,i]))
}

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/physico_fam_std.pdf")
hist( physico_fam_std,
      main="physico Properties: Standard Deviation Distribution",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

physico_dTIM_m_mean_std <- (physico_dTIM_means - physico_fam_means) / physico_fam_std

pdf(file="/Users/mercicle/Documents/python_workspace/BioVis/Codes/PrinCompData/ScoredTIMs/physico_dTIM_m_mean_std.pdf")
hist( physico_dTIM_m_mean_std,
      main="physico Properties: dTIM Minus Family Mean (Standardized)",
      freq=FALSE,
      breaks = 20,
      col="lightgreen",
      border="black")
dev.off()

############################################################################
####               Plot all histograms on One Plot                     #####
############################################################################
alpha_turn_dTIM_m_mean_std_df <- as.data.frame(alpha_turn_dTIM_m_mean_std)
beta_dTIM_m_mean_std_df  <- as.data.frame(beta_dTIM_m_mean_std)
comp_dTIM_m_mean_std_df <- as.data.frame(comp_dTIM_m_mean_std)
hydro_dTIM_m_mean_std_df  <- as.data.frame(hydro_dTIM_m_mean_std)
other_dTIM_m_mean_std_df  <- as.data.frame(other_dTIM_m_mean_std)
physico_dTIM_m_mean_std_df <- as.data.frame(physico_dTIM_m_mean_std)

#Now, combine your two dataframes into one.  First make a new column in each.
alpha_turn_dTIM_m_mean_std_df$characteristic <- 'Alpha-Turn Propensity'
beta_dTIM_m_mean_std_df$characteristic  <- 'Beta Propensity'
comp_dTIM_m_mean_std_df$characteristic <- 'Composition'
hydro_dTIM_m_mean_std_df$characteristic  <-  'Hydrophobicity'
other_dTIM_m_mean_std_df$characteristic  <- 'Other Properties'
physico_dTIM_m_mean_std_df$characteristic <-  'Physicochemical Properties'

names(alpha_turn_dTIM_m_mean_std_df)[1] <- "dTIMmMean"
names(beta_dTIM_m_mean_std_df)[1] <- "dTIMmMean"
names(comp_dTIM_m_mean_std_df)[1] <- "dTIMmMean"
names(hydro_dTIM_m_mean_std_df)[1] <- "dTIMmMean"
names(other_dTIM_m_mean_std_df)[1] <- "dTIMmMean"
names(physico_dTIM_m_mean_std_df)[1] <- "dTIMmMean"

#and combine into your new data frame vegLengths
allDistsStd <- rbind(alpha_turn_dTIM_m_mean_std_df,
                  beta_dTIM_m_mean_std_df,
                  comp_dTIM_m_mean_std_df,
                  hydro_dTIM_m_mean_std_df,
                  other_dTIM_m_mean_std_df,
                  physico_dTIM_m_mean_std_df)

#now make your lovely plot
ggplot(allDistsStd, aes(x = dTIMmMean))  +
  geom_histogram(data=subset(allDistsStd,characteristic == "alpha"),fill = "red", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "beta"),fill = "grey", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "comp"),fill = "blue", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "hydro"),fill = "green", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "other"),fill = "purple", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "physico"),fill = "yellow", alpha = 0.2)

ggplot(allDistsStd, aes(x = dTIMmMean))  +
  geom_histogram(data=subset(allDistsStd,characteristic == "Alpha-Turn Propensity"),fill = "red", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "Beta Propensity"),fill = "grey", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "Composition"),fill = "blue", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "Hydrophobicity"),fill = "green", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "Other Properties"),fill = "purple", alpha = 0.2) +
  geom_histogram(data=subset(allDistsStd,characteristic == "Physicochemical Properties"),fill = "yellow", alpha = 0.2) +
  geom_histogram(aes(fill = ..count..)) +
  scale_fill_gradient("count", low = "red",high = "green") +
  facet_wrap(~ characteristic)
+ ggtitle("his")

############################################################################
####                     Scatterplot Matrix                            #####
############################################################################
alpha_turn_dTIM_m_mean_std_df <- as.data.frame(alpha_turn_dTIM_m_mean_std)
beta_dTIM_m_mean_std_df  <- as.data.frame(beta_dTIM_m_mean_std)
comp_dTIM_m_mean_std_df <- as.data.frame(comp_dTIM_m_mean_std)
hydro_dTIM_m_mean_std_df  <- as.data.frame(hydro_dTIM_m_mean_std)
other_dTIM_m_mean_std_df  <- as.data.frame(other_dTIM_m_mean_std)
physico_dTIM_m_mean_std_df <- as.data.frame(physico_dTIM_m_mean_std)

allDistsStd <- data.frame(AlphaTurnPropensity = alpha_turn_dTIM_m_mean_std ,
                       BetaPropensity = beta_dTIM_m_mean_std ,
                       Composition = comp_dTIM_m_mean_std ,
                       Hydrophobicity = hydro_dTIM_m_mean_std ,
                       OtherCharacteristics = other_dTIM_m_mean_std ,
                       PhysicochemicalProperties = physico_dTIM_m_mean_std )

pairs(~AlphaTurnPropensity
      +BetaPropensity
      + Composition
      + Hydrophobicity
      + OtherCharacteristics
      + PhysicochemicalProperties
      ,data = allDistsStd,
      main="ScatterPlot of AA Characteristics: (dTIM Principal Component - Mean Principal Component) / Std")


# hypothesis testing for significance of oligogenic hypothesis in PCGC trios
# Kathleen Keough 2.16.17

# load necessary packages
setwd('/Users/kathleen/Box Sync/UCSF/ConklinPollard/projects/PCGC_oligo_proj')
library(dplyr)
library(readr)

# this is your file with 1/0 hypotheses for genes of interest (or all genes!)

trio_dat <- read_tsv("cardio277_table_freq30_excNAs.txt")
print(colnames(trio_dat[,apply(trio_dat==0,2,all)]))
print(dim(trio_dat))
# filter genes where all zeros indicating no trios met oligo hypothesis

trio_dat <- trio_dat[ , !apply(trio_dat==0,2,all)]
print(dim(trio_dat))
# construct gene list from column names (column 3 onwards)

list_of_interest = colnames(trio_dat)
gene_list <- as.list(tail(list_of_interest,length(list_of_interest)-2))

# perform Fisher's exact test for each gene

results_df <- data.frame(matrix(ncol = 2, nrow = length(gene_list)))
colnames(results_df) <- c("Genes","Fisher's Exact p-value")
results_df$Genes <- gene_list
rownames(results_df) <- results_df$Genes

for (gene in gene_list){
  fishers_pval <- fisher.test(trio_dat$CaseControl,
                              y=trio_dat[[paste(gene)]],
                              alternative = "greater")$p.value
  results_df[gene,2] <- fishers_pval
}

results_df$Genes <- unlist(results_df$Genes)

write.table(results_df, file='277cardio_common+rare_results.tsv', sep='\t', row.names = FALSE)


dat<-Read.summary.data()
unique(dat$Species)
dat<-droplevels(subset(dat,Species %in% c("N. sandeel","S. sandeel","Nor. pout" , "Sprat") & Quarter==1))
bio<-aggregate(list(TSB=dat$BIO/1000,SSB=dat$SSB/1000),list(Year=dat$Year,Species=dat$Species),sum)

b1<-subset(bio,select=c(Year,Species,TSB))

bio$Year<-bio$Year+1

b2<-subset(bio,select=c(Year,Species,SSB))

b<-merge(b1,b2)

b$ratio<-b$TSB/b$SSB
head(b)
aggregate(ratio~Species,data=b,mean)


#' @title gam2matrix
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
 gam2matrix = function( oo, i=1, n2=100 )  {

    xterm <- oo$smooth[[i]]$term[1]
    yterm <- oo$smooth[[i]]$term[2]

    raw <- data.frame(x=as.numeric(oo$model[xterm][[1]]), y = as.numeric(oo$model[yterm][[1]]))

    xm <- seq(min(raw$x), max(raw$x), length = n2)
    ym <- seq(min(raw$y), max(raw$y), length = n2)
    by <- rep(1, n2^2)

    xx <- rep(xm, n2)
    yy <- rep(ym, rep(n2, n2))

    dat <- data.frame(x=xx, y=yy, by=by)
    names(dat) <- c(xterm, yterm, oo$smooth[[i]]$by)

    op <- PredictMat(oo$smooth[[i]], dat)
    first <- oo$smooth[[i]]$first.para
    last <- oo$smooth[[i]]$last.para
    p <- oo$coefficients[first:last]
    offset <- attr(oo, "offset")
    if (is.null(offset)) {
      fit <- op %*% p
    } else {
      fit <- op %*% p + offset
    }

    mat = matrix( fit, n2, n2 )
    out = list( x=xm, y=ym, fit=mat )
    return( out)
  }


 modwptAnalysis=function(x,wavelet="d4", ULFmin = 0, ULFmax = 0.03, VLFmin = 0.03, VLFmax = 0.05, LFmin = 0.05, LFmax = 0.15, HFmin = 0.15, HFmax = 0.4, sampling=4,bandtolerance,relative)
{

  # Auxiliary variables
  ULFpower=0;
  VLFpower=0;
  LFpower=0;
  HFpower=0;

  # Working with a zero mean signal
  x=x-mean(x)
  # Getting tree nodes
  ULFnodes=getNodes(ULFmin,ULFmax,sampling,bandtolerance,relative)
  VLFnodes=getNodes(VLFmin,VLFmax,sampling,bandtolerance,relative)
  LFnodes=getNodes(LFmin,LFmax,sampling,bandtolerance,relative)
  HFnodes=getNodes(HFmin,HFmax,sampling,bandtolerance,relative)
  #All nodes
  targets=unlist(c(ULFnodes[2:length(ULFnodes)],VLFnodes[2:length(VLFnodes)],LFnodes[2:length(LFnodes)],HFnodes[2:length(HFnodes)]))

  # Get the maximum depth of the nodes
  depth=max(ULFnodes[[1]],VLFnodes[[1]],LFnodes[[1]],HFnodes[[1]])
  # Wavelet analysis
  wx=BoundModwpt(x,wf=wavelet,n.levels=depth,targets);

  # Power calculation
  ULFpower=getPower(wx,ULFnodes,wavelet)
  VLFpower=getPower(wx,VLFnodes,wavelet)
  LFpower=getPower(wx,LFnodes,wavelet)
  HFpower=getPower(wx,HFnodes,wavelet)

  # Store the results of the calculation
  return(list(ULF=ULFpower,VLF=VLFpower,LF=LFpower,HF=HFpower,depth=depth))

}


#' Regression matrix with default outlier and holiday regressors for IC
#'
#' A matrix object with the default regression matrix used for the default model of
#' IC in the factional airline model fit to the weekly initial unemployment claims data
#'
#' @format A 940 x 69 matrix with regressors in each column. The first 10 columns are regular holidays:
#' \describe{
#'   \item{ny}{New Years Day Holiday}
#'   \item{mlk}{MLK Holiday}
#'   \item{president}{Presidents Day Holiday}
#'   \item{easter}{Easter Holiday}
#'   \item{memorial}{Memorial Day Holiday}
#'   \item{july4}{July 4th Holiday}
#'   \item{labor}{Labor Day Holiday}
#'   \item{columbus}{Columbus Day Holiday}
#'   \item{veteran}{Veteran's Day Holiday}
#'   \item{thanksgiving}{Thanksgiving Holiday}
#' }
#' The next 3 columns are special holidays:
#' \describe{
#'   \item{july4_wed}{July 4th falls on a Wednesday}
#'   \item{xmas_w53}{Christams falls in the 53rd week}
#'   \item{xmas_fri}{Christmas falls on a Friday}
#' }
#' The remaining columns are AO outliers in different weeks.
#' Every week in the pandemic has an AO outlier. The outlier list is given below:
#' AO(week 37, 2005) AO(week 38, 2005) AO(week 39, 2005) AO(week 40, 2005)
#' AO(week 41, 2005) AO(week 1, 2006)  AO(week 2, 2007)	 AO(week 4, 2008)
#' AO(week 45, 2012) AO(week 35, 2017) AO(week 12, 2020) AO(week 13, 2020)
#' AO(week 14, 2020) AO(week 15, 2020) AO(week 16, 2020) AO(week 17, 2020)
#' AO(week 18, 2020) AO(week 19, 2020) AO(week 20, 2020) AO(week 21, 2020)
#' AO(week 22, 2020) AO(week 23, 2020) AO(week 24, 2020) AO(week 25, 2020)
#' AO(week 26, 2020) AO(week 27, 2020) AO(week 28, 2020) AO(week 29, 2020)
#' AO(week 30, 2020) AO(week 31, 2020) AO(week 32, 2020) AO(week 33, 2020)
#' AO(week 34, 2020) AO(week 35, 2020) AO(week 36, 2020) AO(week 37, 2020)
#' AO(week 38, 2020) AO(week 39, 2020) AO(week 40, 2020) AO(week 41, 2020)
#' AO(week 42, 2020) AO(week 43, 2020) AO(week 44, 2020) AO(week 45, 2020)
#' AO(week 46, 2020) AO(week 47, 2020) AO(week 48, 2020) AO(week 49, 2020)
#' AO(week 50, 2020) AO(week 51, 2020) AO(week 52, 2020) AO(week 1, 2021)
#' AO(week 2, 2021)  AO(week 3, 2021)  AO(week 4, 2021) AO(week 5, 2021)
#'
"ic_default_matrix"


   balanced             parens
1     FALSE               ][][
2     FALSE [][[]]][[]][]]][[[
3     FALSE     ][[][][]][][[]
4     FALSE     ][][][][][][][
5      TRUE [[[][]]][[[][][]]]
6      TRUE                 []
7     FALSE           ]][[][[]
8     FALSE     []]]][[[]][[[]
9      TRUE     [[[[][[][]]]]]
10     TRUE                 []


#' Map projections
#'
#' `coord_map()` projects a portion of the earth, which is approximately
#' spherical, onto a flat 2D plane using any projection defined by the
#' `mapproj` package. Map projections do not, in general, preserve straight
#' lines, so this requires considerable computation. `coord_quickmap()` is a
#' quick approximation that does preserve straight lines. It works best for
#' smaller areas closer to the equator.
#'
#' In general, map projections must account for the fact that the actual length
#' (in km) of one degree of longitude varies between the equator and the pole.
#' Near the equator, the ratio between the lengths of one degree of latitude and
#' one degree of longitude is approximately 1. Near the pole, it tends
#' towards infinity because the length of one degree of longitude tends towards
#' 0. For regions that span only a few degrees and are not too close to the
#' poles, setting the aspect ratio of the plot to the appropriate lat/lon ratio
#' approximates the usual mercator projection. This is what
#' `coord_quickmap()` does, and is much faster (particularly for complex
#' plots like [geom_tile()]) at the expense of correctness.
#'
#' @param projection projection to use, see
#'    [mapproj::mapproject()] for list
#' @param ...,parameters Other arguments passed on to
#'   [mapproj::mapproject()]. Use `...` for named parameters to
#'   the projection, and `parameters` for unnamed parameters.
#'   `...` is ignored if the `parameters` argument is present.
#' @param orientation projection orientation, which defaults to
#'   `c(90, 0, mean(range(x)))`.  This is not optimal for many
#'   projections, so you will have to supply your own. See
#'   [mapproj::mapproject()] for more information.
#' @param xlim,ylim Manually specific x/y limits (in degrees of
#'   longitude/latitude)
#' @param clip Should drawing be clipped to the extent of the plot panel? A
#'   setting of `"on"` (the default) means yes, and a setting of `"off"`
#'   means no. For details, please see [`coord_cartesian()`].
#' @export
#' @examples
#' if (require("maps")) {
#' nz <- map_data("nz")
#' # Prepare a map of NZ
#' nzmap <- ggplot(nz, aes(x = long, y = lat, group = group)) +
#'   geom_polygon(fill = "white", colour = "black")
#'
#' # Plot it in cartesian coordinates
#' nzmap
#' }
#'
#' if (require("maps")) {
#' # With correct mercator projection
#' nzmap + coord_map()
#' }
#'
#' if (require("maps")) {
#' # With the aspect ratio approximation
#' nzmap + coord_quickmap()
#' }
#'
#' if (require("maps")) {
#' # Other projections
#' nzmap + coord_map("azequalarea", orientation = c(-36.92, 174.6, 0))
#' }
#'
#' if (require("maps")) {
#' states <- map_data("state")
#' usamap <- ggplot(states, aes(long, lat, group = group)) +
#'   geom_polygon(fill = "white", colour = "black")
#'
#' # Use cartesian coordinates
#' usamap
#' }
#'
#' if (require("maps")) {
#' # With mercator projection
#' usamap + coord_map()
#' }
#'
#' if (require("maps")) {
#' # See ?mapproject for coordinate systems and their parameters
#' usamap + coord_map("gilbert")
#' }
#'
#' if (require("maps")) {
#' # For most projections, you'll need to set the orientation yourself
#' # as the automatic selection done by mapproject is not available to
#' # ggplot
#' usamap + coord_map("orthographic")
#' }
#'
#' if (require("maps")) {
#' usamap + coord_map("conic", lat0 = 30)
#' }
#'
#' if (require("maps")) {
#' usamap + coord_map("bonne", lat0 = 50)
#' }
#'
#' \dontrun{
#' if (require("maps")) {
#' # World map, using geom_path instead of geom_polygon
#' world <- map_data("world")
#' worldmap <- ggplot(world, aes(x = long, y = lat, group = group)) +
#'   geom_path() +
#'   scale_y_continuous(breaks = (-2:2) * 30) +
#'   scale_x_continuous(breaks = (-4:4) * 45)
#'
#' # Orthographic projection with default orientation (looking down at North pole)
#' worldmap + coord_map("ortho")
#' }
#'
#' if (require("maps")) {
#' # Looking up up at South Pole
#' worldmap + coord_map("ortho", orientation = c(-90, 0, 0))
#' }
#'
#' if (require("maps")) {
#' # Centered on New York (currently has issues with closing polygons)
#' worldmap + coord_map("ortho", orientation = c(41, -74, 0))
#' }
#' }
coord_map <- function(projection="mercator", ..., parameters = NULL, orientation = NULL, xlim = NULL, ylim = NULL, clip = "on") {
  if (is.null(parameters)) {
    params <- list(...)
  } else {
    params <- parameters
  }

  ggproto(NULL, CoordMap,
    projection = projection,
    orientation = orientation,
    limits = list(x = xlim, y = ylim),
    params = params,
    clip = clip
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
CoordMap <- ggproto("CoordMap", Coord,

  transform = function(self, data, panel_params) {
    trans <- mproject(self, data$x, data$y, panel_params$orientation)
    out <- cunion(trans[c("x", "y")], data)

    out$x <- rescale(out$x, 0:1, panel_params$x.proj)
    out$y <- rescale(out$y, 0:1, panel_params$y.proj)
    # mproject() converts Inf to NA, so we need to restore them from data.
    out$x[is.infinite(data$x)] <- squish_infinite(data$x)
    out$y[is.infinite(data$y)] <- squish_infinite(data$y)

    out
  },

  backtransform_range = function(panel_params) {
    # range is stored in data coordinates and doesn't have to be back-transformed
    list(x = panel_params$x.range, y = panel_params$y.range)
  },

  range = function(panel_params) {
    # Range in projected coordinates:
    #   list(x = panel_params$x.proj, y = panel_params$y.proj)
    # However, coord_map() does never really work with transformed coordinates,
    # so return unprojected data coordinates here
    list(x = panel_params$x.range, y = panel_params$y.range)
  },

  distance = function(x, y, panel_params) {
    max_dist <- dist_central_angle(panel_params$x.range, panel_params$y.range)
    dist_central_angle(x, y) / max_dist
  },

  aspect = function(ranges) {
    diff(ranges$y.proj) / diff(ranges$x.proj)
  },

  setup_panel_params = function(self, scale_x, scale_y, params = list()) {

    # range in scale
    ranges <- list()
    for (n in c("x", "y")) {
      scale <- get(paste0("scale_", n))
      limits <- self$limits[[n]]
      range <- expand_limits_scale(scale, default_expansion(scale), coord_limits = limits)
      ranges[[n]] <- range
    }

    orientation <- self$orientation %||% c(90, 0, mean(ranges$x))

    # Increase chances of creating valid boundary region
    grid <- expand.grid(
      x = seq(ranges$x[1], ranges$x[2], length.out = 50),
      y = seq(ranges$y[1], ranges$y[2], length.out = 50)
    )

    ret <- list(x = list(), y = list())

    # range in map
    proj <- mproject(self, grid$x, grid$y, orientation)$range
    ret$x$proj <- proj[1:2]
    ret$y$proj <- proj[3:4]

    for (n in c("x", "y")) {
      out <- get(paste0("scale_", n))$break_info(ranges[[n]])
      ret[[n]]$range <- out$range
      ret[[n]]$major <- out$major_source
      ret[[n]]$minor <- out$minor_source
      ret[[n]]$labels <- out$labels
    }

    details <- list(
      orientation = orientation,
      x.range = ret$x$range, y.range = ret$y$range,
      x.proj = ret$x$proj, y.proj = ret$y$proj,
      x.major = ret$x$major, x.minor = ret$x$minor, x.labels = ret$x$labels,
      y.major = ret$y$major, y.minor = ret$y$minor, y.labels = ret$y$labels,
      x.arrange = scale_x$axis_order(), y.arrange = scale_y$axis_order()
    )
    details
  },

  render_bg = function(self, panel_params, theme) {
    xrange <- expand_range(panel_params$x.range, 0.2)
    yrange <- expand_range(panel_params$y.range, 0.2)

    # Limit ranges so that lines don't wrap around globe
    xmid <- mean(xrange)
    ymid <- mean(yrange)
    xrange[xrange < xmid - 180] <- xmid - 180
    xrange[xrange > xmid + 180] <- xmid + 180
    yrange[yrange < ymid - 90] <- ymid - 90
    yrange[yrange > ymid + 90] <- ymid + 90

    xgrid <- with(panel_params, expand.grid(
      y = c(seq(yrange[1], yrange[2], length.out = 50), NA),
      x = x.major
    ))
    ygrid <- with(panel_params, expand.grid(
      x = c(seq(xrange[1], xrange[2], length.out = 50), NA),
      y = y.major
    ))

    xlines <- self$transform(xgrid, panel_params)
    ylines <- self$transform(ygrid, panel_params)

    if (nrow(xlines) > 0) {
      grob.xlines <- element_render(
        theme, "panel.grid.major.x",
        xlines$x, xlines$y, default.units = "native"
      )
    } else {
      grob.xlines <- zeroGrob()
    }

    if (nrow(ylines) > 0) {
      grob.ylines <- element_render(
        theme, "panel.grid.major.y",
        ylines$x, ylines$y, default.units = "native"
      )
    } else {
      grob.ylines <- zeroGrob()
    }

    ggname("grill", grobTree(
      element_render(theme, "panel.background"),
      grob.xlines, grob.ylines
    ))
  },

  render_axis_h = function(self, panel_params, theme) {
    arrange <- panel_params$x.arrange %||% c("secondary", "primary")

    if (is.null(panel_params$x.major)) {
      return(list(
        top = zeroGrob(),
        bottom = zeroGrob()
      ))
    }

    x_intercept <- with(panel_params, new_data_frame(list(
      x = x.major,
      y = y.range[1]
    ), n = length(x.major)))
    pos <- self$transform(x_intercept, panel_params)

    axes <- list(
      top = draw_axis(pos$x, panel_params$x.labels, "top", theme),
      bottom = draw_axis(pos$x, panel_params$x.labels, "bottom", theme)
    )
    axes[[which(arrange == "secondary")]] <- zeroGrob()
    axes
  },

  render_axis_v = function(self, panel_params, theme) {
    arrange <- panel_params$y.arrange %||% c("primary", "secondary")

    if (is.null(panel_params$y.major)) {
      return(list(
        left = zeroGrob(),
        right = zeroGrob()
      ))
    }

    x_intercept <- with(panel_params, new_data_frame(list(
      x = x.range[1],
      y = y.major
    ), n = length(y.major)))
    pos <- self$transform(x_intercept, panel_params)

    axes <- list(
      left = draw_axis(pos$y, panel_params$y.labels, "left", theme),
      right = draw_axis(pos$y, panel_params$y.labels, "right", theme)
    )
    axes[[which(arrange == "secondary")]] <- zeroGrob()
    axes
  }
)

mproject <- function(coord, x, y, orientation) {
  check_installed("mapproj", reason = "for `coord_map()`")
  suppressWarnings(mapproj::mapproject(x, y,
    projection = coord$projection,
    parameters  = coord$params,
    orientation = orientation
  ))
}


suppressMessages(library(ez))
suppressMessages(library(ggplot2))
suppressMessages(library(multcomp))
suppressMessages(library(nlme))
suppressMessages(library(pastecs))
suppressMessages(library(pgirmess))
suppressMessages(library(reshape))
suppressMessages(library(WRS))
suppressMessages(library(e1071))
suppressMessages(library(afex))
suppressMessages(library(emmeans))
suppressMessages(library(tidyverse))
suppressMessages(library(sjPlot))
suppressMessages(library(sjmisc))

processMainEffectCategory <- function(filename, n){
  data <- read.csv(file=filename, header=TRUE, sep=",")
  data$preferredVersion <- unclass(data$preferredVersion)
  personalityVariables <- names(data)[2:39]

  invisible(lapply(personalityVariables, function(x) {
    result <- aov(eval(substitute(grandMeanTakes ~ personality, list(personality = as.name(x)))), data = data)
    filename = sprintf("./results/mainEffects/personality/categories/%s/grandMeanTakes/%s.messageAcrossData", n, x)
    #print(summary(result))
    write.table(data.frame(unlist(summary(result))), file=filename, row.names=TRUE, col.names=TRUE)
    if(summary(result)[[1]][["Pr(>F)"]] <= 0.05){
      posthoc<-suppressMessages(pairwise.wilcox.test(data$grandMeanTakes, eval(substitute(data$personality, list(personality = as.name(x)))), p.adj = "none", exact=FALSE))
      write.table(data.frame(unlist(posthoc)), file=sprintf("./results/mainEffects/personality/categories/%s/grandMeanTakes/Post_%s.messageAcrossData", n, x), row.names=TRUE, col.names=TRUE)
      #print(posthoc)
    }
  }))

  invisible(lapply(personalityVariables, function(x) {
    result <- aov(eval(substitute(meanWhoFocus ~ personality, list(personality = as.name(x)))), data = data)
    filename = sprintf("./results/mainEffects/personality/categories/%s/meanWhoFocus/%s.messageAcrossData", n, x)
    write.table(data.frame(unlist(summary(result))), file=filename, row.names=TRUE, col.names=TRUE)
    if(summary(result)[[1]][["Pr(>F)"]] <= 0.05){
      posthoc<-suppressMessages(pairwise.wilcox.test(data$meanWhoFocus, eval(substitute(data$personality, list(personality = as.name(x)))), p.adj = "none", exact=FALSE))
      write.table(data.frame(unlist(posthoc)), file=sprintf("./results/mainEffects/personality/categories/%s/meanWhoFocus/Post_%s.messageAcrossData", n, x), row.names=TRUE, col.names=TRUE)
    }
  }))

  invisible(lapply(personalityVariables, function(x) {
    result <- aov(eval(substitute(meanWhatFocus ~ personality, list(personality = as.name(x)))), data = data)
    filename = sprintf("./results/mainEffects/personality/categories/%s/meanWhatFocus/%s.messageAcrossData", n, x)
    write.table(data.frame(unlist(summary(result))), file=filename, row.names=TRUE, col.names=TRUE)
    if(summary(result)[[1]][["Pr(>F)"]] <= 0.05){
      posthoc<-suppressMessages(pairwise.wilcox.test(data$meanWhatFocus, eval(substitute(data$personality, list(personality = as.name(x)))), p.adj = "none", exact=FALSE))
      write.table(data.frame(unlist(posthoc)), file=sprintf("./results/mainEffects/personality/categories/%s/meanWhatFocus/Post_%s.messageAcrossData", n, x), row.names=TRUE, col.names=TRUE)
    }
  }))
}

processInteractionCategory <- function(filename, n){
  meltedData <- read.csv(file=filename, header=TRUE, sep=",")

  personalityVariables <- names(meltedData)[2:39]
  #print(personalityVariables)

  #Compute the analysis of variance

  invisible(lapply(personalityVariables, function(x) {
      Mixed.aov.1 <- suppressMessages(aov_car(eval(substitute(takes ~ personality * ScoreSystem + Error(playerId/ScoreSystem), list(personality = as.name(x)))), data = meltedData))

      filename = sprintf("./results/interactionEffects/categories/%s/takes/%s.messageAcrossData", n, x)
      write(knitr::kable(nice(Mixed.aov.1)),file=filename,append=TRUE)

      if(grepl("*", nice(Mixed.aov.1)[[4]][[3]], fixed=TRUE)){
        Mixed_Fitted_Interaction<-suppressMessages(emmeans(Mixed.aov.1, eval(substitute(~ScoreSystem|personality, list(personality = as.name(x))))))
        write.table(Mixed_Fitted_Interaction, file=sprintf("./results/interactionEffects/categories/%s/takes/Post_%s.messageAcrossData", n, x), row.names=TRUE, col.names=TRUE)
      }
    }
  ))

  invisible(lapply(personalityVariables, function(x) {
      Mixed.aov.1 <- suppressMessages(aov_car(eval(substitute(what ~ personality * ScoreSystem + Error(playerId/ScoreSystem), list(personality = as.name(x)))), data = meltedData))

      filename = sprintf("./results/interactionEffects/categories/%s/what/%s.messageAcrossData", n, x)
      write(knitr::kable(nice(Mixed.aov.1)),file=filename,append=TRUE)

      if(grepl("*", nice(Mixed.aov.1)[[4]][[3]], fixed=TRUE)){
        Mixed_Fitted_Interaction<-suppressMessages(emmeans(Mixed.aov.1, eval(substitute(~ScoreSystem|personality, list(personality = as.name(x))))))
        write.table(Mixed_Fitted_Interaction, file=sprintf("./results/interactionEffects/categories/%s/what/Post_%s.messageAcrossData", n, x), row.names=TRUE, col.names=TRUE)
      }
    }
  ))

  invisible(lapply(personalityVariables, function(x) {
      Mixed.aov.1 <- suppressMessages(aov_car(eval(substitute(who ~ personality * ScoreSystem + Error(playerId/ScoreSystem), list(personality = as.name(x)))), data = meltedData))

      filename = sprintf("./results/interactionEffects/categories/%s/who/%s.messageAcrossData", n, x)
      write(knitr::kable(nice(Mixed.aov.1)),file=filename,append=TRUE)

      if(grepl("*", nice(Mixed.aov.1)[[4]][[3]], fixed=TRUE)){
        Mixed_Fitted_Interaction<-suppressMessages(emmeans(Mixed.aov.1, eval(substitute(~ScoreSystem|personality, list(personality = as.name(x))))))
        write.table(Mixed_Fitted_Interaction, file=sprintf("./results/interactionEffects/categories/%s/who/Post_%s.messageAcrossData", n, x), row.names=TRUE, col.names=TRUE)
      }
    }
  ))
}

print("Computing main effects...")
# print("Computing for two groups [High, Low]...")
# processMainEffectCategory("input/dataTwoCategories.csv", "two")
print("Computing for three groups [High, Medium, Low]...")
processMainEffectCategory("input/dataThreeCategories.csv", "three")
# print("Computing for four groups [High, Medium_High, Medium_Low, Low]...")
# processMainEffectCategory("input/dataFourCategories.csv", "four")

print("Computing interaction effects...")
# print("Computing for two groups [High, Low]...")
# processInteractionCategory("output/meltedDataTwoCategories.csv", "two")
print("Computing for three groups [High, Medium, Low]...")
processInteractionCategory("output/meltedDataThreeCategories.csv", "three")
# print("Computing for four groups [High, Medium_High, Medium_Low, Low]...")
# processInteractionCategory("output/meltedDataFourCategories.csv", "four")