# GetLargeDocTargetsData.r
source("../common/DataUtil.r")
library(ggplot2)
source("../common/PlotUtil.r")

# P A R A M S
sPlotFile <- "largedoctargets.png"
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem
                                    , docsize
                                    )}
fnSubset <- function(dfIn) {subset(dfIn, copies==1 & lifem<=10000
                                    )}
sTitleLine <-   (   ""
                %+% "Larger documents are larger targets for random errors and "
                %+% "therefore more likely to fail "
                %+% " "
                %+% "\n"
                %+% "\n(Copies=1, no auditing)"
                )
sLegendLabel <- "Document\n size (MB)"
lLegendItemLabels <- c("5", "50", "500", "5000")
sXLabel <- ("1MB sector half-life (megahours)"
            %+% "                           (lower error rate =====>)")
sYLabel <- ("permanent document losses (%)")
# Also change summarize function and ggplot(color=...).

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
newdat <- alldat.df %>% fnGroupBy() %>%
summarize(mdmlosspct=round(midmean(lost/docstotal)*100.0, 2), n=n()) %>%
fnSubset()
trows <- newdat

# P L O T   D A T A
gp <- ggplot(data=trows
            , aes(x=lifem,y=safe(mdmlosspct), color=factor(docsize))
            )
gp <- gp + labs(color=sLegendLabel)

gp <- fnPlotLogScales(gp, x="YES", y="YES"
                ,xbreaks=c(2,5,10,100,1000,10000)
                ,ybreaks=c(0.01,0.10,1.00,10,100)
                )
gp <- gp + geom_line(
                  size=3
                , show.legend=TRUE
                )
gp <- gp + geom_point(data=trows
                , size=6
                , show.legend=TRUE
                , color="black"
                )

gp <- gp + theme(legend.position=c(0.15,0.3))
gp <- gp + theme(legend.background=element_rect(fill="lightgray",
                                  size=0.5, linetype="solid"))
gp <- gp + theme(legend.key.size=unit(0.3, "in"))
gp <- gp + theme(legend.key.width=unit(0.6, "in"))
gp <- gp + theme(legend.text=element_text(size=16))
gp <- gp + theme(legend.title=element_text(size=14))
gp <- gp + scale_color_discrete(labels=lLegendItemLabels)

gp <- fnPlotTitles(gp
            , titleline=sTitleLine
            , xlabel=sXLabel
            , ylabel=sYLabel
        )
# Label the percentage lines out on the right side.
xlabelposition <- log10(800)
gp <- fnPlotPercentLine(gp, xloc=xlabelposition)
gp <- fnPlotMilleLine(gp, xloc=xlabelposition)
gp <- fnPlotSubMilleLine(gp, xloc=xlabelposition)

plot(gp)
fnPlotMakeFile(gp, sPlotFile)

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


#' Find the optimal parameter values for BRTs
#' (lowest mean deviance with n.trees > 1000)
#' Zack Oyafuso & Erik Franklin <=2017
#' Simon Dedman, 2016, simondedman@gmail.com,
#' github.com/SimonDedman/gbm.auto
#'
#' @param samples Explanatory and response variables to predict from. Keep col
#' names short, no odd characters, starting numerals or terminal periods. Spaces
#' may be converted to periods in directory names, underscores won't. Can be a
#' subset
#' @param expvar List of names or column numbers of explanatory variables in
#' 'samples': c(1,3,6) or c("Temp","Sal"). No default
#' @param resvar Name or column number of response variable in samples: 12,
#' "Rockfish". No default. Column name is ideally species name
#' @param tc Permutations of tree complexity to attempt, single or vector,
#' biggest number <= number of explanatory variables e.g. c(2,7)
#' @param lr Permutations of learning rate to attmpt. Single or vector.
#' @param bf Permutations of bag fraction to attempt. Single vector or "CHECK" to test
#' @param family Probability distribution family: bernoulli poisson laplace gaussian
#' @param runbest Option to run BRT with best param combo, default false
#'
#' @return Optionally runs best BRT and prints best parameter combination
#' @export
#' @author Simon Dedman, \email{simondedman@@gmail.com}
#' @examples None
#' @import gbm
#' @import dismo
#' @import parallel
#' @import foreach
#' @import doParallel

gbm.tune <- function(
  lr = c(0.001, 0.005, 0.01), # Permutations of learning rate to attmpt. Single or vector.
  tc = 1:3, # Permutations of tree complexity to attempt, single or vector,
  # biggest number <= number of explanatory variables e.g. c(2,7)
  bf = "CHECK", # Permutations of bag fraction to attempt. Single vector or "CHECK" to test
  samples, # Explanatory and response variables to predict from. Keep col
  # names short, no odd characters, starting numerals or terminal periods. Spaces
  # may be converted to periods in directory names, underscores won't. Can be a
  # subset
  expvar, # List of names or column numbers of explanatory variables in samples
  # e.g. c(1,3,6) or c("Temp","Sal"). No default
  resvar, # Name or column number of response variable in samples: 12,
  # "Rockfish". No default. Column name is ideally species name
  family = "gaussian", #Probability distribution family: bernoulli poisson laplace gaussian
  runbest = FALSE){ #run BRT of best parameter combo? Default FALSE

  library(dismo); library(gbm); library(parallel); library(foreach); library(doParallel)

  #SD TODO####
  # currently tries preset permutations of tc lr bf Which is better than manually
  # tc could be based on n of vars?
  # what happens if a BRT doesn't run? If code can learn from crash & continue then
  # lr & bf could be set large enough to probably crash and iteratively shrink
  # change name of this function

  #Get minimum bf with gbm.bfcheck if requested####
  if(bf == "CHECK") if(family == "gaussian"){
    minbf <- gbm.bfcheck(samples = samples, resvar = resvar, ZI = "CHECK")[2]
  } else {
    minbf <- gbm.bfcheck(samples = samples, resvar = resvar, ZI = "CHECK")[1]
  }

  #set min bf based on bfcheck & untouchable ceiling of 1####
  if(minbf < 0.5) { #open 1st IF
    minbf <- 0.5 # default to 0.5 if acceptable bf is <0.5
  } else { #close 1st IF open 1st ELSE
    if(minbf > 0.9 && minbf < 1){ #if minbf is between 0.9 & 1 #open 2nd IF
      minbf <- min(ceiling(minbf*100) / 100, 0.99) # round up 0.1 or 0.99 never 1. Still probably won't work!
    } else { #open 2nd ELSE within 2nd IF
      minbf <- ceiling(minbf*10) / 10 # else round up to nearest 0.1
    } #close 2nd ELSE
  } # close 1st IF. minbf is single min acceptable bf else 0.5.

  #create vector of bf permutations####
  headroom <- 1-minbf #space between minbf and 1
  headincrement <- headroom/3 # thirds of that space
  bf <- c(minbf, # create a vector of 3 values, min bf + 1/3 & 2/3
          minbf + (headincrement * 1),
          minbf + (headincrement * 2))

  #Tune BRT settings####
  ## Create all combination of
  ## (1) learning rate (lr)
  ## (2) tree complexity (tc)
  ## (3) bagging rate (bf)
  tune_settings = expand.grid(lr, tc, bf)

  #Run BRT model per setting in tune_settings####
  #Register Cores for Parallel Processing####
  cl = makeCluster(detectCores())
  registerDoParallel(cl, cores = detectCores())
  #samples <- samples #delete if unrequired
  clusterExport(cl = cl, varlist = 'samples')

  #Partition BRTs to workers####
  x = foreach(i = 1:nrow(tune_settings), .combine = rbind) %dopar% {
    library(dismo); library(gbm)
    test = gbm.step(data = samples,
                    gbm.x = expvar,
                    gbm.y = resvar, #response
                    family = family,
                    tree.complexity = tune_settings$tc[i],
                    learning.rate = tune_settings$lr[i],
                    bag.fraction = tune_settings$bf[i])

    print( c(test$n.trees, test$cv.statistics$deviance.mean) )
  }
  stopCluster(cl)

  #Append n.trees mean dev to tune_settings####
  tune_settings[,c('n.trees', 'dev_mean')] = x

  #Select best settings####
  # The "optimal" settings is the combination of bf tc & lr that
  # 1: produces > 1000 trees (as recommended by Elith et al. 2008), and
  # 2: has the lowest mean deviance
  if(min(tune_settings$n.trees < 1000)) { #if no treees>1000 produces
    best_settings = tune_settings[which.min(tune_settings$dev_mean),] #make best settings anyway
    print("No BRT combinations produced >= 1000 trees") #let the user know
  } else { #else subset for only trees > 1000
    accept_mods = subset(tune_settings, n.trees > 1000)
    best_settings = accept_mods[which.min(accept_mods$dev_mean),]
  }

  #Fit BRT with best settings####
  if(runbest){ #if runbest BRT params selected, do so
    brt_opt =  gbm.step(data = samples,
                        gbm.x = expvar, #covariates
                        gbm.y = resvar,
                        family = "gaussian",
                        tree.complexity = best_settings$tc,
                        learning.rate = best_settings$lr,
                        bag.fraction = best_settings$bf)
  }
  return(best_settings) #return best settings combo to user
} # close function


#' Extract the EMM Plot as a ggplot element form a Jamovi call to ANOVA
#'
#' @param res The result of an ANOVA call
#' @param plotnumber The emm plot to extract if using multi-way Anova
#'
#' @return a ggplot object
#' @export
#'
#' @examples
anova_emm_plot <- function(res, plotnumber = 1){

  res$emm[[plotnumber]]$emmPlot$plot

}


# test_genMCMC_ANOVA.r

library(JerimalaiStoneArtefacts)
context("genMCMC_cont_table")

test_that("genMCMC_cont_table works", {

  library(JerimalaiStoneArtefacts)
  library(coda)

  # from Jags-Ycount-Xnom2fac-MpoissonExp-Example.R

  #-------------------------------------------------------------------------------
  #Load The data file
  #.............................................................................
  myDataFrame = read.csv( file="data_for_tests/HairEyeColor.csv" )
  # Alter count by a multiplier, for demo purposes:
  countMult = 1
  myDataFrame$Count = round( myDataFrame$Count * countMult )
  fileNameRoot = paste0("HairEyeColor-",countMult,"-")
  yName="Count"
  x1Name="Eye"
  x2Name="Hair"
  x1contrasts = list(
    list( c("Green") , c("Hazel") , compVal=0.0 , ROPE=c(-0.1,0.1) ) ,
    list( c("Blue")  , c("Green") , compVal=0.0 , ROPE=c(-0.1,0.1) )
  )
  x2contrasts = list(
    list( c("Black") , c("Blond") , compVal=0.0 , ROPE=c(-0.1,0.1) ) ,
    list( c("Brown") , c("Red")   , compVal=0.0 , ROPE=c(-0.1,0.1) )
  )
  x1x2contrasts = list(
    list( list( c("Blue") , c("Brown") ) ,
          list( c("Black") , c("Blond") ) ,
          compVal=0.0 , ROPE=c(-0.1,0.1) )
  )
  numSavedSteps = 12000
  thinSteps = 10

  #.............................................................................
  graphFileType = "eps"

  # --------------------------------------------------------------------
  # Generate the MCMC chain:

  mcmcCoda_cont_table <- genMCMC_cont_table(datFrm=myDataFrame,
                      yName=yName , x1Name=x1Name , x2Name=x2Name ,
                      numSavedSteps=numSavedSteps , thinSteps=thinSteps ,
                      saveName=fileNameRoot )
  #-------------------------------------------------------------------------------
  # Display diagnostics of chain, for specified parameters:
#   parameterNames = varnames(mcmcCoda)
#   show( parameterNames ) # show all parameter names, for reference
#   for ( parName in c("b0","b1[1]","b2[1]","b1b2[1,1]","ppx1x2p[1,1]",
#                      "a1SD","a1a2SD") ) {
#     diagMCMC( codaObject=mcmcCoda , parName=parName ,
#               saveName=fileNameRoot , saveType=graphFileType )
#   }
  #-------------------------------------------------------------------------------
  # Get summary statistics of chain:
  summaryInfo_cont_table = smryMCMC_cont_table( codaSamples = mcmcCoda_cont_table ,
                          datFrm=myDataFrame , x1Name=x1Name , x2Name=x2Name ,
                          x1contrasts=x1contrasts ,
                         x2contrasts=x2contrasts ,
                         x1x2contrasts=x1x2contrasts ,
                          saveName=fileNameRoot )
  # show(summaryInfo)
  # Display posterior information:
#      plotMCMC_cont_table( mcmcCoda ,
#                datFrm=myDataFrame , yName=yName , x1Name=x1Name , x2Name=x2Name ,
#                x1contrasts=x1contrasts ,
#   #             x2contrasts=x2contrasts ,
#   #             x1x2contrasts=x1x2contrasts ,
#                saveName=fileNameRoot , saveType=graphFileType )
  #-------------------------------------------------------------------------------
  # Other specific comparisons of cells:
#   if ( substr(fileNameRoot,1,12) == "HairEyeColor" ) {
#     # THIS x1level minus THAT x1level at AT x2level:
#     THISx1 = "Blue"
#     THATx1 = "Brown"
#     ATx2 = "Black"
#     THISidx = which(levels(myDataFrame[,x1Name])==THISx1)
#     THATidx = which(levels(myDataFrame[,x1Name])==THATx1)
#     ATidx   = which(levels(myDataFrame[,x2Name])==ATx2)
#     openGraph(height=4,width=4)
#     compInfo = plotPost(
#       as.matrix(mcmcCoda)[,paste("b1b2[",THISidx,",",ATidx,"]",sep="")] -
#         as.matrix(mcmcCoda)[,paste("b1b2[",THATidx,",",ATidx,"]",sep="")] ,
#       main=paste(THISx1,"-",THATx1,"@",ATx2) ,
#       xlab=paste("Beta Deflect. Diff.") ,
#       compVal=0 ,ROPE=c(-0.1,0.1) )
#     show(compInfo)
#     saveGraph(file=paste(fileNameRoot,THISx1,"-",THATx1,"At",ATx2,sep=""),
#               type=graphFileType)
#     # THIS x1level minus THAT x1level at AT x2level:
#     THISx1 = "Blue"
#     THATx1 = "Brown"
#     ATx2 = "Blond"
#     THISidx = which(levels(myDataFrame[,x1Name])==THISx1)
#     THATidx = which(levels(myDataFrame[,x1Name])==THATx1)
#     ATidx   = which(levels(myDataFrame[,x2Name])==ATx2)
#     openGraph(height=4,width=4)
#     compInfo = plotPost(
#       as.matrix(mcmcCoda)[,paste("b1b2[",THISidx,",",ATidx,"]",sep="")] -
#         as.matrix(mcmcCoda)[,paste("b1b2[",THATidx,",",ATidx,"]",sep="")] ,
#       main=paste(THISx1,"-",THATx1,"@",ATx2) ,
#       xlab=paste("Beta Deflect. Diff.") ,
#       compVal=0 ,ROPE=c(-0.1,0.1) )
#     show(compInfo)
#     saveGraph(file=paste(fileNameRoot,THISx1,"-",THATx1,"At",ATx2,sep=""),
#               type=graphFileType)
#     # THIS x2level minus THAT x2level at AT x1level:
#     THISx2 = "Black"
#     THATx2 = "Blond"
#     ATx1 = "Blue"
#     THISidx = which(levels(myDataFrame[,x2Name])==THISx2)
#     THATidx = which(levels(myDataFrame[,x2Name])==THATx2)
#     ATidx   = which(levels(myDataFrame[,x1Name])==ATx1)
#     openGraph(height=4,width=4)
#     compInfo = plotPost(
#       as.matrix(mcmcCoda)[,paste("b1b2[",ATidx,",",THISidx,"]",sep="")] -
#         as.matrix(mcmcCoda)[,paste("b1b2[",ATidx,",",THATidx,"]",sep="")] ,
#       main=paste(THISx2,"-",THATx2,"@",ATx1) ,
#       xlab=paste("Beta Deflect. Diff.") ,
#       compVal=0 ,ROPE=c(-0.1,0.1) )
#     show(compInfo)
#     saveGraph(file=paste(fileNameRoot,THISx2,"-",THATx2,"At",ATx1,sep=""),
#               type=graphFileType)
#     # THIS x2level minus THAT x2level at AT x1level:
#     THISx2 = "Black"
#     THATx2 = "Blond"
#     ATx1 = "Brown"
#     THISidx = which(levels(myDataFrame[,x2Name])==THISx2)
#     THATidx = which(levels(myDataFrame[,x2Name])==THATx2)
#     ATidx   = which(levels(myDataFrame[,x1Name])==ATx1)
#     openGraph(height=4,width=4)
#     compInfo = plotPost(
#       as.matrix(mcmcCoda)[,paste("b1b2[",ATidx,",",THISidx,"]",sep="")] -
#         as.matrix(mcmcCoda)[,paste("b1b2[",ATidx,",",THATidx,"]",sep="")] ,
#       main=paste(THISx2,"-",THATx2,"@",ATx1) ,
#       xlab=paste("Beta Deflect. Diff.") ,
#       compVal=0 ,ROPE=c(-0.1,0.1) )
#     show(compInfo)
#     saveGraph(file=paste(fileNameRoot,THISx2,"-",THATx2,"At",ATx1,sep=""),
#               type=graphFileType)
#   }
  #-------------------------------------------------------------------------------

  # clean up by removing files...
  do.call(file.remove,list(list.files(pattern = fileNameRoot)))

  # simply check that the output has the right number of rows and cols
  expect_equal(dim(summaryInfo_cont_table), c(73, 14))

})


rm(list=ls())

### Functions ###

# It calculates the SUS of a specific user
calculateSUS = function (list) {
	sum = 0
	for (i in 1:10) {
		value = list[[i]]
		if (i %% 2 == 0) {
			sum = sum + 5 - value
		} else {
			sum = sum + value - 1
		}
	}
	return(sum * 2.5)
}

# It calculates the SUS of each user (one per row)
calculateUsersSUS = function (list) {
	result = data.frame()
	len = length(list[,1])
	for (i in 1:len) {
		result[paste("User",i,sep=""),1] = calculateSUS(list[i,])
	}

	names(result) = "SUS values"
	return(result)
}

# It calculates the learnability of a specific USER
calculateLearnability = function (list) {
	return((10 - list[[4]] - list[[10]]) * 12.5)
}

# It calculates the learnability dimension from SUS value of each user
calculateUsersLearnability = function (list) {
	result = data.frame()
	len = length(list[,1])
	for (i in 1:len) {
		result[paste("User",i,sep=""),1] = calculateLearnability(list[i,])
	}

	names(result) = "Learnability"
	return(result)
}

# It calculates the usability of a specific USER
calculateUsability = function (list) {
	userSUS = calculateSUS(list) / 2.5
	userLearn = calculateLearnability(list) / 12.5
	return((userSUS - userLearn) * 3.125)
}

# It calculates the usability dimension from SUS value of each user
calculateUsersUsability = function (list) {
	result = data.frame()
	len = length(list[,1])
	for (i in 1:len) {
		result[paste("User",i,sep=""),1] = calculateUsability(list[i,])
	}

	names(result) = "Usability"
	return(result)
}

# It calculates the basic statistics of SUS
summarise = function (data,text) {
	return(cat(
		"\n## ", text, ": basic statistics ##\n",
		"\tn. of " , text, " values: ", length(data[,1]), "\n",
		"\t", text, " mean: ", sapply(data,mean), "\n",
		"\tmedian: ", sapply(data,median), "\n",
		"\tmax: ", sapply(data,max), "\n",
		"\tmin: ", sapply(data,min), "\n",
		"\ts. deviation: ", sapply(data,sd), "\n",
		"\tvariance: ", sapply(data,var), "\n",
		"---------------------------------------\n",
		sep = ""
	));
}

# It calculates the ANOVA of the stack
anova = function (inputstack,text) {

	cat("\n\n# Homogeneity of variance for", text,"\n")
	# Check if the variance is homogeneous
	print(bartlett.test(values ~ ind, data=inputstack))

	cat("# ANOVA calculation of", text,"\n")
	m = aov(values ~ ind, data=inputstack)
	print(summary(m))

	cat("\n# Tukey of", text,"\n")
	print(TukeyHSD(m))
}

# It calculates the percentage values in a 1 to 5 range of values
percentage15 = function (dframe, text) {
	cat("\n\n## Percentage of", text)
	for (i in 1:length(dframe)) {
		cat("\n\n# Column",i,"percentage values")
		current_length = length(dframe[,i])
		for (j in 1:5) {
			count = length(which(dframe[,i] == j))
			cat("\nValue",j,"has percentage:",as.integer(round(count/current_length,2)*100),"% -",count,"out of",current_length)
		}
	}
	cat("\n\n")
}

### Operations ###

# Carica i dati dei questionari SUS dai CSV e vincola le variabili a R
sus = read.csv("sus.csv")
attach(sus)

# SUS
print("SUS")
usersSUS = calculateUsersSUS(sus)
usersLearn = calculateUsersLearnability(sus)
usersUsability = calculateUsersUsability(sus)
summarise(usersSUS, "SUS")
summarise(usersUsability, "Usability")
summarise(usersLearn, "Learnability")

background = read.csv("background.csv")
attach(background)

# Sub-values from questionaries
experience = as.data.frame(t(t(sapply(as.data.frame(t(background[,1:7])),sum))))

print("Pearson with full SUS")
print(cor.test(experience$V1,usersSUS$"SUS values"))

print("Pearson with Learnability")
print(cor.test(experience$V1,usersLearn$"Learnability"))

print("Pearson with Usability")
print(cor.test(experience$V1,usersUsability$"Usability"))

# Plot the diagrams of the aforementioned comparisons
par(mfrow=c(2,3))
plot(experience$V1,usersSUS$"SUS values",xlab="Experience score",ylab="SUS score",pch=16,col="blue",cex=2)
abline(lm(usersSUS$"SUS values"~experience$V1), col="red", cex=5, lty=2)

plot(experience$V1,usersLearn$"Learnability",xlab="Experience score",ylab="Learnability score",pch=16,col="blue",cex=2)
abline(lm(usersLearn$"Learnability"~experience$V1), col="red", cex=5, lty=2)

plot(experience$V1,usersUsability$"Usability",xlab="Experience score",ylab="Usability score",pch=16,col="blue",cex=2)
abline(lm(usersUsability$"Usability"~experience$V1), col="red", cex=5, lty=2)


library(scales)
library(zoo)

lh = read.csv("../dat/light.csv", header = TRUE)
pr = read.csv("../dat/prysm.csv", header = TRUE)
tk = read.csv("../dat/teku.csv", header = TRUE)
oe = read.csv("../dat/parity.csv", header = TRUE)

col_lh = c("#9e0142", "#d53e4f", "#f46d43")
col_tk = c("#003c30", "#01665e", "#35978f")
col_pr = c("#40004b", "#762a83", "#9970ab")
col_oe = c("#1a1a1a", "#4d4d4d", "#878787")

pairs(lh[,c(8, 4, 7, 2, 3, 6)], main="Lighthouse", pch=".", col=alpha(col_lh[3], 0.3))
pairs(pr[,c(8, 4, 7, 2, 3, 6)], main="Prysm", pch=".", col=alpha(col_pr[3], 0.3))
pairs(tk[,c(8, 4, 7, 2, 3, 6)], main="Teku", pch=".", col=alpha(col_tk[3], 0.3))

sync <- plot(lh$time, lh$slot, main="Synchronization Progress", xlab="Time [s]", ylab="Slot [1]", pch=".", col=alpha(col_lh[3], 0.3))
sync <- lines(pr$time, pr$slot, type="p", pch=".", col=alpha(col_pr[3], 0.3))
sync <- lines(tk$time, tk$slot, type="p", pch=".", col=alpha(col_tk[3], 0.3))
sync <- lines(lh$time, rollmean(lh$slot, 600, fill=list(NA, NULL, NA)), col=alpha(col_lh[2], 0.5))
sync <- lines(pr$time, rollmean(pr$slot, 600, fill=list(NA, NULL, NA)), col=alpha(col_pr[2], 0.5))
sync <- lines(tk$time, rollmean(tk$slot, 600, fill=list(NA, NULL, NA)), col=alpha(col_tk[2], 0.5))
sync <- text(6500, 180000, "1h 48min 59sec", cex=0.8, pos=4, col=col_lh[1])
sync <- text(30000, 170000, "8h 48min 8sec", cex=0.8, pos=4, col=col_tk[1])
sync <- text(70000, 160000, "23h 50min 3sec", cex=0.8, pos=4, col=col_pr[1])
sync <- text(70000, 20000, "--- Lighthouse", cex=0.8, pos=4, col=col_lh[2])
sync <- text(70000, 12000, "--- Teku", cex=0.8, pos=4, col=col_tk[2])
sync <- text(70000, 4000, "--- Prysm", cex=0.8, pos=4, col=col_pr[2])

dbt <- plot(pr$time, pr$db, main="Database Size", xlab="Time [s]", ylab="Database Size [B]", log="y", ylim=c(50000000,10000000000), pch=".", col=alpha(col_pr[3], 0.3))
dbt <- lines(tk$time, tk$db, type="p", pch=".", col=alpha(col_tk[3], 0.3))
dbt <- lines(lh$time, lh$db, type="p", pch=".", col=alpha(col_lh[3], 0.3))
dbt <- lines(lh$time, rollmean(lh$db, 600, fill=list(NA, NULL, NA)), col=alpha(col_lh[2], 0.5))
dbt <- lines(pr$time, rollmean(pr$db, 600, fill=list(NA, NULL, NA)), col=alpha(col_pr[2], 0.5))
dbt <- lines(tk$time, rollmean(tk$db, 600, fill=list(NA, NULL, NA)), col=alpha(col_tk[2], 0.5))
dbt <- text(70000, 100000000, "--- Prysm", cex=0.8, pos=4, col=col_pr[2])
dbt <- text(70000, 84000000, "--- Teku", cex=0.8, pos=4, col=col_tk[2])
dbt <- text(70000, 71000000, "--- Lighthouse", cex=0.8, pos=4, col=col_lh[2])

mem <- plot(pr$time, pr$mem, main="Resident Memory", xlab="Time [s]", ylab="Memory Usage [B]", log="y", ylim=c(50000000,10000000000), pch=".", col=alpha(col_pr[3], 0.3))
mem <- lines(tk$time, tk$mem, type="p", pch=".", col=alpha(col_tk[3], 0.3))
mem <- lines(lh$time, lh$mem, type="p", pch=".", col=alpha(col_lh[3], 0.3))
mem <- lines(lh$time, rollmean(lh$mem, 600, fill=list(NA, NULL, NA)), col=alpha(col_lh[2], 0.5))
mem <- lines(pr$time, rollmean(pr$mem, 600, fill=list(NA, NULL, NA)), col=alpha(col_pr[2], 0.5))
mem <- lines(tk$time, rollmean(tk$mem, 600, fill=list(NA, NULL, NA)), col=alpha(col_tk[2], 0.5))
mem <- text(70000, 100000000, "--- Prysm", cex=0.8, pos=4, col=col_pr[2])
mem <- text(70000, 84000000, "--- Teku", cex=0.8, pos=4, col=col_tk[2])
mem <- text(70000, 71000000, "--- Lighthouse", cex=0.8, pos=4, col=col_lh[2])

prs <- plot(lh$time, lh$peers, main="P2P Peer Count", xlab="Time [s]", ylab="Peer Count [1]", pch=".", col=alpha(col_lh[3], 0.3))
prs <- lines(pr$time, pr$peers, type="p", pch=".", col=alpha(col_pr[3], 0.3))
prs <- lines(tk$time, tk$peers, type="p", pch=".", col=alpha(col_tk[3], 0.3))
prs <- lines(lh$time, rollmean(lh$peers, 600, fill=list(NA, NULL, NA)), col=alpha(col_lh[2], 0.5))
prs <- lines(pr$time, rollmean(pr$peers, 600, fill=list(NA, NULL, NA)), col=alpha(col_pr[2], 0.5))
prs <- lines(tk$time, rollmean(tk$peers, 600, fill=list(NA, NULL, NA)), col=alpha(col_tk[2], 0.5))
prs <- text(70000, 10, "--- Lighthouse", cex=0.8, pos=4, col=col_lh[2])
prs <- text(70000, 8, "--- Prysm", cex=0.8, pos=4, col=col_pr[2])
prs <- text(70000, 6, "--- Teku", cex=0.8, pos=4, col=col_tk[2])

bps <- plot(lh$time, lh$bps_avg, main="Synchronization Speed", xlab="Time [s]", ylab="Slots per Second [1/s]", log="y", pch=".", col=alpha(col_lh[3], 0.3))
bps <- lines(pr$time, pr$bps_avg, type="p", pch=".", col=alpha(col_pr[3], 0.3))
bps <- lines(tk$time, tk$bps_avg, type="p", pch=".", col=alpha(col_tk[3], 0.3))
bps <- lines(lh$time, rollmean(lh$bps_avg, 600, fill=list(NA, NULL, NA)), col=alpha(col_lh[2], 0.5))
bps <- lines(pr$time, rollmean(pr$bps_avg, 600, fill=list(NA, NULL, NA)), col=alpha(col_pr[2], 0.5))
bps <- lines(tk$time, rollmean(tk$bps_avg, 600, fill=list(NA, NULL, NA)), col=alpha(col_tk[2], 0.5))
bps <- text(6500, 31, "29.127/s", cex=0.8, pos=4, col=col_lh[1])
bps <- text(31000, 7, "6.0767/s", cex=0.8, pos=4, col=col_tk[1])
bps <- text(78000, 3, "2.2953/s", cex=0.8, pos=4, col=col_pr[1])
bps <- text(70000, 50, "--- Lighthouse", cex=0.8, pos=4, col=col_lh[2])
bps <- text(70000, 43, "--- Teku", cex=0.8, pos=4, col=col_tk[2])
bps <- text(70000, 37, "--- Prysm", cex=0.8, pos=4, col=col_pr[2])

fin <- plot(lh$time, lh$bps_avg, main="The Final Chart", xlab="Time [s]", ylab="Blocks per Second [1/s]", log="y", ylim=c(1, 5000), pch=".", col=alpha(col_lh[3], 0.3))
fin <- lines(pr$time, pr$bps_avg, type="p", pch=".", col=alpha(col_pr[3], 0.3))
fin <- lines(tk$time, tk$bps_avg, type="p", pch=".", col=alpha(col_tk[3], 0.3))
fin <- lines(oe$time[1:60], oe$bps[1:60], type="p", pch=".", col=alpha(col_oe[3], 0.3))
fin <- lines(lh$time, rollmean(lh$bps_avg, 600, fill=list(NA, NULL, NA)), col=alpha(col_lh[2], 0.5))
fin <- lines(pr$time, rollmean(pr$bps_avg, 600, fill=list(NA, NULL, NA)), col=alpha(col_pr[2], 0.5))
fin <- lines(tk$time, rollmean(tk$bps_avg, 600, fill=list(NA, NULL, NA)), col=alpha(col_tk[2], 0.5))
fin <- lines(oe$time[1:60], rollmean(oe$bps[1:60], 120, fill=list(NA, NULL, NA)), col=alpha(col_oe[2], 0.5))
fin <- text(300, 1500, "1027.0/s", cex=0.8, pos=4, col=col_oe[1])
fin <- text(6500, 31, "29.127/s", cex=0.8, pos=4, col=col_lh[1])
fin <- text(31000, 7, "6.0767/s", cex=0.8, pos=4, col=col_tk[1])
fin <- text(78000, 3, "2.2953/s", cex=0.8, pos=4, col=col_pr[1])
fin <- text(55000, 2000, "--- OpenEthereum (ETH1)", cex=0.8, pos=4, col=col_oe[2])
fin <- text(55000, 1150, "--- Lighthouse (ETH2)", cex=0.8, pos=4, col=col_lh[2])
fin <- text(55000, 890, "--- Teku (ETH2)", cex=0.8, pos=4, col=col_tk[2])
fin <- text(55000, 700, "--- Prysm (ETH2)", cex=0.8, pos=4, col=col_pr[2])


# To analyze and process the output tos95day.rdata
# Run after climatology_OISST_95day_doall.r

################
# Reshape
# To run on laptop
###############
load('temp/tos95day.rdata')

# reorder dimensions
tos95day <- aperm(tos95day, c(2,1))

# rotate sst monthly temps 1986-2005 so columns 0 -> 360 lon (centered at Greenwich), rows 90 -> -90 lat (like cmip5)
nms <- dimnames(tos95day)
lons <- as.numeric(nms[[2]])
newlonord <- c(lons[lons>0], lons[lons<0])
newcolnms <- newlonord
newcolnms[newcolnms<0] <- newcolnms[newcolnms<0] + 360
newlonord <- as.character(newlonord)
newcolnms <- as.character(newcolnms)

lats <- as.numeric(nms[[1]])
newlatord <- sort(lats, decreasing=TRUE)
newrownms <- as.character(newlatord)
newlatord <- as.character(newlatord)

tos95day <- tos95day[newlatord, newlonord] # lat x lon (0-360)
dimnames(tos95day)[[2]] <- newcolnms

	image(tos95day)

save(tos95day, file='temp/tos95day.rdata')

#############
# Plot
#############
load('temp/tos95day.rdata')

image(tos95day)

###########################
# Compare 95% warmest day to warmest month and warmest day
###########################
require(raster)
load('temp/tos95day.rdata')

# to warmest month
	load('temp/sstclimatology_warmestmonth.rdata')

	range(tos95day - sstclimwarmestmo, na.rm=TRUE)
	summary(as.numeric(tos95day - sstclimwarmestmo))
	sum(as.numeric(tos95day - sstclimwarmestmo) < 0, na.rm=TRUE)/sum(!is.na(as.numeric(tos95day - tosmax)))

	rast <- raster(tos95day - sstclimwarmestmo, xmn=0, xmx=360, ymn=-90, ymx=90)
	plot(rast)

	# show values < 0
	rast2 <- raster((tos95day - sstclimwarmestmo)<0, xmn=0, xmx=360, ymn=-90, ymx=90)
	plot(rast2)

# to warmest day
	load('temp/tosmaxday.rdata')

	range(tos95day - tosmaxday, na.rm=TRUE)
	summary(as.numeric(tos95day - tosmaxday))
	sum(as.numeric(tos95day - tosmaxday) > 0, na.rm=TRUE)/sum(!is.na(as.numeric(tos95day - tosmax)))

	rast <- raster(tos95day - tosmaxday, xmn=0, xmx=360, ymn=-90, ymx=90)
	plot(rast)


read.data = function(experiment, hash) {
    assign("watermark", sprintf("%s / %s", experiment, hash), envir=.GlobalEnv)
    assign("data", read.csv(sprintf("tests/accuracy-%s-%s.csv", experiment, hash)), envir=.GlobalEnv)
    # this makes a nice mark for plotting
    data$lx = round(log10(data$q.raw/(1-data$q.raw)))

    assign("sizes", read.csv(sprintf("tests/accuracy-sizes-%s-%s.csv", experiment, hash)), envir=.GlobalEnv)
    sizes$center = with(sizes, (q.0 + q.1)/2)

    assign("cdf", read.csv(sprintf("tests/accuracy-cdf-%s-%s.csv", experiment, hash)), envir=.GlobalEnv)
}

#buckets = read.csv("accuracy-samples.csv")

plot.cdf = function(sortFlag="sorted", compression=100, dist="UNIFORM", digest="MERGE", alpha = 0.4, dx=0.000025, cex=1, add=F, col=rgb(1,0,0,alpha=alpha), bufferSize = NA, offset=0, ylim=c(-0.08,0.08), bars=5) {
    i = cdf$digest == digest & cdf$dist == dist & cdf$sort == sortFlag & cdf$compression == compression
    if (!is.na(bufferSize)) {
        i = i & cdf$bufferSize == bufferSize
    }
    n = length(table(cdf$q[i]))
    boxplot(error ~ q, cdf[i,], add=add, col=col, boxwex=1/(bars+1), at=1:n + offset/bars, xaxt='n', ylim=ylim)
    axis(side=1, at=1:n, labels=levels(factor(cdf$q[i])))
    title(watermark, line=-1-offset)
}

plot.fill = function(sortFlag="sorted", dist="UNIFORM", digest="MERGE", alpha = 0.4, dx=0.000025, cex=1, compression=100) {
    i = sizes$digest == digest & sizes$dist == dist & sizes$sort == sortFlag
    plot(count*compression/1e6/pi*2 ~ center, sizes[i,], pch=21, bg=rgb(0,0,0,alpha=alpha), col=NA, cex=cex)
    title(watermark, line=-2)
}

plot.dk = function(sortFlag="sorted", dist="UNIFORM", digest="MERGE", alpha = 0.4, dx=0.000025) {
    i = sizes$digest == digest & sizes$dist == dist & sizes$sort == sortFlag
    plot(dk ~ center, sizes[i,])
    title(watermark, line=-2)
}

plot.buckets = function(sortFlag="sorted", alpha = 0.4, clusters=1:7, emphasis=c(), xlim=c(0, 0.003), dx=0.000025, generation=3, digest="MERGE") {
    x.max = 0
    for (ix in clusters) {
        i = with(buckets, digest == digest & dist == "UNIFORM" & k == generation & sort == sortFlag)
        if (ix >= 0) {
            i = i & (buckets$centroid == ix)
        } else {
            i = i & (buckets$centroid == (max(buckets$centroid[i]) + ix + 1))
        }
        zx = buckets[i,]$x
        x.max = max(c(x.max, zx))
    }
    b = seq(0,1.1 * x.max,by=dx)

    colorIndex = rep(1:4, len=length(clusters))
    colors = c(rgb(1,0,0,alpha=alpha), rgb(0,1,0,alpha=alpha), rgb(0,0,1,alpha=alpha), rgb(0.5, 0.5, 0.5,alpha=alpha))[colorIndex]
    addFlag = F
    for (ix in rev(clusters)) {
        i = with(buckets, digest == digest & dist == "UNIFORM" & k == generation & sort == sortFlag)
        if (ix >= 0) {
            i = i & (buckets$centroid == ix)
        } else {
            i = i & (buckets$centroid == (max(buckets$centroid[i]) + ix + 1))
        }
        zx = buckets[i,]$x
        hist(zx, xlim=xlim, add=addFlag, breaks=b, col=colors[abs(ix)], border=rgb(0,0,0,alpha=0.1))
        addFlag = T
    }
    for (ix in emphasis) {
        i = with(buckets, digest == digest & dist == "UNIFORM" & k == generation & sort == sortFlag)
        if (ix >= 0) {
            i = i & (buckets$centroid == ix)
        } else {
            i = i & (buckets$centroid == (max(buckets$centroid[i]) + ix + 1))
        }
        data = buckets[i,]$x
        hist(data, add=T, breaks=b, col=colors[ix], border=colors[ix])
    }
    title(watermark, line=-2)
}


##
# calculates ratio of (M, B, C) speakers
# among rural, town, and urban residents
# with side-by-side plots for childhood vs. current residence
##

rm(list=ls())
library(dplyr)
library(tidyr)
library(ggplot2)

# read in data
source("inread.r")
lg <- inread("data/mbc_kid_cp.csv")
lg <- lg %>% select(Subject_Code, self.MBC)
almost_everything <- inread('data/2015_lmsim_data.csv')
df <- almost_everything %>%
  select(Subject_Code,
    Urban_Status.x, Urban_Status.y, Ethnicity) %>%
  inner_join(lg, by = "Subject_Code")

# cleaning: drop rows with missing Location, Language or Ethnicity
df$Urban_Status.x[df$Urban_Status.x %in% "UNKNOWN"] <- NA
df$Urban_Status.y[df$Urban_Status.y %in% "UNKNOWN"] <- NA
df <- na.omit(df)
df$Ethnicity <- NULL

# make ordered factors
df$self.MBC <- factor(df$self.MBC,
    levels=c("M", "B", "C"),
    ordered=TRUE)
orderXZC <- function(myvar){
  x <- factor(myvar,
    levels = c("XIANG_RURAL","ZHEN_TOWN","CHENG_CITY"),
    labels=c("Rural","Town","Urban"),
    ordered=TRUE)
  return(x)
}
df$Urban_Status.x <- orderXZC(df$Urban_Status.x)
df$Urban_Status.y <- orderXZC(df$Urban_Status.y)

# subset by time point to calculate probabilities
# childhood residence data
then <- df
then$Urban_Status.x <- NULL
then <- rename(then, Urban_Status = Urban_Status.y)
y <- as.data.frame(tally(na.omit(then) %>%
      group_by(Urban_Status, self.MBC))) %>%
      spread(self.MBC, n)
y[is.na(y)] <- 0
y$n <- with(y, M+B+C)
y$Mratio <- with(y, M/n)
y$Bratio <- with(y, B/n)
y$Cratio <- with(y, C/n)
then <- y %>% select(
        Urban_Status, n, Mratio, Bratio, Cratio)
rm(y)
# current residence data
now <- df
now$Urban_Status.y <- NULL
now <- rename(now, Urban_Status = Urban_Status.x)
x <- as.data.frame(tally(na.omit(now) %>%
      group_by(Urban_Status, self.MBC))) %>%
      spread(self.MBC, n)
x[is.na(x)] <- 0
x$n <- (x$M + x$B + x$C)
x$Mratio <- with(x, M/n)
x$Bratio <- with(x, B/n)
x$Cratio <- with(x, C/n)
now <- x %>% select(
        Urban_Status, n, Mratio, Bratio, Cratio)
rm(x)

# standard error
get.se <- function(df, col, n = "n"){
  p <- df[[col]]
  n <- df[[n]]
  x <- sqrt(p*(1-p)/n)
  return(x)
}

# reformat to long tables and calculate SE
probs <- gather(now, "outcome", "prob", 3:5)
probs$se <- get.se(probs, "prob", "n")
now <- probs
rm(probs)
probs <- gather(then, "outcome", "prob", 3:5)
probs$se <- get.se(probs, "prob", "n")
then <- probs
rm(probs)

# set ordering of M, B, C again
now$outcome <- factor(now$outcome,
              levels=c("Mratio", "Bratio", "Cratio"),
              ordered=TRUE)
then$outcome <- factor(then$outcome,
              levels=c("Mratio", "Bratio", "Cratio"),
              ordered=TRUE)
# combine THEN and NOW data
now$time <- "Current Residence"
then$time <- "Childhood Residence"
df <- rbind(then, now)
df$time <- factor(df$time,
          levels=c("Childhood Residence", "Current Residence"),
          ordered=TRUE)

# plotting function
lplot <- function(df){
  n <- sum(df$n)/6
  nphrase <- paste(
    "N =", n, "interviewees", sep = " ")
  pd <- position_dodge(.5)
  title <- paste(
    "Language repertoires of rural, town and urban residents",
    nphrase, sep="\n")
  X.lab <- "Residence Type"
  Y.lab <- "Proportion of M, B and C speakers"
  Mstyle <- "solid"
  Bstyle <- "solid"
  Cstyle <- "solid"
  errorcol <- "gray50" #dark gray
  Mcol <- "#404096"
  Bcol <- "#dea73a"
  Ccol <- "#d92120"
    ggplot(df, aes(x=Urban_Status, y=prob,
                  color=outcome, group=outcome)) +
    scale_colour_manual(
          values = c(Mcol, Bcol, Ccol),
          name = "Languages",
          labels = c("Mongolian only", "Bilingual", "Chinese only")) +
    geom_errorbar(aes(ymin=prob-se, ymax=prob+se),
                  width=.5, size=0.8,
                  colour=errorcol, linetype="solid", position=pd) +
    geom_line(position=pd, size=2) +
    geom_point(position=pd, size=2.5) +
    xlab(X.lab) + ylab(Y.lab) +
    ylim(0,1) +
    labs(title = title) +
    theme(axis.text=element_text(size=12),
          axis.title=element_text(size=12)) +
    theme(strip.text = element_text(size=12))
}

# make plot
p <-  lplot(df) + facet_wrap(~time)
f <-  "mbc_urbrur"
ggsave(plot=p, file=paste0("figures/",f,".pdf"),
        width=8, height=5, units="in")
ggsave(plot=p, file=paste0("figures/",f,".jpg"),
        width=8, height=5, units="in")

# save underlying data points
write.csv(df, file=paste0("analysis/",f,".csv"),
          fileEncoding = "UTF-8", row.names = FALSE)


################################################################################
# haplotypeDistMatrix function  - (matrix)
#
# Author: Heidi Lischer
# Date: 10.2008
################################################################################

haplotypeDistMatrix <- function(xmlText, Labels, timeAttr, outfile=outfiles){
  # convert string data (half matrix) to a numeric matrix ----------------------
  # split string -------
  tagData2 <- as.character(xmlText)

  tagData3 <- strsplit(tagData2, "\n")
  tagMatrix <- as.matrix(as.data.frame(tagData3))
  tagMatrix <- subset(tagMatrix, tagMatrix[,1] != "") #trim empty lines
  tagMatrix  <- gsub(" + ", " ", tagMatrix)   # trim white space
  Data <- strsplit(tagMatrix, " ")

  Row <- length(Data)

  # to numeric matrix ----------
  Matrix <- as.matrix(as.data.frame(Data[1]))
  Matrix <- subset(Matrix, Matrix[,1] != "")
  Matrix <- rbind(Matrix, matrix(NA, ncol=1, nrow=(Row-1)))
  numericList <- as.numeric(Matrix)
  numericMatrix <- t(as.matrix(numericList))

  for(n in 2:(Row)){
    nextrow <- as.matrix(as.data.frame(Data[n]))
    nextrow <- subset(nextrow, nextrow[,1] != "")
    nextrow <- rbind(nextrow, matrix(NA, ncol=1, nrow=(Row-n)))
    numericList <- as.numeric(nextrow)
    numericMatrix <- rbind(numericMatrix, t(as.matrix(numericList)))
  }

  # graphic---------------------------------------------------------------------
  # Mirror matrix (left-right)
  mirror.matrix <- function(x) {
    xx <- as.data.frame(x);
    xx <- rev(xx);
    xx <- as.matrix(xx);
    xx;
  }

  # Rotate matrix 270 clockworks
  rotate270.matrix <- function(x) {
    mirror.matrix(t(x))
  }

  DistanceMatrix <- rotate270.matrix(numericMatrix)

  nCol <- ncol(DistanceMatrix)
  nRow <- nrow(DistanceMatrix)

  # draw matrix plot---------------
   ColorRamp <- colorRampPalette(c("white", "steelblue1", "blue3"))

   outfileGraphic <- paste(outfile, "hapDistMatrix ", timeAttr, ".png", sep="")

   #save graphic
   png(outfileGraphic, width=1300, height=1300, res=144)

      smallplot <- c(0.874, 0.9, 0.18, 0.83)
      bigplot <- c(0.13, 0.85, 0.14, 0.87)

      old.par <- par(no.readonly = TRUE)

        #draw legend --------------------------------
        par(plt = smallplot)

        # get legend values
        Min <- min(DistanceMatrix, na.rm=TRUE)
        Max <- max(DistanceMatrix, na.rm=TRUE)
        binwidth <- (Max - Min) / 64
        y <- seq(Min + binwidth/2, Max - binwidth/2, by = binwidth)
        z <- matrix(y, nrow = 1, ncol = length(y))

        image(1, y, z, col = ColorRamp(64),xlab="", ylab="", axes=FALSE)

            # adjust axis if only one value exists
            if(Min == Max){
              axis(side=4, las = 2, cex.axis=0.8, at=Min, labels=round(Min, 2))
            } else {
              axis(side=4, las = 2, cex.axis=0.8)
            }

            box()
            mtext(text="Number of pairwise differences", side=4,line=2.2,font=2)

        #draw main graphic ------------------------------
        par(new = TRUE, plt = bigplot)

        image(c(1:nCol), c(1:nRow), DistanceMatrix, col=ColorRamp(64),
                main="Haplotype distance matrix", xlab="Haplotype",
                ylab="Haplotype", axes=FALSE)

            cexAxis <- 0.8
            if(nCol > 56) {
                cexAxis <- 0.7
            }

            axis(1, at = c(1:nCol),labels=c(Labels[1:ncol(Labels)]),
                   cex.axis=cexAxis, las=2)
            axis(2, at = c(1:nRow), labels=c(Labels[ncol(Labels):1]),
                   cex.axis=cexAxis, las=2)
            box()

      par(old.par)  #reset graphic parameters

   dev.off()

   return(numericMatrix)  #return matrix values

}


# Count every response in answers vector
answers <- c("Y", "N", "N", "Y", "Y")
answers_factor <- factor(answers)
levels(answers_factor) <- c("No", "Yes")
answers_count <- summary(answers_factor)

# Compares grades using ordered factor
grades <- c("A", "B", "C", "D", "E")
grades_factor <- factor(grades, ordered = TRUE, levels <- c("E", "D", "C", "B", "A"))
student_1 <- grades_factor[1]
student_2 <- grades_factor[2]
student_1 > student_2


library(tidyverse)
library(tidycensus)
library(tigris)
library(sf)

setwd("C:/Users/jdrew/Documents/Classes/SP20/GES 486/proj2")

noMOE <- function(x) {
  x[str_subset(names(x),"M$",negate=T)]
}

# Total Units, Occupied Units, Owner-Occupied Units, Median Household Income
dvars <- c("totalUnits"="DP04_0001E","occupUnits"="DP04_0045E",
          "ownOccUnits"="DP04_0046E")
bvars <- c("mhhi"="B19013_001E")

geo <- "tract"

md_cty <- read_sf("md_counties.gpkg")
md_shp <- read_sf("md_tracts.gpkg")

md_nowater <- md_shp %>% filter(ALAND > 0)

for(yr in 2010:2018) {
  tbl_d <- get_acs(geography = geo,
                         variables = dvars,
                         state = "MD",
                         year = yr,
                         output = "wide"
  )

  tbl_b <- get_acs(geography = geo,
                         variables = bvars,
                         state = "MD",
                         year = yr,
                         output = "wide"
  )

  out <- left_join(md_nowater["GEOID"],tbl_d,by="GEOID") %>%
    left_join(select(tbl_b,-NAME),by="GEOID") %>%
    noMOE() %>%
    mutate(ownOcc_total_pct = round(ownOccUnits / totalUnits * 100, 2)) #%>%
    #st_transform(3857)

  out$start <- yr
  out$end <- yr

  write_sf(out,paste0("geojs/output",yr,".geojson"))

}


context("rpart binning")

test_that("Test computing breaks on one variable", {
        dat <- data.frame(x=sample(-100:100, 201))
        dat$y <- factor(dat$x > 50 | dat$x < -10)

        obj <- binR(y~x, dat, algorithm="rpart")
        expect_equal(obj$breaks$x, c(-Inf,-10.5,50.5,Inf))
})

test_that("Test computing breaks on one variable all pos", {
        dat <- data.frame(x=sample(100))
        dat$y <- factor(dat$x > 50 | dat$x < 10)

        obj <- binR(y~x, dat, algorithm="rpart")
        expect_equal(obj$breaks$x, c(0,9.5,50.5,Inf))
})

test_that("Test computing breaks on one variable all neg", {
        dat <- data.frame(x=sample(-100:0, 101))
        dat$y <- factor(dat$x < -50 | dat$x > -10)

        obj <- binR(y~x, dat, algorithm="rpart")
        expect_equal(obj$breaks$x, c(-Inf,-50.5,-9.5,0))
})

test_that("Test computing breaks on two vars", {
        set.seed(11)
        dat <- data.frame(x1=sample(-100:100, 100),
                          x2=sample(100))
        dat$y <- factor(dat$x1 > 50 | dat$x1 + dat$x2 < -10 | dat$x2 > 50)

        obj <- binR(y~x1 + x2, dat, algorithm="rpart")
        expect_equal(obj$breaks$x1, c(-Inf, -40.5, -14.5, 29.5, 46.5, Inf))
        expect_equal(obj$breaks$x2, c(0.0, 21.5, 40.5, 50.5, Inf))
})


#' utci_class7
#'
#' Calculate 7-fold thermal classe by using value of  Universal Thermal Climate Index  UTCI index.
#'
#' @param t numeric  Air temperature in degC
#' @param rh numeric  Air Relative humidity in percentage.
#' @param wind numeric  Wind speed in meters per second
#' @param tmrt numeric  Mean radiant temperature in degC.
#' @return UTCI class
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  UTCI
#' @references Brode P,Jendritzky G,Fiala D and Havenith G, 2011,The Universal Thermal Climate Index UTCI in Operational Use".International Journal of Biometeorology.
#'
#'
#'
#' @export
#'

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


# Facets

# A. Facets layer
# 1. Basics
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Facet rows by am
  facet_grid(rows = vars(am))

ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Facet columns by cyl
  facet_grid(cols = vars(cyl))

ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Facet rows by am and columns by cyl
  facet_grid(rows = vars(am), cols = vars(cyl))

# 2. Many variables
# See the interaction column. Interaction is how the variables combined iteract with each other
mtcars$fcyl_fam

# Color the points by fcyl_fam
ggplot(mtcars, aes(x = wt, y = mpg, color = fcyl_fam)) +
  geom_point() +
  # Use a paired color palette
  scale_color_brewer(palette = "Paired")

# Update the plot. Final plot has seven variables from the original dataset included
ggplot(mtcars, aes(x = wt, y = mpg, color = fcyl_fam, size = disp)) +
  geom_point() +
  scale_color_brewer(palette = "Paired") +
  # Grid facet on gear and vs
  facet_grid(rows = vars(gear), cols = vars(vs))

# 3. Formula notation. This is the previous formula convention to create the facet grid plots. Making use of the vars() method is now preferred
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Facet rows by am using formula notation
  facet_grid(am ~ .)

ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Facet columns by cyl using formula notation
  facet_grid(. ~ cyl)

ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Facet rows by am and columns by cyl using formula notation
  facet_grid(am ~ cyl)

# B. Facets label and order
# 1. Labelling facets
# Plot wt by mpg
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Displaying both the values and the variables
  facet_grid(cols = vars(cyl), labeller = label_both)

# Plot wt by mpg
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Label context
  facet_grid(cols = vars(cyl), labeller = label_context)

# Plot wt by mpg
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Two variables. Both label values are added to avoid ambiguity
  facet_grid(cols = vars(vs, cyl), labeller = label_context)

# 2. Setting order
# Make factor, set proper labels explictly
mtcars$fam <- factor(mtcars$am, labels = c(`0` = "automatic",
                                           `1` = "manual"))

# Default order is alphabetical
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  facet_grid(cols = vars(fam))

# Make factor, set proper labels explictly, and
# manually set the label order
mtcars$fam <- factor(mtcars$am,
                     levels = c(1, 0),
                     labels = c("manual", "automatic"))

# View again
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  facet_grid(cols = vars(fam))

# C. Facets plotting spaces
# 1. Variable plotting spaces 1: continuous variables
ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Update the faceting to free the x-axis scales
  facet_grid(cols = vars(cyl), scales = "free_x")

ggplot(mtcars, aes(wt, mpg)) +
  geom_point() +
  # Swap cols for rows; free the y-axis scales
  facet_grid(rows = vars(cyl), scales = "free_y")

# 2. Variable plotting spaces 2: categorical variables
ggplot(mtcars, aes(x = mpg, y = car, color = fam)) +
  geom_point() +
  # Free the y scales and space. Works to clear blank spaces that have no value attached to them in the y axes labels
  facet_grid(rows = vars(gear), scales = "free_y", space = "free_y")

# D. Facet wraps and margins
# 1. Wrapping for many levels. Addition levels that can't fit on the same row will move to the next row
ggplot(Vocab, aes(x = education, y = vocabulary)) +
  stat_smooth(method = "lm", se = FALSE) +
  # Create facets, wrapping by year, using vars()
  facet_wrap(vars(year))

ggplot(Vocab, aes(x = education, y = vocabulary)) +
  stat_smooth(method = "lm", se = FALSE) +
  # Create facets, wrapping by year, using a formula
  facet_wrap(~ year)

ggplot(Vocab, aes(x = education, y = vocabulary)) +
  stat_smooth(method = "lm", se = FALSE) +
  # Update the facet layout, using 11 columns
  facet_wrap(~ year, ncol = 11)

# 2. Margin plots
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  # Update the facets to add margins. Will add a column / row with (all) of the data points
  facet_grid(rows = vars(fvs, fam), cols = vars(gear), margins = TRUE)

ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  # Update the facets to only show margins on fam
  facet_grid(rows = vars(fvs, fam), cols = vars(gear), margins = "fam")

ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  # Update the facets to only show margins on gear and fvs
  facet_grid(rows = vars(fvs, fam), cols = vars(gear), margins = c("gear", "fvs"))


setwd ("c://R")
SampleData=read.csv ("CleaningData.csv", header=TRUE,sep=";")
head(SampleData)
summary(SampleData)
SampleData

str(SampleData)
SampleData$right<-as.numeric(levels(SampleData$right))[SampleData$right]
SampleData

SampleData[SampleData==""]<-NA
summary(SampleData)

SampleData$right[SampleData$right == -19 ] <- NA
SampleData$right

is.na(SampleData)
which (is.na(SampleData))
which (is.na(SampleData), arr.ind=TRUE)

unique(unlist(lapply(SampleData, function (x) which (is.na (x)))))

SampleDataMinor<-na.omit(SampleData)
summary(SampleDataMinor)

is.nan(SampleData$right)

boxplot(SampleDataMinor,cex.axis=0.6,cex.lab=0.6)

boxplot.stats(SampleDataMinor$age)


'
The file "add_new_data.r" adds the new data from AJR (2005) to the
dataset as described in Albouy (2012).

'

source("project_paths.r")

library(foreign)

data <- read.dta(paste(PATH_IN_DATA, "ajrcomment.dta", sep="/"))

# Initilize new variables
data["logmort0_new"] = data$logmort0
data["campaign_new"] = data$campaign
data["source0_new"] = data$source0

# Adjust new variables
data[grep("HKG", data$shortnam),]$logmort0_new = log(285)
data[grep("BHS", data$shortnam),]$logmort0_new = log(189)
data[grep("AUS", data$shortnam),]$logmort0_new = log(14.1)
data[grep("HND", data$shortnam),]$logmort0_new = log(95.2)
data[grep("GUY", data$shortnam),]$logmort0_new = log(84)
data[grep("SGP", data$shortnam),]$logmort0_new = log(20)
data[grep("TTO", data$shortnam),]$logmort0_new = log(106.3)
data[grep("SLE", data$shortnam),]$logmort0_new = log(350)

data[grep("HKG", data$shortnam),]$source0_new = 1
data[grep("BHS", data$shortnam),]$source0_new = 1
data[grep("AUS", data$shortnam),]$source0_new = 1
data[grep("HND", data$shortnam),]$source0_new = 1
data[grep("GUY", data$shortnam),]$source0_new = 1
data[grep("SGP", data$shortnam),]$source0_new = 1
data[grep("TTO", data$shortnam),]$source0_new = 1
data[grep("SLE", data$shortnam),]$source0_new = 1

data[grep("HND", data$shortnam),]$campaign_new = 0

write.table(data, file = paste(PATH_OUT_DATA, "ajrcomment_all.txt", sep="/"))


#dod方法下的射出频率与参数之间的关系
#########说明########
#乙二醇液体
#voltage_pluse，说明高峰电压和基准电压下的射出时间ms
#duty_pluse，随着fv电压频率上升，占空比不同时的射出时间
#height，不同占空比下，随fv上升，弯月面高度的变化
#angle，同上，弯月面锥角的变化
#flowrate_pulse，不同占空比下，随流量变化的射出时间
#flowrate_height，此时的弯月面高度
#flowrate_angle，弯月面角度的变化
#setduty_pulse, 固定占空比为50%时，不同电压频率下，不同流量下的射出时间
#setduty_height，同上，弯月面高度
#setduty_angle，同上，弯月面锥角

#####第一组：随电压频率上升，不同占空比下的射出时间和弯月面信息#####
#####第二组：固定电压频率下，不同流量，不同占空比下的射出时间和弯月面信息####
#####第三组：固定占空比下，不同流量，不同电压频率的射出时间和弯月面信息####

#设定工作区间
setwd("D:/data")
library(xlsx)

fp<-read.xlsx("dod_v_pulse.xls", sheetName = "flowrate_pulse", header = TRUE)
fh<-read.xlsx("dod_v_pulse.xls", sheetName = "flowrate_height", header = TRUE)
fa<-read.xlsx("dod_v_pulse.xls", sheetName = "flowrate_angle", header  = TRUE)
#规划区域
par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(2,1,1,1))

#保存pdf
#pdf("dod_duty.pdf")

################################画图-流量与pulse射出时间的关系###########################
plot(fp$flowrate, fp$X0.1, col=0, xaxs="i", xlim=c(0, 0.001), ylim=c(0.34, 0.5),
xlab="Flow rate (ml/min)", cex.lab=1.2, ylab="Pulse time (ms)", main="Pulse time in various k", cex.main = 1.5)

model1 = loess(fp$X0.1~fp$flowrate)
lines(fp$flowrate,  model1$fit, col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

model2 = loess(fp$X0.2~fp$flowrate)
lines(fp$flowrate,  model2$fit, col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

model3 = loess(fp$X0.3~fp$flowrate)
lines(fp$flowrate,  model3$fit, col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

model4 = loess(fp$X0.5~fp$flowrate)
lines(fp$flowrate, model4$fit, col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

legend("bottomright", c("k=0.1", "k=0.2", "k=0.3", "k=0.5"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E"), pch=c(21,22,23, 24), lwd=1.5, lty=2, cex=1.2, bty="n")

################################画图-信息###########################

plot(fp$flowrate, fp$X0.1,  yaxt="n", xaxt= "n", col=0,  xlab="", ylab="", xlim=c(0,0.001), ylim=c(1, 3), main="Information", cex.main = 1.5)
text(0.00025, 2.8, "Liquids - Ethylene glycol", col="black", adj=0, cex=1.5)
text(0.00025, 2.5, "Distance - 1mm", col="black", adj=0, cex=1.5)
text(0.00025, 2.2, "Nozzle - 24G - 0.55mm", col="black", adj=0, cex=1.5)
text(0.00025, 1.9, "Flowrate -  0.0002ml/min", col="black", adj=0, cex=1.5)
text(0.00025, 1.6, "Voltage frequency - 20Hz", col="black", adj=0, cex=1.5)
text(0.00025, 1.3, "Duty cycle - 20%", col="black", adj=0, cex=1.5)

#legend("bottomleft", c("k=0.1", "k=0.2", "k=0.3", "k=0.5", "k=0.8"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=1.5, lty=2, cex=1.2, bty="n")

#################################画图--弯月面高度#############################
plot(fh$flowrate, fh$X0.1, col=0, xaxs="i", xlim=c(0, 0.001), ylim=c(0.3, 0.4),
xlab="Flow rate (ml/min)", cex.lab=1.2, ylab="Height of Meniscus (mm)", main="Meniscus height in various k", cex.main = 1.5)

lines(lowess(fh$flowrate, fh$X0.1), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(fh$flowrate, fh$X0.2), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(fh$flowrate, fh$X0.3), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(fh$flowrate, fh$X0.5), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

legend("bottomright", c("k=0.1", "k=0.2", "k=0.3", "k=0.5"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E"), pch=c(21,22,23,24), lwd=1.5, lty=2, cex=1.2, bty="n")

###############################画图--弯月面角度#############################
plot(fa$flowrate, fa$X0.1, col=0, xaxs="i",xlim=c(0, 0.001), ylim=c(65, 90),
xlab="Flow rate (ml/min)", cex.lab=1.2, ylab="Taylor fale (°)", main="Meniscus Angle in various k", cex.main = 1.5)

lines(lowess(fa$flowrate, fa$X0.1), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(fa$flowrate, fa$X0.2), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(fa$flowrate, fa$X0.3), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(fa$flowrate, fa$X0.5), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

legend("topright", c("k=0.1", "k=0.2", "k=0.3", "k=0.5"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E"), pch=c(21,22,23,24), lwd=1.5, lty=2, cex=1.2, bty="n")

#mtext("乙二醇 | H = 1mm | Nozzle 24G | Q = 0.0002ml/min | Fv = 20Hz | Duty = 20%", 1, line=1, col="black", cex=1.3, font=2, outer=TRUE)

#dev.off()


# initialize libraries
library(plyr)
library(digest)
library(reshape2)
library(ggplot2)
library("plot3D")

# useful functions

# calculate the distance between two sets of coordinates
dist3D <- function(coord1, coord2) { # vector X,Y,Z
        xdist <- coord1[1] - coord2[1] # could also write as coord1$X, etc.
        ydist <- coord1[2] - coord2[2]
        zdist <- coord1[3] - coord2[3]
        return(as.numeric(sqrt(xdist^2+ydist^2+zdist^2)))
}

# calculate the pairwise distance between an array of 3D coordinates
pairwise_dist3D <- function(temp_coords) { # labeled X,Y,Z
        N <- length(temp_coords$X)
        dist_vec <- rep(0,N) # create vector
        # TODO: some error checking
        sum_dist <- 0 # initialize to zero
        count <- 0
        for (i in 1:(N-1)) {
                for (j in (i+1):N) {
                        if (i != j) {
                                count <- count + 1
                                first_coord <- temp_coords[i,]
                                second_coord <- temp_coords[j,]
                                curr_dist <- dist3D(first_coord, second_coord)
                                sum_dist <- sum_dist + curr_dist
                                dist_vec[count] <- curr_dist
                        }
                }
        }
        return(c(as.numeric(mean(dist_vec)),as.numeric(sd(dist_vec))))
}

# initialize variables and load in raw fcsv data into df_raters
setwd('~/GitHub/afids-analysis/data/PHASE1_input_afid/')

df_afids <- read.table('~/GitHub/afids-analysis/etc/afids.csv', sep=",", header=TRUE)

df_raters <- data.frame(fid=integer(),X=double(),Y=double(),Z=double(),rater=factor(),
                        template=factor(),mri_type=factor(),session=integer(),date=integer(),
                        name=character(),description=character(),stringsAsFactors = FALSE)
csv_files <- list.files(".", "*.fcsv")

for (i in 1:length(csv_files)) {
    curr_split <- unlist(strsplit(csv_files[i],"_"))
    if (length(curr_split)>1) { # extract name and session data
        rater_template <- curr_split[1]
        rater_mri_type <- curr_split[2]
        rater_name <- curr_split[3]
        rater_session <- as.numeric(curr_split[4])
        rater_date <- as.numeric(unlist(strsplit(curr_split[5],"[.]"))[1])
    }
    curr_rater <- read.table(csv_files[i], header=FALSE, sep=",")
    df_rater <- data.frame(fid = 1:length(curr_rater$V1))

    df_rater <- cbind(df_rater,X=curr_rater[2],Y=curr_rater[3],Z=curr_rater[4],rater=rater_name,
                    template=rater_template,mri_type=rater_mri_type,
                    session=rater_session,date=rater_date,name=curr_rater[12],
                    description=curr_rater[13])

    df_rater <- rename(df_rater, c("V2"="X","V3"="Y","V4"="Z","V12"="name","V13"="description"))
    df_raters <- rbind(df_raters,df_rater)
}

levels(df_raters$rater) <- 1:8

# TODO: save df_raters as a file

# start by calculating mean coordinates
df_template_mean <- data.frame(fid=integer(),X=double(),Y=double(),Z=double(),
                        template=factor(), name=factor(),description=character(),stringsAsFactors = FALSE)
df_template_sd <- data.frame(fid=integer(),X=double(),Y=double(),Z=double(),
                        template=factor(), name=factor(),description=character(),stringsAsFactors = FALSE)

# iterate over each template and compute the mean and standard deviation
for (curr_template in levels(df_raters$template)) {
    for (i in 1:32) { # for each AFID32 point, calculate the mean
        df_subset <- subset(df_raters, fid == i & template == curr_template)
        curr_fid_name <- df_afids$name[i]
        curr_fid_desc <- df_afids$description[i]
        df_curr_fid <- data.frame(fid = i, X = mean(df_subset$X), Y = mean(df_subset$Y), Z = mean(df_subset$Z),
                        template=curr_template, name=curr_fid_name, description=curr_fid_desc)
        df_template_mean <- rbind(df_template_mean, df_curr_fid)
        df_curr_fid_sd <- data.frame(fid = i, X = sd(df_subset$X), Y = sd(df_subset$Y), Z = sd(df_subset$Z),
                        template=curr_template, name=curr_fid_name, description=curr_fid_desc)
        df_template_sd <- rbind(df_template_sd, df_curr_fid_sd)
    }
}

##########################################################################################
# Agile12v2016
##########################################################################################
df_Agile12v1_mean <- subset(df_template_mean, template == 'Agile12v2016')
df_Agile12v1_fcsv <- data.frame(id=paste('vtkMRMLMarkupsFiducialNode',df_Agile12v1_mean$fid,sep="_"),x=df_Agile12v1_mean$X,y=df_Agile12v1_mean$Y,z=df_Agile12v1_mean$Z,
                               ow=0,ox=0,oy=0,oz=1,
                               vis=1,sel=1,lock=0,label=df_Agile12v1_mean$fid,desc=df_Agile12v1_mean$description,
                               associatedNodeID='vtkMRMLScalarVolumeNode1',stringsAsFactors = FALSE)

# write out table (need to use file connection approach because of multiple header lines required by Slicer)
fio <- file('~/GitHub/afids-analysis/data/PHASE1_output_afid/Agile12v2016_MEAN.fcsv', open="wt") # TODO: link to output directory
  writeLines(paste('# Markups fiducial file version = 4.6'),fio)
  writeLines(paste('# CoordinateSystem = 0'),fio)
  writeLines(paste('# columns = id,x,y,z,ow,ox,oy,oz,vis,sel,lock,label,desc,associatedNodeID'),fio)
  write.table(df_Agile12v1_fcsv,fio,sep=',',quote=FALSE,col.names=FALSE,row.names=FALSE)
close(fio)

##########################################################################################
# Colin27
##########################################################################################
df_Colin27_mean <- subset(df_template_mean, template == 'Colin27')
df_Colin27_fcsv <- data.frame(id=paste('vtkMRMLMarkupsFiducialNode',df_Colin27_mean$fid,sep="_"),x=df_Colin27_mean$X,y=df_Colin27_mean$Y,z=df_Colin27_mean$Z,
                               ow=0,ox=0,oy=0,oz=1,
                               vis=1,sel=1,lock=0,label=df_Colin27_mean$fid,desc=df_Colin27_mean$description,
                               associatedNodeID='vtkMRMLScalarVolumeNode1',stringsAsFactors = FALSE)

# write out table (need to use file connection approach because of multiple header lines required by Slicer)
fio <- file('~/GitHub/afids-analysis/data/PHASE1_output_afid/Colin27_MEAN.fcsv', open="wt") # TODO: link to output directory
  writeLines(paste('# Markups fiducial file version = 4.6'),fio)
  writeLines(paste('# CoordinateSystem = 0'),fio)
  writeLines(paste('# columns = id,x,y,z,ow,ox,oy,oz,vis,sel,lock,label,desc,associatedNodeID'),fio)
  write.table(df_Colin27_fcsv,fio,sep=',',quote=FALSE,col.names=FALSE,row.names=FALSE)
close(fio)

##########################################################################################
# MNI152NLin2009bAsym
##########################################################################################
df_MNI2009b_mean <- subset(df_template_mean, template == 'MNI152NLin2009bAsym')
df_MNI2009b_fcsv <- data.frame(id=paste('vtkMRMLMarkupsFiducialNode',df_MNI2009b_mean$fid,sep="_"),x=df_MNI2009b_mean$X,y=df_MNI2009b_mean$Y,z=df_MNI2009b_mean$Z,
                               ow=0,ox=0,oy=0,oz=1,
                               vis=1,sel=1,lock=0,label=df_MNI2009b_mean$fid,desc=df_MNI2009b_mean$description,
                               associatedNodeID='vtkMRMLScalarVolumeNode1',stringsAsFactors = FALSE)

# write out table (need to use file connection approach because of multiple header lines required by Slicer)
fio <- file('~/GitHub/afids-analysis/data/PHASE1_output_afid/MNI152NLin2009bAsym_MEAN.fcsv', open="wt") # TODO: link to output directory
  writeLines(paste('# Markups fiducial file version = 4.6'),fio)
  writeLines(paste('# CoordinateSystem = 0'),fio)
  writeLines(paste('# columns = id,x,y,z,ow,ox,oy,oz,vis,sel,lock,label,desc,associatedNodeID'),fio)
  write.table(df_MNI2009b_fcsv,fio,sep=',',quote=FALSE,col.names=FALSE,row.names=FALSE)
close(fio)

df_raters$mean_AFLE <- NA # mean AFID localization error
df_raters$outlier <- NA
df_raters$xdist <- NA
df_raters$ydist <- NA
df_raters$zdist <- NA

for (i in 1:dim(df_raters)[1]) {
    curr_rater <- df_raters[i,]

    mean_raters <- df_MNI2009b_mean[curr_rater$fid,] # just so it's set to something for now

    #determine current template in order to assign the appropriate mean rater
    if (curr_rater$template == 'MNI152NLin2009bAsym') {
        mean_raters <- df_MNI2009b_mean[curr_rater$fid,]
    } else if (curr_rater$template == 'Agile12v2016') {
        mean_raters <- df_Agile12v1_mean[curr_rater$fid,]
    } else if (curr_rater$template == 'Colin27') {
        mean_raters <- df_Colin27_mean[curr_rater$fid,]
    } else {
        # unidentified template, e.g. MNI2009b
    }
    df_raters[i,]$xdist <- curr_rater$X - mean_raters$X
    df_raters[i,]$ydist <- curr_rater$Y - mean_raters$Y
    df_raters[i,]$zdist <- curr_rater$Z - mean_raters$Z
    curr_coords <- curr_rater[,2:4]
    mean_coords <- mean_raters[,2:4]
    df_raters[i,]$mean_AFLE <- dist3D(curr_coords, mean_coords)
    df_raters[i,]$outlier <- (df_raters[i,]$mean_AFLE > 10) # outliers > 10mm
}

# summary of findings

# Total: 1.27 +/- 1.98 mm; Outliers: 24/3072 (0.78%)
all_templates <- subset(df_raters, session > 0) # ignore session 0 which was from the group tutorial
num_outliers <- sum(subset(all_templates, outlier == TRUE)$outlier)
num_total <- length(all_templates$outlier)
sprintf( "Total: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(all_templates$mean_AFLE), sd(all_templates$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

# Agile12v1.0: 1.10 +/- 1.59 mm; Outliers: 3/1024 (0.29%)
curr_template <- subset(df_raters, session > 0 & template == 'Agile12v2016') # UHF == Agile12v1.0
num_outliers <- sum(subset(curr_template, outlier == TRUE)$outlier)
num_total <- length(curr_template$outlier)
sprintf( "Agile12v2016: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(curr_template$mean_AFLE), sd(curr_template$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

# Colin27: 1.71 +/- 2.78 mm; Outliers: 20/1024 (1.95%)
curr_template <- subset(df_raters, session > 0 & template == 'Colin27')
num_outliers <- sum(subset(curr_template, outlier == TRUE)$outlier)
num_total <- length(curr_template$outlier)
sprintf( "Colin27: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(curr_template$mean_AFLE), sd(curr_template$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

# MNI2009b: 0.99 +/- 1.11 mm; Outliers: 1/1024 (0.10%)
curr_template <- subset(df_raters, session > 0 & template == 'MNI152NLin2009bAsym')
num_outliers <- sum(subset(curr_template, outlier == TRUE)$outlier)
num_total <- length(curr_template$outlier)
sprintf( "MNI152NLin2009bAsym: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(curr_template$mean_AFLE), sd(curr_template$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

# summarize results for each fid and template

summary_all_df <- ddply(df_raters, .(fid), summarize, mean_total=mean(mean_AFLE), sd_total=sd(mean_AFLE), sum_outliers_total=sum(outlier))

summary_temp_df <- ddply(df_raters, .(fid,template), summarize, mean=mean(mean_AFLE), sd=sd(mean_AFLE), sum_outliers=sum(outlier))

# Agile12v2016
summary_all_df$mean_UHF <- subset(summary_temp_df, template == "Agile12v2016")$mean
summary_all_df$sd_UHF <- subset(summary_temp_df, template == "Agile12v2016")$sd
summary_all_df$sum_outliers_UHF <- subset(summary_temp_df, template == "Agile12v2016")$sum_outliers
# Colin27
summary_all_df$mean_Colin27 <- subset(summary_temp_df, template == "Colin27")$mean
summary_all_df$sd_Colin27 <- subset(summary_temp_df, template == "Colin27")$sd
summary_all_df$sum_outliers_Colin27 <- subset(summary_temp_df, template == "Colin27")$sum_outliers
# MNI152NLin2009bAsym
summary_all_df$mean_MNI2009b <- subset(summary_temp_df, template == "MNI152NLin2009bAsym")$mean
summary_all_df$sd_MNI2009b <- subset(summary_temp_df, template == "MNI152NLin2009bAsym")$sd
summary_all_df$sum_outliers_MNI2009b <- subset(summary_temp_df, template == "MNI152NLin2009bAsym")$sum_outliers

summary_all_df

# TODO: reformat and round off numbers for manuscript
write.table(summary_all_df, file = "~/GitHub/afids-analysis/tables/PHASE1_template_validation_afid_AFLE.csv", row.names = FALSE, quote = FALSE, sep = ",")

# now QC all the output
df_raters_QC <- subset(df_raters, outlier == FALSE)

# start by calculating mean coordinates
df_template_mean <- data.frame(fid=integer(),X=double(),Y=double(),Z=double(),
                        template=factor(), name=factor(),description=character(),stringsAsFactors = FALSE)
df_template_sd <- data.frame(fid=integer(),X=double(),Y=double(),Z=double(),
                        template=factor(), name=factor(),description=character(),stringsAsFactors = FALSE)

# iterate over each template and compute the mean and standard deviation
for (curr_template in levels(df_raters_QC$template)) {
    for (i in 1:32) { # for each AFID32 point, calculate the mean
        df_subset <- subset(df_raters_QC, fid == i & template == curr_template)
        curr_fid_name <- df_afids$name[i]
        curr_fid_desc <- df_afids$description[i]
        df_curr_fid <- data.frame(fid = i, X = mean(df_subset$X), Y = mean(df_subset$Y), Z = mean(df_subset$Z),
                        template=curr_template, name=curr_fid_name, description=curr_fid_desc)
        df_template_mean <- rbind(df_template_mean, df_curr_fid)
        df_curr_fid_sd <- data.frame(fid = i, X = sd(df_subset$X), Y = sd(df_subset$Y), Z = sd(df_subset$Z),
                        template=curr_template, name=curr_fid_name, description=curr_fid_desc)
        df_template_sd <- rbind(df_template_sd, df_curr_fid_sd)
    }
}

##########################################################################################
# Agile12v2016
##########################################################################################
df_Agile12v1_mean <- subset(df_template_mean, template == 'Agile12v2016')
df_Agile12v1_fcsv <- data.frame(id=paste('vtkMRMLMarkupsFiducialNode',df_Agile12v1_mean$fid,sep="_"),x=df_Agile12v1_mean$X,y=df_Agile12v1_mean$Y,z=df_Agile12v1_mean$Z,
                               ow=0,ox=0,oy=0,oz=1,
                               vis=1,sel=1,lock=0,label=df_Agile12v1_mean$fid,desc=df_Agile12v1_mean$description,
                               associatedNodeID='vtkMRMLScalarVolumeNode1',stringsAsFactors = FALSE)

# write out table (need to use file connection approach because of multiple header lines required by Slicer)
fio <- file('~/GitHub/afids-analysis/data/PHASE1_output_afid_postQC/Agile12v2016_MEAN_postQC.fcsv', open="wt")
  writeLines(paste('# Markups fiducial file version = 4.6'),fio)
  writeLines(paste('# CoordinateSystem = 0'),fio)
  writeLines(paste('# columns = id,x,y,z,ow,ox,oy,oz,vis,sel,lock,label,desc,associatedNodeID'),fio)
  write.table(df_Agile12v1_fcsv,fio,sep=',',quote=FALSE,col.names=FALSE,row.names=FALSE)
close(fio)

##########################################################################################
# Colin27
##########################################################################################
df_Colin27_mean <- subset(df_template_mean, template == 'Colin27')
df_Colin27_fcsv <- data.frame(id=paste('vtkMRMLMarkupsFiducialNode',df_Colin27_mean$fid,sep="_"),x=df_Colin27_mean$X,y=df_Colin27_mean$Y,z=df_Colin27_mean$Z,
                               ow=0,ox=0,oy=0,oz=1,
                               vis=1,sel=1,lock=0,label=df_Colin27_mean$fid,desc=df_Colin27_mean$description,
                               associatedNodeID='vtkMRMLScalarVolumeNode1',stringsAsFactors = FALSE)

# write out table (need to use file connection approach because of multiple header lines required by Slicer)
fio <- file('~/GitHub/afids-analysis/data/PHASE1_output_afid_postQC/Colin27_MEAN_postQC.fcsv', open="wt") # TODO: link to output directory
  writeLines(paste('# Markups fiducial file version = 4.6'),fio)
  writeLines(paste('# CoordinateSystem = 0'),fio)
  writeLines(paste('# columns = id,x,y,z,ow,ox,oy,oz,vis,sel,lock,label,desc,associatedNodeID'),fio)
  write.table(df_Colin27_fcsv,fio,sep=',',quote=FALSE,col.names=FALSE,row.names=FALSE)
close(fio)

##########################################################################################
# MNI2009b
##########################################################################################
df_MNI2009b_mean <- subset(df_template_mean, template == 'MNI152NLin2009bAsym')
df_MNI2009b_fcsv <- data.frame(id=paste('vtkMRMLMarkupsFiducialNode',df_MNI2009b_mean$fid,sep="_"),x=df_MNI2009b_mean$X,y=df_MNI2009b_mean$Y,z=df_MNI2009b_mean$Z,
                               ow=0,ox=0,oy=0,oz=1,
                               vis=1,sel=1,lock=0,label=df_MNI2009b_mean$fid,desc=df_MNI2009b_mean$description,
                               associatedNodeID='vtkMRMLScalarVolumeNode1',stringsAsFactors = FALSE)

# write out table (need to use file connection approach because of multiple header lines required by Slicer)
fio <- file('~/GitHub/afids-analysis/data/PHASE1_output_afid_postQC/MNI152NLin2009bAsym_MEAN_postQC.fcsv', open="wt") # TODO: link to output directory
  writeLines(paste('# Markups fiducial file version = 4.6'),fio)
  writeLines(paste('# CoordinateSystem = 0'),fio)
  writeLines(paste('# columns = id,x,y,z,ow,ox,oy,oz,vis,sel,lock,label,desc,associatedNodeID'),fio)
  write.table(df_MNI2009b_fcsv,fio,sep=',',quote=FALSE,col.names=FALSE,row.names=FALSE)
close(fio)

df_raters_QC$mean_AFLE <- NA # mean AFID localization error
df_raters_QC$outlier <- NA
df_raters_QC$xdist <- NA
df_raters_QC$ydist <- NA
df_raters_QC$zdist <- NA

for (i in 1:dim(df_raters_QC)[1]) {
    curr_rater <- df_raters_QC[i,]

    mean_raters <- df_MNI2009b_mean[curr_rater$fid,] # just so it's set to something for now

    #determine current template in order to assign the appropriate mean rater
    if (curr_rater$template == 'MNI152NLin2009bAsym') {
        mean_raters <- df_MNI2009b_mean[curr_rater$fid,]
    } else if (curr_rater$template == 'Agile12v2016') {
        mean_raters <- df_Agile12v1_mean[curr_rater$fid,]
    } else if (curr_rater$template == 'Colin27') {
        mean_raters <- df_Colin27_mean[curr_rater$fid,]
    } else {
        # unidentified template, e.g. MNI2009b
    }
    df_raters_QC[i,]$xdist <- curr_rater$X - mean_raters$X
    df_raters_QC[i,]$ydist <- curr_rater$Y - mean_raters$Y
    df_raters_QC[i,]$zdist <- curr_rater$Z - mean_raters$Z
    curr_coords <- curr_rater[,2:4]
    mean_coords <- mean_raters[,2:4]
    df_raters_QC[i,]$mean_AFLE <- dist3D(curr_coords, mean_coords)
    df_raters_QC[i,]$outlier <- (df_raters_QC[i,]$mean_AFLE > 10) # outliers > 10mm
}

# summary of findings

all_templates <- subset(df_raters_QC, session > 0) # ignore session 0 which was from the group tutorial
num_outliers <- sum(subset(all_templates, outlier == TRUE)$outlier)
num_total <- length(all_templates$outlier)
sprintf( "Total: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(all_templates$mean_AFLE), sd(all_templates$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

curr_template <- subset(df_raters_QC, session > 0 & template == 'Agile12v2016')
num_outliers <- sum(subset(curr_template, outlier == TRUE)$outlier)
num_total <- length(curr_template$outlier)
sprintf( "Agile12v2016: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(curr_template$mean_AFLE), sd(curr_template$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

curr_template <- subset(df_raters_QC, session > 0 & template == 'Colin27')
num_outliers <- sum(subset(curr_template, outlier == TRUE)$outlier)
num_total <- length(curr_template$outlier)
sprintf( "Colin27: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(curr_template$mean_AFLE), sd(curr_template$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

curr_template <- subset(df_raters_QC, session > 0 & template == 'MNI152NLin2009bAsym')
num_outliers <- sum(subset(curr_template, outlier == TRUE)$outlier)
num_total <- length(curr_template$outlier)
sprintf( "MNI152NLin2009bAsym: %.2f +/- %.2f mm; Outliers: %d/%d (%.2f%%)",
        mean(curr_template$mean_AFLE), sd(curr_template$mean_AFLE),
        num_outliers, num_total, (num_outliers/num_total)*100 )

# summarize results for each fid and template

summary_all_df <- ddply(df_raters_QC, .(fid), summarize, mean_total=mean(mean_AFLE), sd_total=sd(mean_AFLE), sum_outliers_total=sum(outlier))

summary_temp_df <- ddply(df_raters_QC, .(fid,template), summarize, mean=mean(mean_AFLE), sd=sd(mean_AFLE), sum_outliers=sum(outlier))
# Colin27
summary_all_df$mean_Colin27 <- subset(summary_temp_df, template == "Colin27")$mean
summary_all_df$sd_Colin27 <- subset(summary_temp_df, template == "Colin27")$sd
summary_all_df$sum_outliers_Colin27 <- subset(summary_temp_df, template == "Colin27")$sum_outliers
# MNI2009b
summary_all_df$mean_MNI2009b <- subset(summary_temp_df, template == "MNI152NLin2009bAsym")$mean
summary_all_df$sd_MNI2009b <- subset(summary_temp_df, template == "MNI152NLin2009bAsym")$sd
summary_all_df$sum_outliers_MNI2009b <- subset(summary_temp_df, template == "MNI152NLin2009bAsym")$sum_outliers
# UHF
summary_all_df$mean_UHF <- subset(summary_temp_df, template == "Agile12v2016")$mean
summary_all_df$sd_UHF <- subset(summary_temp_df, template == "Agile12v2016")$sd
summary_all_df$sum_outliers_UHF <- subset(summary_temp_df, template == "Agile12v2016")$sum_outliers

summary_all_df

# TODO: export table

df_rater_info <- read.table('~/GitHub/afids-analysis/etc/raters.csv', sep=",", header=TRUE)
df_rater_info

sprintf( "Imaging Experience: %.1f +/- %.1f months (Range: %.1f-%.1f)",
        mean(df_rater_info$imaging_exp), sd(df_rater_info$imaging_exp),
        range(df_rater_info$imaging_exp)[1], range(df_rater_info$imaging_exp)[2])
sprintf( "Neuroanatomy Experience: %.1f +/- %.1f months (Range: %.1f-%.1f)",
        mean(df_rater_info$neuro_exp), sd(df_rater_info$neuro_exp),
        range(df_rater_info$neuro_exp)[1], range(df_rater_info$neuro_exp)[2])
sprintf( "3D Slicer Experience: %.1f +/- %.1f months (Range: %.1f-%.1f)",
        mean(df_rater_info$slicer_exp), sd(df_rater_info$slicer_exp),
        range(df_rater_info$slicer_exp)[1], range(df_rater_info$slicer_exp)[2])

# subset for learning calculations (linear regression)
df_learning <- subset(df_raters_QC, session > 0)
l <- lm(mean_AFLE ~ session, data = df_learning)
s <- summary(l) # for session, the estimate was negative: -0.024 and non-significant: 0.1141
round(cbind(l$coeff,s$coefficients[,4]),4) # first column is the effect, second column is the pval

# no difference with mixed-effects modeling approach
#library(lme4)
#learning.lmer <- lmer(mean_AFLE ~ session + (1|rater), data = df_learning)
#summary(learning.lmer)
# no significant difference

# Did specific raters demonstrate any learning?
# create dataframe for linear model for each rater and p-values
models = dlply(df_learning, .(rater), lm, formula = mean_AFLE ~ session)
# also extract p-values for intercept and session
qual <- laply(models, function(mod) summary(mod)$coefficients[,4])

coefs = ldply(models, coef)
summary_learning_raters <- cbind(coefs,qual)
summary_learning_raters <- summary_learning_raters[,c(1,2,4,3,5)]
names(summary_learning_raters)[c(3,5)] <- c('pval_(Intercept)','pval_session')

# FDR correction
summary_learning_raters$pval_session_adjusted <- p.adjust(summary_learning_raters$pval_session, "fdr")
summary_learning_raters$pval_session_significant <- (summary_learning_raters$pval_session_adjusted < 0.05)

# Display the table
# TODO: also export the table
summary_learning_raters

# Did raters improve placing specific AFIDs?
# create dataframe for linear model for each rater and p-values
models = dlply(df_learning, .(fid), lm, formula = mean_AFLE ~ session)
# also extract p-values for intercept and session
qual <- laply(models, function(mod) summary(mod)$coefficients[,4])

coefs = ldply(models, coef)
summary_learning_afids <- cbind(coefs,qual)
summary_learning_afids <- summary_learning_afids[,c(1,2,4,3,5)]
names(summary_learning_afids)[c(3,5)] <- c('pval_(Intercept)','pval_session')

# FDR correction
summary_learning_afids$pval_session_adjusted <- p.adjust(summary_learning_afids$pval_session, "fdr")
summary_learning_afids$pval_session_significant <- (summary_learning_afids$pval_session_adjusted < 0.05)

# Display the table
# TODO: also export the table
summary_learning_afids

# intra-rater AFLE
#   defined here as mean pairwise distance between AFIDs placed by the same rater
df_intrarater <- data.frame(fid=integer(),
                 rater=factor(),
                 template=factor(),
                 intrarater_mean=double(),
                 intrarater_sd=double(),
                 stringsAsFactors=FALSE)

for (curr_template in levels(df_raters_QC$template)) {
        for (curr_rater in levels(df_raters_QC$rater)) {
                for (curr_fid in 1:32) {
                        curr_coords <- subset(df_raters_QC, rater == curr_rater & fid == curr_fid & template == curr_template & session > 0 & outlier == FALSE)
                        if (length(curr_coords$fid) > 0) {
                                curr_output <- pairwise_dist3D(curr_coords[,2:4])
                                curr_df <- data.frame(fid = curr_fid, rater = curr_rater, template = curr_template, intrarater_mean = curr_output[1], intrarater_sd = curr_output[2])
                                df_intrarater <- rbind(df_intrarater, curr_df)
                        }
                }
        }
}

# exploration of intra-rater AFLE data

# summary of findings
df_intrarater_summary <- ddply(df_intrarater, .(template), summarize, mean=mean(intrarater_mean), sd=sd(intrarater_mean))
df_intrarater_Colin27 <- ddply(subset(df_intrarater, template == "Colin27"), .(fid), summarize, mean_Colin27=mean(intrarater_mean), sd_Colin27=sd(intrarater_mean))
df_intrarater_ICBM2009b <- ddply(subset(df_intrarater, template == "MNI152NLin2009bAsym"), .(fid), summarize, mean_ICBM2009b=mean(intrarater_mean), sd_ICBM2009b=sd(intrarater_mean))
df_intrarater_Agile12v1 <- ddply(subset(df_intrarater, template == "Agile12v2016"), .(fid), summarize, mean_Agile12v1=mean(intrarater_mean), sd_Agile12v1=sd(intrarater_mean))
df_intrarater_total <- ddply(df_intrarater, .(fid), summarize, mean_total=mean(intrarater_mean), sd_total=sd(intrarater_mean))

df_intrarater_summary_all <- merge(df_intrarater_Agile12v1, df_intrarater_Colin27)
df_intrarater_summary_all <- merge(df_intrarater_summary_all, df_intrarater_ICBM2009b)
df_intrarater_summary_all <- merge(df_intrarater_summary_all, df_intrarater_total)

df_intrarater_summary
round(df_intrarater_summary_all,2)

sprintf( "Intra-Rater AFLE: %.1f +/- %.1f mm",
        mean(df_intrarater$intrarater_mean), sd(df_intrarater$intrarater_mean))

# inter-rater AFLE
#   defined here as the mean pairwise distance between mean intra-rater AFID coordinates
df_meanrater <- ddply(subset(df_raters_QC, session > 0), .(template,rater,fid), summarize, X=mean(X), Y=mean(Y), Z=mean(Z))

df_interrater <- data.frame(fid=integer(),
                            template=factor(),
                            interrater_mean=double(),
                            interrater_sd=double(),
                            stringsAsFactors=FALSE)

for (curr_template in levels(df_raters_QC$template)) {
        for (curr_fid in 1:32) {
                curr_coords <- subset(df_meanrater, fid == curr_fid & template == curr_template)
                if (length(curr_coords$fid) > 0) {
                        curr_output <- pairwise_dist3D(curr_coords[,4:6]) # careful here as index can shift.
                        curr_df <- data.frame(fid = curr_fid, template = curr_template, interrater_mean = curr_output[1], interrater_sd = curr_output[2])
                        df_interrater <- rbind(df_interrater, curr_df)

                }
        }
}

# exploration of inter-rater AFLE data
# summary of findings
df_interrater_summary <- ddply(df_interrater, .(template), summarize, mean=mean(interrater_mean), sd=sd(interrater_mean))

df_interrater_Colin27 <- subset(df_interrater, template == "Colin27")
names(df_interrater_Colin27)[3:4] <- c("mean_Colin27","sd_Colin27")
df_interrater_Colin27 <- df_interrater_Colin27[,c(1,3,4)]

df_interrater_ICBM2009b <- subset(df_interrater, template == "MNI152NLin2009bAsym")
names(df_interrater_ICBM2009b)[3:4] <- c("mean_MNI152NLin2009bAsym","sd_MNI152NLin2009bAsym")
df_interrater_ICBM2009b <- df_interrater_ICBM2009b[,c(1,3,4)]

df_interrater_Agile12v1 <- subset(df_interrater, template == "Agile12v2016")
names(df_interrater_Agile12v1)[3:4] <- c("mean_Agile12v2016","sd_Agile12v2016")
df_interrater_Agile12v1 <- df_interrater_Agile12v1[,c(1,3,4)]

df_interrater_total <- ddply(df_interrater, .(fid), summarize, mean_total=mean(interrater_mean), sd_total=sd(interrater_mean))

df_interrater_summary_all <- merge(df_interrater_Agile12v1, df_interrater_Colin27)
df_interrater_summary_all <- merge(df_interrater_summary_all, df_interrater_ICBM2009b)
df_interrater_summary_all <- merge(df_interrater_summary_all, df_interrater_total)

df_interrater_summary
round(df_interrater_summary_all,2)

sprintf( "Inter-Rater AFLE: %.1f +/- %.1f mm",
        mean(df_interrater$interrater_mean), sd(df_interrater$interrater_mean))

# ANOVA for templates
res.aov <- aov(mean_AFLE ~ template, data = df_raters_QC)
summary(res.aov)[[1]][[1,"F value"]]
summary(res.aov)[[1]][[1,"Pr(>F)"]]

# analysis of variance across templates and fids
summary_anova_templates <- ddply(df_raters_QC, "fid", summarise,
      Fval = summary(aov(mean_AFLE ~ template))[[1]][[1,"F value"]],
      pval = summary(aov(mean_AFLE ~ template))[[1]][[1,"Pr(>F)"]]
      )
summary_anova_templates$adjusted <- p.adjust(summary_anova_templates$pval, "fdr")
summary_anova_templates$significant <- (summary_anova_templates$adjusted < 0.05)

# display
# TODO: also export the table
summary_anova_templates

# PCA + K-means clustering
# set the variables up
fid_pca <- ddply(df_raters_QC, "fid", summarise,
                           eval1 = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$importance[2,1],
                           eval2 = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$importance[2,2],
                           eval3 = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$importance[2,3],
                           evec1x = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[1,1],
                           evec1y = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[2,1],
                           evec1z = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[3,1],
                           evec2x = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[1,2],
                           evec2y = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[2,2],
                           evec2z = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[3,2],
                           evec3x = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[1,3],
                           evec3y = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[2,3],
                           evec3z = summary(prcomp(cbind(xdist,ydist,zdist), center=TRUE, scale. = TRUE))$rotation[3,3]
)

# create clusters
fid_pca$kmeans2 <- kmeans( fid_pca[,2:4], 2 )$cluster
fid_pca$kmeans3 <- kmeans( fid_pca[,2:4], 3 )$cluster
fid_pca$kmeans4 <- kmeans( fid_pca[,2:4], 4 )$cluster
fid_pca$kmeans5 <- kmeans( fid_pca[,2:4], 5 )$cluster
fid_pca$kmeans6 <- kmeans( fid_pca[,2:4], 6 )$cluster

# map cluster corresponding to kmeans clustering
df_raters_QC$kmeans2 <- fid_pca$kmeans2[df_raters_QC$fid]
df_raters_QC$kmeans3 <- fid_pca$kmeans3[df_raters_QC$fid]
df_raters_QC$kmeans4 <- fid_pca$kmeans4[df_raters_QC$fid]
df_raters_QC$kmeans5 <- fid_pca$kmeans5[df_raters_QC$fid]
df_raters_QC$kmeans6 <- fid_pca$kmeans6[df_raters_QC$fid]

# a template for the scatterplots
# show displacement positions for each fid
par( mfrow=c(4,8), mar = c(0.2,0.2,0.2,0.2), # margins between plots
     oma = c(2,2,2,2), # outer margines
     mgp = c(1,1,0),
     xpd = NA ) #oma = outer margins
for(i in 1:32) {
        scatter3D(x = 0, y = 0, z = 0, bty = "b2", colkey = FALSE, alpha = 0,
                  main = sprintf("%d", i), xlim = c(-2.5,2.5), ylim = c(-2.5,2.5), zlim = c(-2.5,2.5),
                  pch = 20, phi = 30, theta = 40, pch = 19, cex = 1, col = df_raters_QC$kmeans3[i]+1 )
}

# figure
# show displacement positions for each fid
# K-means clustering with k = 3; tried 2-6 but 3 appeared most optimal
par( mfrow=c(4,8), mar = c(0.2,0.2,0.2,0.2), # margins between plots
                   oma = c(2,2,2,2), # outer margines
                   mgp = c(1,1,0),
                   xpd = NA ) #oma = outer margins
for(i in 1:32) {
        df_fid <- subset(df_raters, fid == i)
        scatter3D( df_fid$xdist, df_fid$ydist, df_fid$zdist, bty = "b2", colkey = FALSE, alpha = 1,
                   main = sprintf("%d", i), xlim = c(-2.5,2.5), ylim = c(-2.5,2.5), zlim = c(-2.5,2.5),
                   pch = 20, phi = 30, theta = 40, col = df_raters_QC$kmeans3[i]+1)
}

#figure with cluster colouring

# melt / modify existing dataframe for looking at clusters
fid_pca_simple <- fid_pca[,c("fid","eval1","eval2","eval3","kmeans3")]
melted <- melt(fid_pca_simple,id.vars=c("fid","kmeans3"))
levels(melted$variable) <- 1:3 # rename/refactor variables to numeric
colnames(melted)[3] <- 'PC'

ggplot(melted, aes(x = PC, y = value, group = fid, colour = as.factor(kmeans3))) +
        geom_line() +
        geom_point() +
        scale_colour_manual("Cluster", breaks = c(1,2,3), values = c("red", "green", "blue")) +
        scale_x_discrete("Principal Component") +
        scale_y_continuous("Variance Explained") +
        theme_bw() + theme(legend.position="bottom")

# TODO: K-means for individual templates

sessionInfo()


# R Code
# Regressors
# L. Garcia, A. Lorena, M. de Solto 2017
# Supervised Learning - Regressors

DWNN <- function(tech, tran, test) {
  model = kknn(tech, tran, test, kernel="gaussian")
  model$fitted.values
}

RF <- function(tech, tran, test) {
  model = randomForest(tech, tran)
  as.numeric(predict(model, test))
}

SVR <- function(tech, tran, test) {
  model = svm(tech, tran, scale=TRUE, type="eps-regression", kernel="radial")
  as.numeric(predict(model, test))
}

Random <- function(tech, tran, test) {
  tech = strsplit(as.character(tech), " ~ ")[[2]]
  sample(tran[,tech], 1)
}

Default <- function(tech, tran, test) {
  tech = strsplit(as.character(tech), " ~ ")[[2]]
  mean(tran[,tech])
}

mse <- function(tech, test, pred) {
  tech = strsplit(as.character(tech), " ~ ")[[2]]
  as.numeric((pred - test[,tech])^2)
}

prediction <- function(tech, tran, test) {
  sapply(REGRESSORS, function(r) {
    eval(call(r, tech, tran, test))
  })
}

evaluation <- function(tech, tran, test) {
  sapply(REGRESSORS, function(r) {
    pred = eval(call(r, tech, tran, test))
    mse(tech, test, pred)
  })
}


rm(list=ls())
source("chartr-ModelSelection.r")

VERBOSE = TRUE;

### Example usage ###
# 1. First load the models into the R workspace. taken from modelSuccess.r
# We could probably make a simpler version of this step, so that the
# emphasis remains on the second step.

dataDir = "colgrid/"
resultsDir = 'colgrid_Fits/'
subjnam = "Olaf.Rdata"

load(paste(dataDir,subjnam,sep=""))
N = sum(dat$n)

allValidModels = returnListOfModels()
modelList = unname(allValidModels$modelNames)

# Use for figures 9a, b in the paper
#modelList = c("DDM", "DDMSt","DDMSv","DDMSvSz","DDMSvSt","DDMSvSzSt",
#             "cDDM","cDDMSvSt", "cDDMSvSzSt","cDDMSv", "cDDMSt",
#             "cfkDDM",  "cfkDDMSt", "cfkDDMSvSzSt", "cfkDDMSvSt",
#            "uDDM", "uDDMSt","uDDMSvSb", "uDDMSvSbSt", "uDDMSvSt","uDDMSv")

#modelList = c('DDM','DDMSt','DDMSvSz','DDMSv','UGM','bUGM', 'bUGMSt',
  #            'bUGMSvSb','UGMSv','bUGMSv','UGMSt',
#              'bUGMSvSt','bUGMSvSbSt','UGMSvSt','DDMSvSt','DDMSvSzSt')

#modelList = c("DDM","DDMSv","DDMSvSz", "UGM","UGMSv",
              #"bUGM","bUGMSv","bUGMSvSb","uDDM","uDDMSv","uDDMSvSb",
              #"cDDM","cDDMSv","cDDMSvSz",
              #"cfkDDM")

modelOutput=list()
# load each model's output and store in modelOutput
nreps = 10;
allRuns = letters[c(1:nreps)];
tempReObj = seq(1,length(allRuns))

modelResults = data.frame(matrix(0,length(modelList), nreps+1));
rownames(modelResults) = modelList;
validNames = allRuns;
validNames[length(allRuns)+1] = "best";
colnames(modelResults) = validNames;

for(b in seq(1,length(modelList)))
{

  model = modelList[b]
  # Pick best fit from the lot
  bestfit=-Inf ; uselet=NULL # Fits cannot be worse than -Inf

  if(VERBOSE)
    cat(sprintf("\n%15s: ", model))

    # cat(paste("\n", "Model:", model,"\t"));
  for(m in seq(1,length(allRuns)))
  {
    fnam = allRuns[m];
    fileName = paste(resultsDir,subjnam,"-",model,"-",fnam,sep="") ;
    if(file.exists(fileName))
    {

      load(fileName)
      modelResults[model, fnam] = out$reobj;
      if(VERBOSE)
      {
        cat(paste(fnam, ":", round(out$reobj,0), ","));
        # cat(sprintf("%3.2f",out$pars["v1"]))
      }

      # Pick best model fit from each iteration
      if(out$reobj>bestfit)
      {
        # If fit for the current letter is better than the other fit, then
        # use this letter

        bestfit=out$reobj ;
        uselet=fnam;
        modelOutput[[model]]=out;
        modelResults[model,"best"] = bestfit;
      }
      # Finish selecting
    }
    else
    {
      print(paste("Model:",model,'-',fnam, " not found",sep=""))
    }

  }
  if(VERBOSE)
    cat(paste("choosing ", uselet))
}

s = order(-modelResults[,"best"])
modelResults = modelResults[s,]

useggplot =TRUE;

if(useggplot)
{
  source("prettyModelPlot.r")
}else
{
  par(mfrow=c(1,2))
  source("standardModelPlot.r")
}

#


# Get plot- and site-level hierarchical means of cosmopolitan phyla from rel abundances at NEON cores
# top 15 phyla
# clear workspace, load libraries
rm(list=ls())
library(runjags)
library(foreach)
library(doParallel)
source('paths.r')
source('paths_fall2019.r')
source('NEFI_functions/tic_toc.r')
#source('NEFI_functions/hierarch_ddirch_means.r')

# source hierarch means function
library(RCurl)
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/hierarch_ddirch_means.r", ssl.verifypeer = FALSE)
eval(parse(text = script))
# colin's paths.R
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/paths.r", ssl.verifypeer = FALSE)
eval(parse(text = script))

tic()

#set output.path----
output.path <- NEON_phylo_fg_plot.site_obs_16S.path

#load data and format.----
d <- readRDS(NEON_16S_phylo_fg_abundances.path)

#register parallel environment.----
n.cores <- detectCores()
n.cores <- 16
registerDoParallel(n.cores)

#loop over levels.----
output <- list()
output <-
  foreach(i = 1:length(d)) %dopar% {
    #Get y multivariate matrix.
    abundances <- d[[i]]$abundances
    abundances <- abundances[, colSums(abundances != 0) > 0] # remove empty "other" column
    y <- as.matrix((abundances + 1) / rowSums(abundances + 1)) # need to change this

    #get core_plot and plot_site indexing.
    core_plot <- substr(rownames(y), 1, 8)
    core_site <- substr(rownames(y), 1, 4)
    plot_site <- unique(core_plot)
    plot_site <- substr(plot_site, 1, 4)

    #fit the hierarchical means.
    fit <- hierarch_ddirch_means(y=y, core_plot = core_plot, plot_site = plot_site, jags.method = 'parallel')

    #add row and column names - plot level (you should put this in the function).
    for(j in 1:length(fit$plot.fit)){
      rownames(fit$plot.fit[[j]]) <- unique(core_plot)
      rownames(fit$site.fit[[j]]) <- unique(plot_site)
      colnames(fit$plot.fit[[j]]) <- colnames(y)
      colnames(fit$site.fit[[j]]) <- colnames(y)
    }
    fit$core.fit <- y #add in the core-level data!
    return(fit)
  }
names(output) <- names(d)

#save matrix lists.----
saveRDS(output, output.path)
cat('Script complete. ');
toc()


context("Boxplot")

# thanks wch for providing the test code
test_that("geom_boxplot range includes all outliers", {
  dat <- data.frame(x=1, y=c(-(1:20)^3, (1:20)^3) )
  p <- ggplot_build(ggplot(dat, aes(x,y)) + geom_boxplot())

  miny <- p$panel$ranges[[1]]$y.range[1]
  maxy <- p$panel$ranges[[1]]$y.range[2]

  expect_true(miny <= min(dat$y))
  expect_true(maxy >= max(dat$y))
})