#####################  Data pre-processing ######################

setwd(.WD)
source("functions.r")

.rnam <- row.names(trs)
.nam <- names(trs)
n <- length(.rnam); p <- length(.nam)

cat("The column(variable) names: \n")

for (i in 1:p) cat(i,.nam[i],'\t', fill=T)

.read()
cat("The row(sample) names: \n")
for (i in 1:n) cat(i,.rnam[i],'\t', fill=T)
sprintf("There are %d rows and %d columns involved",length(.rnam),length(.nam))
.read()

.stay = 1; .colGrou <- .colGeo <- .colInd <- .opt <- 0
while(.stay == 1){
cat("1. I want to specify the grouping information\n")
cat("2. I want to specify the spatial coordinates\n")
cat("3. I want to select/drop some columns\n")
cat("4. I want to continue\n")
.ans <- .scanf(1,c(1:4))

if(.ans == 1){
  cat("Choose the number of the column for location grouping variable:\n")
  .colGrou <- .scanf(1,c(0:ncol(trs))); cat('Done\n\n')
}
if(.ans == 2){
  cat("Choose the number of the column for spatial coordinates:\n")
  .colGeo <- .scanf(1,c(0:ncol(trs)));  cat('Done\n\n')
}
if(.ans == 3){
  cat("I want to: 1.select  -1.drop\n")
  .opt <- .scanf(1,c(-1,1))
  cat("Which columns do you want to select or drop? Separated by space. for example: 2 3\n")
  .colInd <- .scanf(1,c(1:ncol(trs)));  cat('Done\n\n')
}
if(.ans == 4){.stay <- 0}
}

if(.opt > 0)  .Mtrs <- (trs[,c(.opt*.colInd)])
if(.opt < 0)  .Mtrs <- (trs[,c(-.colGrou, -.colGeo, .opt*.colInd)])
if(.opt == 0){
if(!all(.colGrou==0))  .Mtrs <- (trs[,c(-.colGrou, -.colGeo)])
if(all(.colGrou==0)) .Mtrs <- (trs)
}

.geo <- .grou <- NULL
if(!all(.colGrou==0)) .grou <- trs[.colGrou]
if(!all(.colGeo==0)) .geo <- as.matrix(trs[,.colGeo])

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

source('missing.r')

source('censor.r')

####################  numeric data type encoding  ############
p <- dim(.Mtrs)[2]
.PM <- matrix(as.numeric(.Mtrs),ncol=p)

n <- dim(.PM)[1]; p <- dim(.PM)[2]

.attriind <- as.numeric(na.action(na.omit(.PM)))
dat <- as.data.frame(na.omit(.PM))
names(dat) <- .attri
if(length(.attriind)) .sites <- .sites[-.attriind]

#####################  data transformation  ##################
.stay <- 1
while(.stay == 1){
.ndat <- as.matrix(dat)
p<-ncol(dat)
.pp <- .optmn(p); .SW <- numeric(p)
palette("default")
par(mfrow=c(.pp[1],.pp[2]), yaxt="n", cex.main=.7,
      mar=c(5,4,4,2)+.001,mai=c(1,.5,1,.5)*.1, mex=.3)
   for(i in 1:p){
   plot.ecdf(.ndat[,i], xlab='', ylab='',main =paste(i,':',.attri[i]))#,add=T)
   .SW[i] <- shapiro.test(.ndat[,i])$p.value
   legend('bottomright',paste('p=',as.character(round(.SW[i],4))),
                   cex=.7,text.col= as.integer(.SW[i]>.01)+2, bty='n')
}
.par0()
rm(.ndat)

cat("for data transformation:\n")
cat("1. I want to apply to all columns\n")
cat("2. I want to apply to a subset of all columns\n")
cat("3. I want to apply to those who fail to pass the Normality test\n")
cat("4. I want to drop some variables\n")
cat("5. I want to select only a subset of variables\n")
cat("6. I want to continue to next step\n")
.cho <- .scanf(1,c(1:6))

if(.cho == 6) .stay <- 0
else if(.cho == 4){
  cat("select the variables you want to drop:\n")
  .varDrop <- .scanf(1,c(1:p))
  dat <- dat[,-.varDrop]
  .attri <- .attri[-.varDrop]; n <- ncol(dat)
  }
else if(.cho == 5){
  cat("select the variables:\n")
  .varKeep <- .scanf(1,c(1:p))
  dat <- dat[,.varKeep]
  .attri <- .attri[.varKeep]; n <- ncol(dat)
  }
else{
if(.cho == 1) .col <- 1:ncol(dat)
if(.cho == 2) {
  cat("please specify the columns the transformation applies to:\n")
  .col <- .scanf(1,1:p)
}

if(.cho == 3) .col <- which(.SW<=.01)

datt <- as.matrix(dat[,.col])
.stayhere <- 1
while(.stayhere == 1){
cat("Choose the type of data transformation:\n", "1.none  2.standardization  3.logarithm  4.square root  5.box-cox  6.scale\n")
.ans <- .scanf(1,c(1:6))
if(.ans == 1) .stayhere <- 0
if(.ans == 2)
{   if(!all(apply(datt,2,var)!=0))  cat("Cannot be done since there are some constant variables(columns)\n")
  if(all(apply(datt,2,var)!=0)) {datt <- as.data.frame(scale(datt)); .stayhere <- 0 }
}

if(.ans == 3)
{   if(!(all(datt>0)))  cat("Cannot be done since there are nonpositive values\n")
    if(all(datt>0)) { datt <- log(datt); .stayhere <- 0}
}

if(.ans == 4)
{   if(!(all(datt>=0)))  cat("Cannot be done since there are negative values\n")
    if(all(datt>=0)) { datt <- sqrt(datt); .stayhere <- 0}
}

if(.ans == 5)  {
  #cat("please choose the power for Box-Cox transformation:\n")
  .lambda <- seq(0,3,.01)
  if(!all(datt>0)) cat("Cannot be done since there are nonpositive values\n")
  if(all(datt>0)){
     for(.ii in 1:ncol(datt)){
     .gm <- exp( mean( log(datt[,.ii]) ) ); .P <- numeric(length(.lambda))
     for(.jj in 2:length(.lambda)) {
        .tmp <- (datt[,.ii]^.lambda[.jj] - 1)/( .lambda[.jj] * .gm^(.lambda[.jj]-1) )
        .P[.jj] <- shapiro.test(.tmp)$p.value  }
        .tmp <- log(datt[,.ii])*.gm
        .P[1] <- shapiro.test(.tmp)$p.value
        .ind <- which(.P == max(.P))[1]
        .optlambda <- .lambda[.ind]; if(.ii == 1) cat('the power selected:')
        cat(.optlambda, ' ')
        if(.optlambda!=0) datt[,.ii] <-  (datt[,.ii]^.optlambda - 1)/( .optlambda * .gm^(.optlambda-1) )
        else  datt[,.ii] <- log(datt[,.ii])*.gm}
        .stayhere <- 0
    }
   }

if(.ans == 6) {
   cat("specify the number to be divided by:\n")
   .scale <- scan("",double(0),nlines=1,quiet=T)
   datt <- datt/.scale; .stayhere <- 0
      }

   if(.stayhere) readline()
   if(!.stayhere) {dat[,.col] <- datt; cat('\n transformation is done\n') }
  }
  rm(datt)
 }

}

########  transfer location group labels into number for visualization
.ugrou <- 1; .ngrou <- rep(1,length(.sites))
if(.colGrou){
.Grou <- .grou[,1]
.ugrou <- unique(.Grou)  ;  .len_ug <- length(.ugrou)
.ngrou <- numeric(length(.Grou))
for(i in 1:.len_ug){.ngrou <- .ngrou + as.vector((.Grou == .ugrou[i])*i)}
}

cat("\n Data preprocessing step is done:\n")
cat("\n Please press Enter key to continue...\n")
readline()

if(.colGrou) {
cat(sprintf("These location groups are detected:"), "\n")
print(rbind(1:length(.ugrou),as.vector(.ugrou)))
cat("\n Please press Enter key to continue...\n")
readline()
}

n <- nrow(dat); p <- ncol(dat)

cat(sprintf(" The final pattern matrix involve %d samples and %d attributes", n, p),"\n")
cat("It is stored in the object 'dat'\n")
cat("Do you want to display it?  y/n", "\n")
.ans <- .scanf(2)
if(.ans =='y') print(dat)


library(ggplot2)
# Create a histogram with mpg
mpgpl <- ggplot(mpg, aes(x = hwy))
mpgpl <- mpgpl + geom_histogram(fill = 'red', alpha = 0.5, bins = 20)

# Create barplot by manufactorer
barpl <- ggplot(mpg, aes(x = manufacturer))
barpl <- barpl + geom_bar(aes(fill = factor(cyl)))

# Create a scatterplot volume / sales
scatterpl <- ggplot(txhousing, aes(x = sales, y = volume))
scatterpl <- scatterpl + geom_point(colot = 'blue', alpha = 0.3)
# Create a line through the scatterplot
scatterpl <- scatterpl + geom_smooth(color='red')


#' wbgt_shade
#'
#' Calculate wet bulb globe temperature index for outdoor shaded environements.
#'
#
#' @param t    numeric Air temperature in degC.
#' @param rh   numeric Relative humidity in percentage.
#' @param wind numeric Mean Wind speed in meters per second.
#' @param solar numeric  Solar Radiation Radiance in Watt./mq
#' @param pair numeric Air pressure in millibar or hPa. Default 1010 hPa.
#' @param elev numeric Elevation in meters on sea level. Default is 0.
#' @return wbgt for shade conditions in degC
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  wbgt, shade
#'
#' @export
#'
#'
#'
#'

wbgt_shade=function(t,rh,wind,solar=10,pair=1010,elev=0) {
                                                         ct$assign("t", as.array(t))
                                                         ct$assign("rh", as.array(rh))
                                                         ct$assign("wind", as.array(wind))
                                                         ct$assign("solar", as.array(solar))
                                                         ct$assign("press", as.array(pair))
                                                         ct$assign("elev", as.array(elev))
                                                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=wbgt_shade(t[i],rh[i],wind[i],solar[i],press[0],elev[0])};")
                                                         res=ct$get("res")
                                                         return(ifelse(res==9999,NA,res))
}


library(plyr)
library(gdata)

getAvg <- function(tbl) {

}

movieFile='movie_titles.txt'

# Read in list of movies, movie's ratings,
# movies <- read.table(movieFile, header = FALSE, sep=",")
movies <- read.csv(movieFile) #, header = FALSE, sep=",")
colnames(movies) <- c("ID","Year","Title");

# ratingFile='mv_0000001.txt'
# rating <- read.csv(ratingFile, skip=1)
ratingNames<- c("User","Rating","Date");
# colnames(rating) <- ratingCol

print("Start")
start <- proc.time()
setwd("training_set")
rfiles = list.files(pattern="*.txt")
mr = lapply(rfiles, read.csv, skip=1, col.names=ratingNames)

k <- function(vec) { colMeans(vec["Rating"]) }
netflixMean <- data.frame(unlist(lapply(mr,k)))

setwd("/home/users/scrasmussen/db-project/netflix/test")

# write data to file
write.table(format(netflixMean, digits=4), quote=FALSE, file="wtest.txt", sep=",", col.names=FALSE)

t <- proc.time() - start
print(t)
print("Fin")


####
####
#### AIM: Prepare twitter data for web map
####
####

# From continous to categorical -------------------------------------------
make_that_data_categorial = function(data) {
  data$group[data$senti_score >= -1.1 &
               data$senti_score <  0.26]  = 1
  data$group[data$senti_score >= 0.26 &
               data$senti_score <  0.4]  = 2
  data$group[data$senti_score >= 0.4 &
               data$senti_score <= 2.9] = 3
  return(data)
}

mine_query_sheet = read.csv("mine_query_sheet.csv")
sf::sf_use_s2(FALSE)
WBIDS = as.data.frame(unique(mine_query_sheet$WBID))
colnames(WBIDS) = "WBID"

wbs = inner_join(WBIDS, wb_all)
wbs = wbs[!duplicated(wbs$name),]
wbs = st_as_sf(wbs)

WB = as.data.frame(aggregate(senti_score  ~ WBID, clean_senti, mean))
WB = make_that_data_categorial(WB)
WB_final = inner_join(wbs, WB)
WB_final = st_transform(WB_final, crs = 4326)
write_sf(WB_final, "data/web/wb_lines_groups.geojson")

no_wb_line = anti_join(WBIDS,WB_final)

# centroids
wb_cent = st_centroid(WB_final) %>% select(name, WBID, geometry)
sf::write_sf(wb_cent, "data/web/wb_lines_centroids.geojson")


library(caret)

data(oil)
data()

head(fattyAcids)

dim(fattyAcids)

head(oilType)

table(oilType)

As a note, the paper states on page 32 that there are 37 unknown samples while the
table on pages 33 and 34 shows that there are 34 unknowns.
Using the data from the Examples section of caret::createFolds

#Linear Kernel
set.seed(1492)

#Train and Tune the SVM
svm.oil <- train(x=fattyAcids,
                    y= oilType,
                    method = "svmLinear")

svm.oil

table(oilType , predict(svm.oil))

part <- createDataPartition(iris, 2)

fold <- createFolds(iris, 2)

length(Reduce(intersect, part))
# [1] 27
1
length(Reduce(intersect, fold))
#[1] 0
2
Looks

Looks like createDataPartition split your data into smaller pieces, but allows for
the same example to appear in dierent splits.
createFolds doesn't allow dierent examples to appear in dierent splits of the
folds.
Basically, createDataPartition is used when you need to make one or more simple
two-way splits of your data. For example, if you want to make a training and test set
and keep your classes balanced, this is what you could use. It can also make multiple
splits of this kind (or leave-group-out CV aka Monte Carlos CV aka repeated training
test splits).
createFolds is exclusively for k-fold CV. Their usage is simular when you use the
returnTrain = TRUE option in createFolds.

### createDataPartition
A series of test/training partitions are created using createDataPartition while cre-
ateResample creates one or more bootstrap samples. createFolds splits the data into k
groups while createTimeSlices creates cross-validation sample information to be used
with time series data.

data(oil)
createDataPartition(oilType, 2)
$Resample1
[1] 4 8 9 10 11 12 13 15 18 36 37 41 64 65 70 71 72 73 75
[20] 19 21 22 33 34 35 76 78 79 80 81 86 87 29 62 42 52 55 56
[39] 25 26 44 48 49 51 28 59 91 93 94 92
$Resample2

[1] 4 6 7 9 10 12 13 14 16 18 37 38 40 64 68 69 72 73 75
[20] 19 20 21 23 24 32 33 35 81 83 84 87 88 29 62 42 53 55 56
[39] 25 26 47 49 50 96 58 59 60 93 95 27
> createResample(oilType, 2)
$Resample1
[1] 2 3 5 5 6 6 6 6 7 8 9 9 9 9 10 10 10 11 12
[20] 13 14 16 16 19 20 21 21 22 22 23 27 27 27 28 28 29 30 30
[39] 31 34 34 35 35 35 35 36 37 38 39 41 41 41 43 45 46 48 51
[58] 53 54 56 57 58 58 59 65 65 65 66 69 71 73 73 73 75 79 81
[77] 81 82 83 83 84 84 84 84 85 85 85 86 88 88 89 90 90 94 96
[96] 96
4
$Resample2
[1] 4 4 6 6 8 10 11 11 11 12 14 16 16 17 17 17 19 20 20
[20] 20 21 22 22 22 24 26 27 28 30 31 33 34 34 35 37 38 41 41
[39] 43 44 45 45 47 47 54 55 56 57 57 59 59 60 60 61 63 63 65
[58] 65 65 65 66 66 67 68 68 69 69 70 74 77 77 77 77 78 78 79
[77] 80 81 82 82 82 83 83 84 85 85 86 87 87 88 89 90 91 93 94
[96] 94
5


# Two problems
#
# Why DqSAD is not strictly decreasing
rm(list = ls())

load(".RData")

setwd("Simul")

Dq1 <- readNeutral_calcDq(paste0(bName,"T100mfSAD.txt"))
plotDq_ReplaceR(Dq1,0.2,0.04,0.001,"DqSAD")

Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0)
Dqq <- sel_ReplaceR(Dq1,0.2,0.04,0.001,0.1)

Dqq[12:24, c("q","Dq","SD.Dq")]

# At q=6 it began to increase!!!

# Make simulations without pomac and use plotDqFit

par <- read.table("sim.par",quote="",stringsAsFactors=F)
# Change base name

# Number of time steps
par[par$V1=="nEvals",]$V2 <- 100
# Change interval to measure Density and Diversity
par[par$V1=="inter",]$V2 <- 100
par[par$V1=="modType",]$V2 <- 4 # Hierarchical saturated
par[par$V1=="sa",]$V2 <- "S" # Save a snapshot of the model
par[par$V1=="baseName",]$V2 <- paste0("Exp",spMeta,"")
par[par$V1=="pomac",]$V2 <- 0 # 0:one set of parms
# 1:several simulations with pomac.lin parameters

write.table(par, "sim.par",sep="\t",row.names=F,col.names=F,quote=F)

# Run the model with the parameter ReplacementRate turned on = Hierarchical
# and exponential dispersal
#
# Set the location of the binary xp"

# make simulations

s <- paste(neuBin,"sim.par","fishE.inp")
s

if(simul) system(s,wait=F)


# Libraries
library(tidyverse)
library(viridis)
library(patchwork)
library(hrbrthemes)
library(circlize)
library(chorddiag)  #devtools::install_github("mattflor/chorddiag")

# Load dataset from github
data <- read.table("/Users/qsr/Desktop/chord/MCI_correlation.csv", header=TRUE)

# short names
colnames(data) <- c("hippoR",
                    "hippoL",
                    "tempoR",
                    "tempoL",
                    "cerebeR",
                    "cerebeL",
                    "brainstem",
                    "insulaR",
                    "insulaL",
                    "occiR",
                    "occiL",
                    "frontR",
                    "frontL",
                    "parieR",
                    "parieL",
                    "ventri")
rownames(data) <- colnames(data)

# I need a long format
data_long <- data %>%
  rownames_to_column %>%
  gather(key = 'key', value = 'value', -rowname)

# parameters
circos.clear()
circos.par(start.degree = 90, gap.degree = 4, track.margin = c(-0.1, 0.1), points.overflow.warning = FALSE)
par(mar = rep(0, 4))

# color palette
mycolor <- viridis(16, alpha = 1, begin = 0, end = 1, option = "D")
mycolor <- mycolor[sample(1:16)]

# Base plot
chordDiagram(
  x = data_long,
  grid.col = mycolor,
  transparency = 0.25,
  directional = 0,
  diffHeight  = -0.04,
  annotationTrack = "grid",
  annotationTrackHeight = c(0.05, 0.1),
  link.arr.type = "big.arrow",
  link.sort = TRUE,
  link.largest.ontop = TRUE)

# Add text and axis
circos.trackPlotRegion(
  track.index = 1,
  bg.border = NA,
  panel.fun = function(x, y) {

    xlim = get.cell.meta.data("xlim")
    sector.index = get.cell.meta.data("sector.index")

    # Add names to the sector.
    circos.text(
      x = mean(xlim),
      y = 3.2,
      labels = sector.index,
      facing = "bending",
      cex = 0.8
    )
  }
)


# Classification using a cubist model
library(Cubist)
library(hydroGOF)

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")
source("pixel-based/utils/crossvalidation.r")
source("pixel-based/utils/subpixel-confusion-matrix.r")
source("utils/accuracy-statistics.r")

Data.df = LoadTrainingAndCovariates()
Data.df[is.na(Data.df)] = -9999
Data.df = st_set_geometry(Data.df, NULL)
Data.df = TidyData(Data.df, drop.cols=NULL)

# Validation data
Data.val = LoadValidationAndCovariates()
Data.val[is.na(Data.val)] = -9999
Data.val = st_set_geometry(Data.val, NULL)
Data.val = TidyData(Data.val, drop.cols=NULL) # Drops around 1050

Classes = GetCommonClassNames()
Truth = Data.val[,Classes]

# Formula interface, supports only a single formula
cubist.formula = function(formula, data, ...)
{
    MF = model.frame(formula, data=data)
    cubist(MF[,-1], MF[,1], ...)
}

Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, cubist.formula, Data.val, filename="../data/pixel-based/predictions/cubist-defaults.csv")
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 19.1, MAE 8.4, similar to RF two-model
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 71%±2, kappa 0.62±0.03
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.59
PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, defaults, NA set to -9999")
PlotBox(Predictions[,Classes], Truth[,Classes], main="Cubist, defaults, NA set to -9999") # Still the same issue with underprediction

Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, cubist.formula, Data.val, filename="../data/pixel-based/predictions/cubist-defaults-naomit.csv")
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 20.4, MAE 9.1, worse than -9999
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 68%±2, kappa 0.58±0.03
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.53
PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, defaults, NAs omitted")
PlotBox(Predictions[,Classes], Truth[,Classes], main="Cubist, defaults, NAs omitted", binpredicted=TRUE) # Still the same issue with underprediction

PredictionTask = future({BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, cubist.formula, Data.val, committees=10, filename="../data/pixel-based/predictions/cubist-committees10.csv")})
resolved(PredictionTask)
Predictions = value(PredictionTask)
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 18.1, MAE 8.1, outright better than RF two-model and three-model
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 72%±2, kappa 0.63±0.03
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.63
PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, 10 committees")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="Cubist, 10 committees")

# Prediction using neighbours
PredictionTaskNeigh5 = future({BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, cubist.formula, Data.val, neighbors=5, filename="../data/pixel-based/predictions/cubist-neighbours5.csv")})
resolved(PredictionTaskNeigh5)
Predictions = value(PredictionTaskNeigh5)
Predictions = BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, cubist.formula, Data.val, neighbors=5, filename="../data/pixel-based/predictions/cubist-neighbours5.csv")
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 18.2, MAE 8.9, lower RMSE but higher MAE
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 69%±3, kappa 0.60±0.04, overall worse than default
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.63, almost like RF 1-model
PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, 5 neighbours")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="Cubist, 5 neighbours")

# Using both neighbours and committees
PredictionTaskNeighCom10 = future({BinaryRelevance(paste0("~", paste(GetAllPixelCovars(), collapse = "+")), Data.df, cubist.formula, Data.val, neighbors=5, committees=10, filename="../data/pixel-based/predictions/cubist-neighbours5-committees10.csv")})
resolved(PredictionTaskNeighCom10)
Predictions = value(PredictionTaskNeighCom10)
AccuracyStatisticsPlots(Predictions[,Classes]/100, Truth[,Classes]/100) # RMSE 17.8, MAE 8.8, similar to RF single-model
SCM(Predictions[,Classes]/100, Truth[,Classes]/100, plot=TRUE, totals=TRUE) # OA 69%±3, kappa 0.60±0.04
NSE(unlist(Predictions[,Classes]/100), unlist(Truth[,Classes]/100)) # 0.64
PlotHex(Predictions[,Classes], Truth[,Classes], "Cubist, 5 neighbours and 10 commitees")
PlotBox(Predictions[,Classes], Truth[,Classes], TRUE, main="Cubist, 5 neighbours and 10 commitees")


#' Plot the Observed Versus Simulated plot based on
#' the PEST .res file
#'
#' This function reads in the PEST .res file and generates an Observed
#' Versus Simulated plot
#' @param PATH This is the full file path to the .res file.
#' When PATH is NA this function will look in the current working
#' directory for the .res file.
#' @export
ggres <- function(PATH = NA){
    if(is.na(PATH)){
            PATH <- getwd()
        }
    RES <- suppressWarnings(MFtools::readpstres(PATH))
    SD  <- sd(RES$`Weight*Residual`)
    LBL <- RES %>% dplyr::filter(abs(Residual) > SD)
    RANGE <- max(RES$Modelled, RES$Measured) - min(RES$Modelled, RES$Measured)
    P <- RES %>% ggplot2::ggplot(aes(x = Measured)) +
                 ggplot2::coord_fixed() +
                 ggplot2::geom_abline(aes(intercept = 0, slope = 1),
                                      size = 1) +
                 ggplot2::geom_abline(aes(intercept = -SD, slope = 1),
                                      lty = 4, size = 1, colour = "red") +
                 ggplot2::geom_abline(aes(intercept = SD, slope = 1),
                                     lty = 4, size = 1, colour = "red") +
                 ggplot2::geom_point(aes(y = Modelled),
                                     size = 2,
                                     colour = "blue",
                                     alpha = 0.5) +
                 ggplot2::geom_text_repel(data = LBL, aes(label = TARG_ID, y = Modelled),
                                    nudge_x = 0.025 * RANGE) +
                 ggplot2::labs(x = "Observed", y = "Simulated") +
                 ggplot2::theme_bw()
         print(P)
     }


# This script uses matR to generate 2 or 3 dimmensional pcoas

# table_in is the abundance array as tab text -- columns are samples(metagenomes) rows are taxa or functions
# color_table and pch_table are tab tables, with each row as a metagenome, each column as a metadata
# grouping/coloring. These tables are used to define colors and point shapes for the plot
# It is assumed that the order of samples (left to right) in table_in is the same
# as the order (top to bottom) in color_table and pch_table

# basic operation is to produce a color-less pcoa of the input data

# user can also input a table to specify colors
# This table can contain colors (as hex or nominal) or can contain metadata
# that is automatically interpreted to produce coloring (identical values or text receive the same color
#
# The user can also input a pch table -- this is more advanced R plotting that allows them to
# select the shape of the plotted points
#
# example invocations are below - going from simplest to most elaborate

# create a 3d plot, minimum input arguments:
#   plot_mg_pcoa(table_in="test_data.txt")

# create a 2d plot, minimum input arguments:
#   plot_mg_pcoa(table_in="test_data.txt", plot_pcs = c(1,2))

# create a 3d plot with colors specified by a color_table file
# (by default, first column of color table is used) and the script expecpts
# entries to be literal or hex colors:
#   plot_mg_pcoa(table_in="test_data.txt", color_table="test_colors.txt")

# create a 3d plot with colors generated from the color_table, using second column in color table
# specify option to generate colors from the table (any metadata will work)
# specify that the second column is used:
#   plot_mg_pcoa(table_in="test_data.txt", color_table="test_colors.txt", auto_colors=TRUE, color_column=2)

# create a plot where every input argument is explicitly addressed:
#   plot_mg_pcoa(table_in="test_data.txt", image_out = "wacky_pcoa", plot_pcs = c(1,3,5), label_points=NA, color_table="test_colors.txt", auto_colors=TRUE, color_column=3, pch_table="test_pch.txt", pch_column=3, image_width_in=10, image_height_in=10, image_res_dpi=250)

render_pcoa <<- function(
                         PCoA_in="", # annotation abundance table (raw or normalized values)
                         image_out="default",
                         figure_main ="principal coordinates",
                         components=c(1,2,3), # R formated string telling which coordinates to plot, and how many (2 or 3 coordinates)
                         label_points=FALSE, # default is off
                         metadata_table=NA, # matrix that contains colors or metadata that can be used to generate colors
                         metadata_column=2, # column of the color matrix to color the pcoa (colors for the points in the matrix) -- rows = samples, columns = colorings
                         amethst_groups=NA,
                         color_list=NA, # use explicit list of colors - trumps table if both are supplied
                         pch_table=NA, # additional matrix that allows users to specify the shape of the data points
                         pch_column=1,
                         image_width_in=22,
                         image_height_in=17,
                         image_res_dpi=300,
                         width_legend = 0.2, # fraction of width used by legend
                         width_figure = 0.8, # fraction of width used by figure
                         title_cex = 2, # cex for the title of title of the figure
                         legend_cex = 2, # cex for the legend
                         figure_cex = 2, # cex for the figure
                         bar_cex = 2,
                         use_all_metadata_columns=FALSE, # option to overide color_column -- if true, plots are generate for all of the metadata columns
                         debug=TRUE
                         )

{

  require(matR)

  argument_test <<- is.na(c(metadata_table,amethst_groups,color_list)) # check that incompatible options were not selected
  if ( 3 - length(subset(argument_test, argument_test==TRUE) ) > 1){
    stop(
         paste(
               "\n\nOnly on of these can have a non NA value:\n",
               "     metadata_table: ", metadata_table,"\n",
               "     amethst_groups: ", amethst_groups, "\n",
               "     color_list    : ", color_list, "\n\n",
               sep="", collapse=""
               )
         )
  }

  ######################
  ######## MAIN ########
  ######################

  load_pcoa_data(PCoA_in) # import_data
  load_metadata(metadata_table, metadata_column, color_list, amethst_groups) # import_metadata_coloring
  load_pch(pch_table) # import_pch

  #####################################################################################
  # PLOT WITH NO METADATA OR COLORS SPECIFIED (colors generated by load_metadata)
  if ( length(argument_test==TRUE)==0 ){
    if ( identical(image_out, "default") ){
      image_out = paste( PCoA_in,".NO_COLOR.PCoA.png", sep="", collapse="" )
      figure_main = paste( PCoA_in, ".NO_COLOR.PCoA", sep="", collapse="" )
    }else{
      image_out = paste(image_out, ".png", sep="", collapse="")
      figure_main = paste( image_out,".PCoA", sep="", collapse="")
    }
    create_plot(
                PCoA_in,
                ncol.color_matrix,
                eigen_values, eigen_vectors, components,
                column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
                image_out,figure_main,
                image_width_in, image_height_in, image_res_dpi,
                width_legend, width_figure,
                title_cex, legend_cex, figure_cex, bar_cex, label_points
                )
  }
  #####################################################################################

  #####################################################################################
  # PLOT WITH AMETHST GROUPS (colors generated by load_metadata)
  if ( identical( is.na(amethst_groups), FALSE ) ){
    if ( identical(image_out, "default") ){
      image_out = paste( PCoA_in,".AMETHST_GROUPS.PCoA.png", sep="", collapse="" )
      figure_main = paste( PCoA_in, ".AMETHST_GROUPS.PCoA", sep="", collapse="" )
    }else{
      image_out = paste(image_out, ".png", sep="", collapse="")
      figure_main = paste( image_out,".PCoA", sep="", collapse="")
    }
    create_plot(
                PCoA_in,
                ncol.color_matrix,
                eigen_values, eigen_vectors, components,
                column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
                image_out,figure_main,
                image_width_in, image_height_in, image_res_dpi,
                width_legend, width_figure,
                title_cex, legend_cex, figure_cex, bar_cex, label_points
                )
  }
  #####################################################################################

  #####################################################################################
  # PLOT WITH LIST OF COLORS (colors generated by load_metadata)
  if ( identical( is.na(color_list), FALSE ) ){
    if ( identical(image_out, "default") ){
      image_out = paste( PCoA_in,".color_List.PCoA.png", sep="", collapse="" )
      figure_main = paste( PCoA_in, ".color_list.PCoA", sep="", collapse="" )
    }else{
      image_out = paste(image_out, ".png", sep="", collapse="")
      figure_main = paste( image_out,".PCoA", sep="", collapse="")
    }
    create_plot(
                PCoA_in,
                ncol.color_matrix,
                eigen_values, eigen_vectors, components,
                column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
                image_out,figure_main,
                image_width_in, image_height_in, image_res_dpi,
                width_legend, width_figure,
                title_cex, legend_cex, figure_cex, bar_cex, label_points
                )
  }
  #####################################################################################

  #####################################################################################
  # PLOT WITH METADATA_TABLE (colors produced from color_matrix)
  if ( identical( is.na(metadata_table), FALSE ) ){
    if ( use_all_metadata_columns==TRUE ){ # autogenerate plots for all columns in the metadata table file
      for (i in 1:ncol.color_matrix){ # generate filename and title for each image
        #column_color( color_matrix, my_color_mode="auto", my_column=i ) # get colors for metadata column i
        #pcoa_colors <<- color_matrix[,i]
        column_factors <<- as.factor(metadata_matrix[,i])
        column_levels <<- levels(as.factor(metadata_matrix[,i]))
        num_levels <<- length(column_levels)
        color_levels <<- col.wheel(num_levels)
        pcoa_colors <<- color_matrix[,i]
        image_out = paste(PCoA_in,".", colnames(color_matrix)[i], ".pcoa.png", sep="", collapse="")
        figure_main = paste( PCoA_in,".", colnames(color_matrix)[i],".PCoA", sep="", collapse="")
        create_plot( # generate a plot
                    PCoA_in,
                    ncol.color_matrix,
                    eigen_values, eigen_vectors, components,
                    column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
                    image_out,figure_main,
                    image_width_in, image_height_in, image_res_dpi,
                    width_legend, width_figure,
                    title_cex, legend_cex, figure_cex, bar_cex, label_points
                    )
      }
    }else if ( use_all_metadata_columns==FALSE ){ # auto generate colors from a single selected column
      #column_color( color_matrix, my_color_mode="auto", my_column=metadata_column ) # get colors for metadata column i
      pcoa_colors <<- color_matrix[,metadata_column]
      column_factors <<- as.factor(metadata_matrix[,metadata_column])
      column_levels <<- levels(as.factor(metadata_matrix[,metadata_column]))
      num_levels <<- length(column_levels)
      color_levels <<- col.wheel(num_levels)
      pcoa_colors <<- color_matrix[,metadata_column]
      if ( identical(image_out, "default") ){ # generate filename and title for each image
        image_out = paste(PCoA_in,".", colnames(color_matrix)[metadata_column], ".pcoa.png", sep="", collapse="")
        figure_main = paste( PCoA_in,".", colnames(color_matrix)[metadata_column],".PCoA", sep="", collapse="")
      }else{
        image_out = paste(image_out, ".png", sep="", collapse="")
        figure_main = paste( image_out,".PCoA", sep="", collapse="")
      }
      create_plot( # generate the plot
                  PCoA_in,
                  ncol.color_matrix,
                  eigen_values, eigen_vectors, components,
                  column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
                  image_out,figure_main,
                  image_width_in, image_height_in, image_res_dpi,
                  width_legend, width_figure,
                  title_cex, legend_cex, figure_cex, bar_cex, label_points
                  )
    }else{
      stop(paste("invalid value for use_all_metadata_columns(", use_all_metadata_columns,") was specified, please try again", sep="", collapse=""))
    }
  }

}
#####################################################################################

######################
###### END MAIN ######
######################

######################
######## SUBS ########
######################

#######################
######## SUB(1): Function to import the data from a pre-calculated PCoA
######################
load_pcoa_data <- function(PCoA_in){
  con_1 <- file(PCoA_in)
  con_2 <- file(PCoA_in)
  # read through the first time to get the number of samples
  open(con_1);
  num_values <- 0
  data_type = "NA"
  while ( length(my_line <- readLines(con_1,n = 1, warn = FALSE)) > 0) {
    if ( length( grep("PCO", my_line) ) == 1  ){
      num_values <- num_values + 1
    }
  }
  close(con_1)
  # create object for values
  eigen_values <- matrix("", num_values, 1)
  dimnames(eigen_values)[[1]] <- 1:num_values
  eigen_vectors <- matrix("", num_values, num_values)
  dimnames(eigen_vectors)[[1]] <- 1:num_values
  # read through a second time to populate the R objects
  value_index <- 1
  vector_index <- 1
  open(con_2)
  current.line <- 1
  data_type = "NA"
  while ( length(my_line <- readLines(con_2,n = 1, warn = FALSE)) > 0) {
    if ( length( grep("#", my_line) ) == 1  ){
      if ( length( grep("EIGEN VALUES", my_line) ) == 1  ){
        data_type="eigen_values"
      } else if ( length( grep("EIGEN VECTORS", my_line) ) == 1 ){
        data_type="eigen_vectors"
      }
    }else{
      split_line <- noquote(strsplit(my_line, split="\t"))
      if ( identical(data_type, "eigen_values")==TRUE ){
        dimnames(eigen_values)[[1]][value_index] <- noquote(split_line[[1]][1])
        eigen_values[value_index,1] <- noquote(split_line[[1]][2])
        value_index <- value_index + 1
      }
      if ( identical(data_type, "eigen_vectors")==TRUE ){
        dimnames(eigen_vectors)[[1]][vector_index] <- noquote(split_line[[1]][1])
        for (i in 2:(num_values+1)){
          eigen_vectors[vector_index, (i-1)] <- as.numeric(noquote(split_line[[1]][i]))
        }
        vector_index <- vector_index + 1
      }
    }
  }
  close(con_2)
  # finish labeling of data objects
  dimnames(eigen_values)[[2]] <- "EigenValues"
  dimnames(eigen_vectors)[[2]] <- dimnames(eigen_values)[[1]]
  class(eigen_values) <- "numeric"
  class(eigen_vectors) <- "numeric"
  # write imported data to global objects
  eigen_values <<- eigen_values
  eigen_vectors <<- eigen_vectors
}
######################
######################
######################

######################
# SUB(2): Function to load the metadata/ generate or import colors for the points
######################
load_metadata <- function(metadata_table, metadata_column, color_list, amethst_groups){

  if ( identical( is.na(metadata_table), FALSE ) ){ # HANDLE METADATA TABLE for generating colors
    metadata_matrix <- as.matrix( # Import metadata table, use it to generate colors
                              read.table(
                                         file=metadata_table,row.names=1,header=TRUE,sep="\t",
                                         colClasses = "character", check.names=FALSE,
                                         comment.char = "",quote="",fill=TRUE,blank.lines.skip=FALSE
                                         )
                              )
    # make sure that the color matrix is sorted (ROWWISE) by id
    metadata_matrix <<- metadata_matrix[order(rownames(metadata_matrix)),]
    color_matrix <<- create_colors(metadata_matrix, color_mode = "auto")
    ncol.color_matrix <<- ncol(color_matrix)

  } else if ( identical( is.na(amethst_groups), FALSE ) ){ # HANDLE AMETHST GROUPS for generating colors

    con_grp <- file(amethst_groups)
    open(con_grp)
    line_count <- 1
    groups.list <- vector(mode="character")
    while ( length(my_line <- readLines(con_grp,n = 1, warn = FALSE)) > 0) {
      new_line <- my_line
      split_line <- unlist(strsplit(my_line, split=","))
      split_line.list <- rep(line_count, length(split_line))
      names(split_line.list) <- split_line
      groups.list <- c(groups.list, split_line.list)
      line_count <- line_count + 1
    }
    close(con_grp)
    if ( length(groups.list) != length(unique(names(groups.list))) ){
      stop("One or more groups have redundant entries - this is not allowed for coloring the PCoA")
    }
    color_matrix <<- matrix(groups.list, ncol=1)
    rownames(color_matrix) <<- names(groups.list)
    color_matrix <<- color_matrix[order(rownames(color_matrix)),,drop=FALSE]   # make sure that the color matrix is sorted (ROWWISE) by id
    color_matrix <<- create_colors(color_matrix, color_mode = "auto")
    ncol.color_matrix <<- ncol(color_matrix)
    pcoa_colors <<- color_matrix[,1]
    ncol.color_matrix <<- 1
    column_factors <<- as.factor(metadata_matrix[,1])
    column_levels <<- levels(as.factor(metadata_matrix[,1]))
    num_levels <<- length(column_levels)
    color_levels <<- col.wheel(num_levels)
    pcoa_colors <<- color_matrix[,1]

  }else if ( identical( is.na(color_list), FALSE ) ){ # HANDLE COLOR LIST; use list of color if it is supplied

    column_levels <<- levels(as.factor(as.matrix(color_list)))
    num_levels <<- length(column_levels)
    color_levels <<- col.wheel(num_levels)
    ncol.color_matrix <<- 1
    pcoa_colors <<- color_list
    #plot_colors <<- color_list

  }else{ # HANDLE NO INPUT METADATA OR COLORS; use a default of black if no table or list is supplied

    column_levels <<- "data"
    num_levels <<- 1
    color_levels <<- 1
    ncol.color_matrix <<- 1
    pcoa_colors <<- "black"

  }
}
######################
######################

######################
# SUB(3): Function to import the pch information for the points # load pch matrix if one is specified
######################
load_pch <- function(pch_table){
  if ( identical( is.na(pch_table), FALSE ) ){
    pch_matrix <- data.matrix(read.table(file=pch_table, row.names=1, header=TRUE, sep="\t", comment.char="", quote="", check.names=FALSE))
    pch_matrix <- pch_matrix[order(rownames(pch_matrix)),]
    plot_pch <<- pch_matrix[,pch_column]
  }else{
    plot_pch <<- 19
  }
}
######################
######################

######################
# SUB(4): Workhorse function that creates the plot
######################
create_plot <- function(
                        PCoA_in,
                        ncol.color_matrix,
                        eigen_values, eigen_vectors, components,
                        column_levels, num_levels, color_levels, pcoa_colors, plot_pch,
                        image_out,figure_main,
                        image_width_in, image_height_in, image_res_dpi,
                        width_legend, width_figure,
                        title_cex, legend_cex, figure_cex, bar_cex, label_points
                        ){
  png( # initialize the png
      filename = image_out,
      width = image_width_in,
      height = image_height_in,
      res = image_res_dpi,
      units = 'in'
      )
  # CREATE THE LAYOUT
  my_layout <- layout(  matrix(c(1,1,2,3,4,4), 3, 2, byrow=TRUE ), widths=c(width_legend,width_figure), heights=c(0.1,0.8,0.1) )
  layout.show(my_layout)
  # PLOT THE TITLE
  plot.new()
  text(x=0.5, y=0.5, figure_main, cex=title_cex)
  # PLOT THE LEGEND
  plot.new()
  legend( x="center", legend=column_levels, pch=15, col=color_levels, cex=legend_cex)
  # PLOT THE FIGURE
  # set par options (Most of the code in this section is copied/adapted from Dan Braithwaite's pco plotting in matR)
  par <- list ()
  par$main <- ""#figure_main
  #par$labels <- if (length (names (x)) != 0) names (x) else samples (x)
  if ( label_points==TRUE ){
    par$labels <-  rownames(eigen_vectors)
  } else {
    par$labels <- NA
  }
  #if (length (groups (x)) != 0) par$labels <- paste (par$labels, " (", groups (x), ")", sep = "")
  par [c ("xlab", "ylab", if (length (components) == 3) "zlab" else NULL)] <- paste ("PC", components, ", R^2 = ", format (eigen_values [components], dig = 3), sep = "")
  #col <- if (length (groups (x)) != 0) groups (x) else factor (rep (1, length (samples (x))))
  #levels (col) <- colors() [sample (length (colors()), nlevels (col))]
  #g <- as.character (col)
  #par$pch <- 19
  par$cex <- figure_cex
  # main plot paramters - create the 2d or 3d plot
  i <- eigen_vectors [ ,components [1]]
  j <- eigen_vectors [ ,components [2]]
  k <- if (length (components) == 3) eigen_vectors [ ,components [3]] else NULL
  if (is.null (k)) {
  #par$col <- col
    par$col <- pcoa_colors ####<--------------
    par$pch <- plot_pch
    par <- resolveMerge (list (...), par)
    xcall (plot, x = i, y = j, with = par, without = "labels")
    xcall (points, x = i, y = j, with = par, without = "labels")
    grid ()
  } else {
    # parameter "color" has to be specially handled.
    # "points" above wants "col", scatterplot3d wants "color", and we
    # want the user not to worry about it...
    # par$color <- col
    par$color <- pcoa_colors
    par$pch <- plot_pch
    par$type <- "h"
    par$lty.hplot <- "dotted"
    par$axis <- TRUE
    par$box <- FALSE
    #par <- resolveMerge (list (...), par)
    reqPack ("scatterplot3d")
    xys <- xcall (scatterplot3d, x = i, y = j, z = k, with = par,
                  without = c ("cex", "labels")) $ xyz.convert (i, j, k)
    i <- xys$x ; j <- xys$y
  }
  text (x = i, y = j, labels = par$labels, pos = 4, cex = par$cex)
  #invisible (P)
  #})
  # PLOT THE COLOR BAR
  bar_x <- 1:num_levels
  bar_y <- 1
  bar_z <- matrix(1:num_levels, ncol=1)
  image(x=bar_x,y=bar_y,z=bar_z,col=color_levels,axes=FALSE,xlab="",ylab="")
  loc <- par("usr")
  text(loc[1], loc[1], column_levels[1], pos = 1, xpd = T, cex=bar_cex)
  text(loc[2], loc[3], column_levels[num_levels], pos = 1, xpd = T, cex=bar_cex)
  graphics.off()
}
######################
######################

######################
# SUB(5): Handle partially formatted metadata to produce colors for a single column in a metadata table
######################
## column_color <- function( color_matrix, my_color_mode="auto", my_column ){
##   ncol.color_matrix <<- ncol(color_matrix)
##   plot_colors.matrix <<- create_colors(color_matrix, color_mode=my_color_mode)
##   column_factors <<- as.factor(color_matrix[,my_column])
##   column_levels <<- levels(as.factor(color_matrix[,my_column]))
##   num_levels <<- length(column_levels)
##   color_levels <<- col.wheel(num_levels)
##   pcoa_colors <<- plot_colors.matrix[,my_column]
## }
######################
######################

######################
# SUB(6): Create optimal contrast color selection using a color wheel
# adapted from https://stat.ethz.ch/pipermail/r-help/2002-May/022037.html
######################
col.wheel <- function(num_col, my_cex=0.75) {
  cols <- rainbow(num_col)
  col_names <- vector(mode="list", length=num_col)
  for (i in 1:num_col){
    col_names[i] <- getColorTable(cols[i])
  }
  cols
}
######################
######################

######################
# SUB(7): The inverse function to col2rgb()
# adapted from https://stat.ethz.ch/pipermail/r-help/2002-May/022037.html
######################
rgb2col <- function(rgb) {
  rgb <- as.integer(rgb)
  class(rgb) <- "hexmode"
  rgb <- as.character(rgb)
  rgb <- matrix(rgb, nrow=3)
  paste("#", apply(rgb, MARGIN=2, FUN=paste, collapse=""), sep="")
}
######################
######################

######################
# SUB(8): Convert all colors into format "#rrggbb"
# adapted from https://stat.ethz.ch/pipermail/r-help/2002-May/022037.html
######################
getColorTable <- function(col) {
  rgb <- col2rgb(col);
  col <- rgb2col(rgb);
  sort(unique(col))
}
######################
######################

######################
# SUB(9): Automtically generate colors from metadata with identical text or values
######################
create_colors <- function(color_matrix, color_mode = "auto"){ # function to
  my_data.color <- data.frame(color_matrix)
  ids <- rownames(color_matrix)
  color_categories <- colnames(color_matrix)
  for ( i in 1:dim(color_matrix)[2] ){
    column_factors <- as.factor(color_matrix[,i])
    column_levels <- levels(as.factor(color_matrix[,i]))
    num_levels <- length(column_levels)
    color_levels <- col.wheel(num_levels)
    levels(column_factors) <- color_levels
    my_data.color[,i]<-as.character(column_factors)
  }
  return(my_data.color)
}
######################
######################

######################
###### END SUBS ######
######################


library(gapminder)
library(dplyr)
library(ggplot2)
library(ggthemes)
library(Hmisc)
library(wesanderson)
library(ggridges)
library(griffen)

#names(cps)
sel_feature <- c("state", "education_category")
new_df <- cps[sel_feature]
unique_state <- unique(new_df["state"])[[1]]
#print(unique_state)

# looping

desired_length <- 1
graduation_rate <- rep(NA, desired_length)
for (i in unique_state) {
    #print(i)
    cur_df <- new_df %>% filter(state == i)
    total_num <- nrow(cur_df)
    college_df <- cur_df %>% filter(education_category == "college")
    college_num <- nrow(college_df)
    state_graduation_rate <- college_num / total_num
    #print(state_graduation_rate)
    graduation_rate <- c(graduation_rate, state_graduation_rate)
}
graduation_rate <- graduation_rate[-1]

graduation_rate_df <- data.frame(unique_state, graduation_rate)
graduation_rate_df <- graduation_rate_df[order(graduation_rate,
 decreasing = FALSE),]
rownames(graduation_rate_df) <- 1 : length(rownames(graduation_rate_df))
graduation_rate_df$unique_state <- factor(graduation_rate_df$unique_state,
 levels = graduation_rate_df$unique_state)
print(graduation_rate_df)

p <- ggplot(data=graduation_rate_df,
 mapping = aes(x=unique_state, y=graduation_rate)) +
  geom_point() + coord_flip() + labs(y = "College Graduation Rate", x = "")
print(p)


library(tm)
library(wordcloud)
library(e1071)
library(gmodels)
#load naive bayes data, sms spam/ham
nb.data <- read.csv("Downloads/Machine-Learning-With-R-master/sms_spam/sms_spam.csv", stringsAsFactors = F)
nb.data$type <- factor(nb.data$type)
#take a look at spam/ham num
table(nb.data$type)
#split messages into bag-of-words
nb.corpus <- Corpus(VectorSource(nb.data$text))
#clearn remove stop words
corpus <- tm_map(nb.corpus, content_transformer(tolower))
nb.corpus <- tm_map(nb.corpus, removeNumbers)
nb.corpus <- tm_map(nb.corpus, removeWords, stopwords())
nb.corpus <- tm_map(nb.corpus, removePunctuation)
nb.corpus <- tm_map(nb.corpus, stripWhitespace)
#create term-document-matrix
nb.dtm <- DocumentTermMatrix(nb.corpus)
#split into train and test data
nb.train <- nb.corpus[1:4000]
nb.test <- nb.corpus[4001:5559]
nb.dtm.train <- nb.dtm[1:4000, ]
nb.dtm.test <- nb.dtm[4001:5559, ]
nb.raw.train <- nb.data[1:4000, ]
nb.raw.test <- nb.data[4001:5559, ]
spam <- subset(nb.raw.train, type == "spam")
ham <- subset(nb.raw.test, type == "ham")
#visualize
wordcloud(spam$text, max.words = 40, scale = c(3, 0.5))
wordcloud(ham$text, max.words = 40, scale = c(3, 0.5))
nb.freq <- findFreqTerms(nb.dtm.train, 5)
train.data <- DocumentTermMatrix(nb.train, list(dictionary = nb.freq))
test.data <- DocumentTermMatrix(nb.test, list(dictionary = nb.freq))
nb.train <- apply(train.data, MARGIN = 2, convert_counts)
nb.test <- apply(test.data, MARGIN = 2, convert_counts)
#build a classifier with naive bayes
nb.classifier <- naiveBayes(nb.train, nb.raw.train$type)
#make prediction
nb.pred <- predict(nb.classifier, nb.test)
#evaluate the classifier
CrossTable(nb.pred, nb.raw.test$type, prop.chisq = FALSE)

convert_counts <- function(x) {
    x <- ifelse(x > 0, 1, 0)
    x <- factor(x, levels = c(0, 1), labels = c("No", "Yes"))
    return(x)
 }


#' @export
findRoot <- function(data,att){
  g <- data[,att]
  dataord<- order(data[,att])
  data <- data[dataord,]
  med <- mean(data[,att])
  caso <- MinEuclidean1xn(med,data[,att])
  return(caso)
}


#' port_cor
#' matrix correlation wrap. Parameter selects which function to use, cor or tgs_cor. Tgs_cor can be more efficien if available
#'
#' @param x matrix whole columans will be analyzed
#' @param pairwise.complete.obs - similar to cor, if this is T, NA's will be ibe ignored and only values that are pairwise available will be used to compute the correlaiton
#' @param spearman TRUE if rank correlation is to be used
#' @param tidy if TRUE, the output will be tidy
#' @param threshold defining a threshold to deterine which correlation to be reported if using the tidy format
#'
#' @return the corelation matrix of the columns
#'
port_cor = function(x, pairwise.complete.obs = F, spearman = F, tidy = F,	threshold = 0)
{
	if (get_param("mc_use_tgs_cor")) {
		return (tgs_cor(x, pairwise.complete.obs, spearman, tidy, threshold))
	}
	else {
		if(tidy) {
			stop("MC-ERR no tidy support for correaltion when not using tgs_cor, try changing the param mc_use_tgs_cor to TRUE")
		}
		return(cor(x, method=ifelse(spearman, "spearman", "pearson"), use=ifelse(pairwise.complete.obs, "pair", "all")))
	}
}


add = function (x,y){
  x+y
}


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

writeCSV <- function (outData,outFile){
  write.csv(outData, file=outFile, row.names=FALSE)
}

BFofAvg <- function(numeratorConstraint,margLikes){

  # Rename column name for numberator in BF calculation.
  colnames(margLikes)[colnames(margLikes)==numeratorConstraint] <- "numeratorConstraint"

  # Start a list of BF values for all loci in dataset
  numLoci <- length(margLikes$numeratorConstraint)

  # Make lists and add to data frame with locus names, constraint name, and 0 BFs
  numeratorList <- rep(c(numeratorConstraint), times=numLoci)
  outBFList <- vector(mode="numeric",length=numLoci)

  # Make dataframe
  outBFdf <- subset(margLikes, select = c('Locus'))
  outBFdf$Hypothesis <- numeratorList
  outBFdf$BF <- outBFList

  # create a dataset of alternate constraints only to average over
  drops <- c("Locus","numeratorConstraint")
  df <- margLikes[,!(names(margLikes) %in% drops)]

  # for locus in dataset
  for (i in 1:nrow(outBFdf)){

    # Get all alternate marginal likehoods
    otherMargLikes <- as.numeric(df[i,])

    # Maximum of alternate margLH
    a <- max(otherMargLikes)

    # Calculate average across alternate constraints
    avgOtherMargLikes <- a+log(sum(exp(otherMargLikes-a)))-log(length(names(df)))

    # Calculate bayes factor - 2ln(BF)
    outBFdf[i,3] <- 2*(margLikes$numeratorConstraint[i] - avgOtherMargLikes)}

  return(outBFdf)
}

setwd("/Users/ChatNoir/Projects/Squam/Graphs/BF")
mLBF <- read.table("StreicherMargLikeSummary.txt",header=TRUE)
mLdGLS <- read.table("/Users/ChatNoir/Projects/Squam/Graphs/dGLS/StreicherdGLSSummary.txt",header=TRUE)
length(mLBF$Locus[!(mLBF$Locus %in% mLdGLS$Locus)])
# same lenght all good.
# Read in table of marginal Likelihoods
mL <- read.table("StreicherMargLikeSummary.txt",header=TRUE)
mLTox <- mL[,!(names(mL) %in% c("Sclero"))]
names(mL)
mLaiS <- mL[,!(names(mL) %in% c("ToxAngIg"))]
mLsaS <- mL[,!(names(mL) %in% c("ToxSnIg"))]
mLsiS <- mL[,!(names(mL) %in% c("ToxSnAng"))]

# Get list of BF for each relationship, using an average of all other constraints as a composite hypothesis.

ScleroBF <- BFofAvg("Sclero",mL)
# sclero avg vs pairwise
SaiBF <- BFofAvg("Sclero",mLaiS)
SsaBF <- BFofAvg("Sclero",mLsaS)
SsiBF <- BFofAvg("Sclero",mLsiS)
# Can do these across all other hypoth mL, or just compared to other Tox hypoth mLTox
ToxAngIgBF  <- BFofAvg("ToxAngIg",mL)
ToxSnAngBF  <- BFofAvg("ToxSnAng",mL)
ToxSnIgBF <- BFofAvg("ToxSnIg",mL)
ToxAngIgBFtx  <- BFofAvg("ToxAngIg",mLTox)
ToxSnAngBFtx  <- BFofAvg("ToxSnAng",mLTox)
ToxSnIgBFtx <- BFofAvg("ToxSnIg",mLTox)

# Combine and factor
allBF <- bind_rows(ScleroBF,ToxAngIgBF,ToxSnAngBF,ToxSnIgBF)
toxBF <- bind_rows(ToxAngIgBFtx,ToxSnAngBFtx,ToxSnIgBFtx)
allBF$Hypothesis <- factor(allBF$Hypothesis, levels=c("Sclero","ToxAngIg","ToxSnAng","ToxSnIg"))
toxBF$Hypothesis <- factor(toxBF$Hypothesis, levels=c("ToxAngIg","ToxSnAng","ToxSnIg"))
allBF <- allBF %>% separate(Locus, c("LocusType","LocusNumber"), "-", remove = FALSE)
toxBF <- toxBF %>% separate(Locus, c("LocusType","LocusNumber"), "-", remove = FALSE)

# Absolute values, averages of differences
margLHablsAve <- mL %>% mutate(absAvg=(abs(Sclero-ToxAngIg)+
                                         abs(Sclero-ToxSnAng)+
                                         abs(Sclero-ToxSnIg)+
                                         abs(ToxAngIg-ToxSnAng)+
                                         abs(ToxAngIg-ToxSnIg)+
                                         abs(ToxSnAng-ToxSnIg))/6) %>% select(Locus,absAvg)

# Support counts

allBF <- mutate(allBF, Support = case_when(BF >= 10 ~ "Strong",
                                           BF >= -10 & BF <= 10 ~ "Ambiguous",
                                           BF <= -10 ~ "Strong_Against")) %>%
  mutate(Percentile = ntile(desc(BF),100)) %>% mutate(locusRank=dense_rank(desc(BF)))
toxBF <- mutate(toxBF, Support = case_when(BF >= 10 ~ "Strong",
                                           BF >= -10 & BF <= 10 ~ "Ambiguous",
                                           BF <= -10 ~ "Strong_Against")) %>%
  mutate(Percentile = ntile(desc(BF),100)) %>% mutate(locusRank=dense_rank(desc(BF)))
allSupport <- allBF %>% group_by(Hypothesis,Support) %>% dplyr::summarise(counts=n())
allSupport$Support <- factor(allSupport$Support, levels=c("Strong_Against","Ambiguous","Strong"))
toxSupport <- toxBF %>% group_by(Hypothesis,Support) %>% dplyr::summarise(counts=n())
toxSupport$Support <- factor(toxSupport$Support, levels=c("Strong_Against","Ambiguous","Strong"))

# Save R data here

#writeCSV(toxSupport,"Streicher_toxdGLSavg_support.csv")
#writeCSV(allSupport,"Streicher_alldGLSavg_support.csv")

# Loci Lists

# Loci sig support for Sclero over Tox
# Loci sig support for Tox over Sclero
# Loci sig support for AI over other Tox
# Loci sig support for SA over other Tox
# Loci sig support for SI over other Tox

allBF.SC.loci <- allBF %>% select(Locus, BF, Hypothesis, Percentile, locusRank) %>%
  filter(Hypothesis=="Sclero") %>%
  filter(BF >= 10) %>% select(-Hypothesis)
allBF.AI.loci <- allBF %>% select(Locus, BF,Hypothesis,Percentile, locusRank) %>%
  filter(Hypothesis=="ToxAngIg") %>%
  filter(BF >= 10) %>% select(-Hypothesis)
allBF.SA.loci <- allBF %>% select(Locus, BF,Hypothesis,Percentile, locusRank) %>%
  filter(Hypothesis=="ToxSnAng") %>%
  filter(BF >= 10) %>% select(-Hypothesis)
allBF.SI.loci <- allBF %>% select(Locus, BF,Hypothesis,Percentile, locusRank) %>%
  filter(Hypothesis=="ToxSnIg") %>%
  filter(BF >= 10) %>% select(-Hypothesis)

# Save Rdata here

#writeCSV(allBF.SC.loci,"Streicher.allBF.SC.loci.csv")
#writeCSV(allBF.AI.loci,"Streicher.allBF.AI.loci.csv")
#writeCSV(allBF.SA.loci,"Streicher.allBF.SA.loci.csv")
#writeCSV(allBF.SI.loci,"Streicher.allBF.SI.loci.csv")

toxBF.AI.loci <- toxBF %>% select(Locus, BF,Hypothesis,Percentile) %>%
  filter(Hypothesis=="ToxAngIg") %>%
  filter(BF >= 10) %>% select(-Hypothesis)
toxBF.SA.loci <- toxBF %>% select(Locus, BF,Hypothesis,Percentile) %>%
  filter(Hypothesis=="ToxSnAng") %>%
  filter(BF >= 10) %>% select(-Hypothesis)
toxBF.SI.loci <- toxBF %>% select(Locus, BF,Hypothesis,Percentile) %>%
  filter(Hypothesis=="ToxSnIg") %>%
  filter(BF >= 10) %>% select(-Hypothesis)

#writeCSV(toxBF.AI.loci,"Streicher.toxBF.AI.loci.csv")
#writeCSV(toxBF.SA.loci,"Streicher.toxBF.SA.loci.csv")
#writeCSV(toxBF.SI.loci,"Streicher.toxBF.SI.loci.csv")

# Graph all the things at once! woop woop

# quartz()

quartz()

############## Saved Plots ############## ############## ############## ############## ##############

# Streicher_BF_Violin
data_summary <- function(x) {
  m <- mean(x)
  ymin <- m-sd(x)
  ymax <- m+sd(x)
  return(c(y=m,ymin=ymin,ymax=ymax))
}
myList <- c("orange","#38598CFF","#2BB07FFF","#C2DF23FF")
txList <- c("#38598CFF","#2BB07FFF","#C2DF23FF")
all <- ggplot(allBF, aes(x=Hypothesis, y=BF, color=Hypothesis)) +
  geom_violin(trim=TRUE) + scale_color_manual(values=myList) +
  theme_bw() + theme(panel.border = element_blank())

all
all.trunc <- ggplot(allBF, aes(x=Hypothesis, y=BF, color=Hypothesis)) +
  geom_violin(trim=TRUE) + ylim(-50,50) + stat_summary(fun.data=data_summary) +
  scale_color_manual(values=myList) + theme_bw() +
  theme_bw() + theme(panel.border = element_blank())
all.trunc

a <- ggarrange(all,all.trunc, ncol=2, nrow=1, common.legend = TRUE, legend="right")
ggsave("Streicher_BF_Violin_all.jpg", plot=a, width = 40, height = 20, units = "cm")

tox <- ggplot(toxBF, aes(x=Hypothesis, y=BF, color=Hypothesis)) +
  geom_violin(trim=TRUE) + scale_color_manual(values=txList) +
  theme_bw() + theme(panel.border = element_blank())
tox.trunc <- ggplot(toxBF, aes(x=Hypothesis, y=BF, color=Hypothesis)) +
  geom_violin(trim=TRUE) + ylim(-25,25) + stat_summary(fun.data=data_summary) +
  scale_color_manual(values=txList) +
  theme_bw() + theme(panel.border = element_blank())
tox
tox.trunc
t <- ggarrange(tox,tox.trunc, ncol=2, nrow=1, common.legend = TRUE, legend="right")

ggsave("Streicher_BF_Violin_tox.jpg", plot=t, width = 40, height = 20, units = "cm")

########### Streicher_BF_Histo ###########

myList <- c("orange","#38598CFF","#2BB07FFF","#C2DF23FF")
txList <- c("#38598CFF","#2BB07FFF","#C2DF23FF")

all <- ggplot(allBF, aes(x=BF, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(10),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=myList)+scale_fill_manual(values=myList)
all
all.trunc <- ggplot(allBF, aes(x=BF, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(0,10),color=c("grey55", "black"), linetype="dashed", size=0.5) +
  xlim(-50,50) + scale_color_manual(values=myList)+scale_fill_manual(values=myList)

all.trunc

a <- ggarrange(all,all.trunc, ncol=1, nrow=2, common.legend = TRUE, legend="right")
a
ggsave("Streicher_BF_Histo_all.jpg", plot=a, width = 40, height = 20, units = "cm")

tox <- ggplot(toxBF, aes(x=BF, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(10),color=c("black"), linetype="dashed", size=0.5) +
  scale_color_manual(values=txList)+scale_fill_manual(values=txList) +
  theme_bw() + theme(panel.border = element_blank()) +
  coord_cartesian(xlim=c(-90,90)) + scale_x_continuous(breaks=seq(-90,90,10))
tox.trunc <- ggplot(toxBF, aes(x=BF, fill=Hypothesis, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  theme_bw() + theme(panel.border = element_blank()) +
  geom_vline(xintercept=c(0,10),color=c("grey55", "black"), linetype="dashed", size=0.5) +
  xlim(-25,25) + scale_color_manual(values=txList)+scale_fill_manual(values=txList)

t <- ggarrange(tox,tox.trunc, ncol=1, nrow=2, common.legend = TRUE, legend="right")
t
ggsave("Streicher_BF_Histo_tox.jpg", plot=t, width = 40, height = 20, units = "cm")

# sclero avg vs pairwise
sc <- ggplot(ScleroBF, aes(fill=Hypothesis, x=BF, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(-10,10),color=c("black", "black"), linetype="dashed", size=0.5) +
  scale_color_manual(values="orange") + scale_fill_manual(values="orange") +
  theme_bw() + theme(panel.border = element_blank()) +
  coord_cartesian(xlim=c(-110,100)) + scale_x_continuous(breaks=seq(-110,100,10)) +
  labs(x="BF Sclero vs avg")
sc
sai <- ggplot(SaiBF, aes(fill=Hypothesis, x=BF, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(-10,10),color=c("black", "black"), linetype="dashed", size=0.5) +
  scale_color_manual(values="orange") + scale_fill_manual(values="orange") +
  theme_bw() + theme(panel.border = element_blank()) +
  coord_cartesian(xlim=c(-110,100)) + scale_x_continuous(breaks=seq(-110,100,10)) +
  labs(x="BF Sclero vs AngIg")
ssa <- ggplot(SsaBF, aes(fill=Hypothesis, x=BF, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(-10,10),color=c("black", "black"), linetype="dashed", size=0.5) +
  scale_color_manual(values="orange") + scale_fill_manual(values="orange") +
  theme_bw() + theme(panel.border = element_blank()) +
  coord_cartesian(xlim=c(-110,100)) + scale_x_continuous(breaks=seq(-110,100,10)) +
  labs(x="BF Sclero vs SnAng")
ssi <- ggplot(SsiBF, aes(fill=Hypothesis, x=BF, color=Hypothesis)) +
  geom_histogram(binwidth = 1, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(-10,10),color=c("black", "black"), linetype="dashed", size=0.5) +
  scale_color_manual(values="orange") + scale_fill_manual(values="orange") +
  theme_bw() + theme(panel.border = element_blank()) +
  coord_cartesian(xlim=c(-110,100)) + scale_x_continuous(breaks=seq(-110,100,10)) +
  labs(x="BF Sclero vs SnIg")

a <- ggarrange(sc,sai,ssi,ssa, ncol=1, nrow=4, legend = "none")
a

#ggsave("Streicher_BF_Histo_ScleroPairwise.jpg", plot=a, width = 20, height = 20, units = "cm")

##########Streicher_BF_Classic###########

myList <- c("orange","#38598CFF","#2BB07FFF","#C2DF23FF")
txList <- c("#38598CFF","#2BB07FFF","#C2DF23FF")

SC <- ggplot(data=ScleroBF) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF, color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("orange","grey40")) + scale_fill_manual(values=c("orange","grey40"))+
  labs(y="BF Hypoth - Average", title="Scleroglossa")
AI <- ggplot(data=ToxAngIgBF) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF,color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("#38598CFF","grey40")) + scale_fill_manual(values=c("#38598CFF","grey40"))+
  labs(y="BF Hypoth vs Average", title="(Anguimorph,Iguania)")
AI
SA <- ggplot(data=ToxSnAngBF) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF,color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("#2BB07FFF","grey40")) + scale_fill_manual(values=c("#2BB07FFF","grey40"))+
  labs(y="BF Hypoth vs Average", title="(Snakes,Anguimorph)")
SA
SI <- ggplot(data=ToxSnIgBF) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF,color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("#C2DF23FF","grey40")) + scale_fill_manual(values=c("#C2DF23FF","grey40"))+
  labs(y="BF Hypoth vs Average", title="(Snakes,Iguania)")
SI

all <- ggarrange(SC, AI, SA, SI, ncol=1, nrow=4, common.legend = TRUE, legend=FALSE)
all
ggsave("Streicher_BF_Classic_All.jpg", plot=all, width = 20, height = 40, units = "cm")

AI <- ggplot(data=ToxAngIgBFtx) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF,color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("#38598CFF","grey40")) + scale_fill_manual(values=c("#38598CFF","grey40"))+
  labs(y="BF Hypoth vs Average", title="(Anguimorph,Iguania)")
AI
SA <- ggplot(data=ToxSnAngBFtx) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF,color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("#2BB07FFF","grey40")) + scale_fill_manual(values=c("#2BB07FFF","grey40"))+
  labs(y="BF Hypoth vs Average", title="(Snakes,Anguimorph)")
SA
SI <- ggplot(data=ToxSnIgBFtx) +
  geom_bar(stat = "identity", position = position_dodge()) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  aes(x=reorder(Locus,-BF,sum),y=BF,color = BF < 0, fill = BF < 0) +
  scale_color_manual(values=c("#C2DF23FF","grey40")) + scale_fill_manual(values=c("#C2DF23FF","grey40"))+
  labs(y="BF Hypoth vs Average", title="(Snakes,Iguania)")
SI

all <- ggarrange(AI, SA, SI, ncol=1, nrow=3, common.legend = TRUE, legend=FALSE)
all
ggsave("Streicher_BF_Classic_Tox.jpg", plot=all, width = 20, height = 30, units = "cm")

# Not saved, histograms of locus types. should be split into different hypotheses for full information effect

all <- ggplot(allBF, aes(x=BF, fill=LocusType, color=LocusType)) +
  geom_histogram(binwidth = 5, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(10),color=c("black"), linetype="dashed", size=0.5) + ylim(0,200)

all

all.trunc <- ggplot(allBF, aes(x=BF, fill=LocusType, color=LocusType)) +
  geom_histogram(binwidth = 5, alpha=0.5, position="dodge") +
  geom_vline(xintercept=c(0,10),color=c("grey55", "black"), linetype="dashed", size=0.5) +
  xlim(-200,200)

all
all.trunc


datetime_to_seconds = function(dt) as.numeric(as.POSIXct(dt, origin="1970-01-01"))

clock_seconds = function() datetime_to_seconds(Sys.time())

seconds_to_clockface = function(s)
{
  hours = floor(s/60/60)
  minutes = floor((s - hours*60*60)/60)
  seconds = floor(s - hours*60*60 - minutes*60)

  list(hours=hours, minutes=minutes, seconds=seconds)
}

get_clockface = function(cf, label, reset=TRUE)
{
  sprintf("%s%02d:%02d:%02d", label, cf$hours, cf$minutes, cf$seconds)
}

print_clockface = function(cf, label, reset=TRUE)
{
  if (reset)
    cat("\r")

  cat(get_clockface(cf, label, reset))
}

audio_ping = function()
{
  cat("\a")
  if ("beepr" %in% utils::installed.packages())
    beepr::beep()
}

timer_clock = function(hours, minutes, seconds, recur=FALSE, over_time=TRUE)
{
  spacer = "    "
  total_seconds = 60*60*hours + 60*minutes + seconds

  ct = 0L
  while (TRUE)
  {
    t_top = clock_seconds() + total_seconds
    tot = seconds_to_clockface(total_seconds*ct)

    while (TRUE)
    {
      t = t_top - clock_seconds()
      if (t <= 0)
      break

      cf = seconds_to_clockface(t)
      if (isTRUE(recur))
      {
        print_clockface(cf, paste0("(reps ", ct, ")", spacer, "countdown: "))
        print_clockface(tot, paste0(spacer, "total: "), reset=FALSE)
      }
      else
        print_clockface(cf, "countdown: ")

      Sys.sleep(1)
    }

    audio_ping()
    if (isFALSE(recur))
    {
      cat("\n")
      break
    }

    ct = ct + 1L
  }

  while (over_time)
  {
    t = clock_seconds() - t_top + 1
    cf = seconds_to_clockface(t)
    print_clockface(cf, "time over: ")

    cat(spacer)

    t = clock_seconds() - t_top + total_seconds + 1
    cf = seconds_to_clockface(t)
    print_clockface(cf, "total time: ", reset=FALSE)
    Sys.sleep(1)
  }

  cat("\n")
  invisible(TRUE)
}


plot.yin.yang <- function(x=5, y=5, r=3, s=10, add=F){
	suppressMessages(require("plotrix"))
	if(!add) plot(1:10, type="n", xlim=c(0,s), ylim=c(0,s), xlab="", ylab="", xaxt="n", yaxt="n", bty="n", asp=1)
	draw.circle(x, y, r, border="white", col= "black")
	draw.ellipse(x, y, r, r, col="white", angle=0, segment=c(90,270), arc.only=F)
	draw.ellipse(x, y - r * 0.5, r * 0.5, r * 0.5, col="black", border="black", angle=0, segment=c(90,270), arc.only=F)
	draw.circle(x, y - r * 0.5, r * 0.125, border="white", col= "white")
	draw.circle(x, y + r * 0.5, r * 0.5, col="white", border="white")
	draw.circle(x, y + r * 0.5, r * 0.125, border="black", lty=1, col= "black")
	draw.circle(x, y, r, border="black")
}
png("yin_yang.png")
plot.yin.yang()
plot.yin.yang(1,7,1, add=T)
dev.off()


#a function similar to pegas::nuc.div(),
#pegas::nuc.div() will count the nucleotide difference between "a" & "-" as 0.
#nuc.div2() will treat the difference between "c" & "-" as normal, i.e. 1.

#get dependency
if(FALSE){
  require(magrittr)
  require(ape)
  require(pegas)
  source(file=R.home(component="RBioinfoZm/AnyEmpty().r"))
}

nuc.div2 <- function(x){
  #control the input of x-------------------------------------------------------
  if(is(object=x, class2="DNAbin")){
    if(AnyEmpty(x)){stop("DNAbin structure error");}
    if(is.list(x)) if(length(unique(lengths(x))) != 1){stop("DNAbin structure error");}
    x %<>% as.matrix() %>% pegas::haplotype()
  }
  if(!is(object=x, class2="haplotype")){
    stop("x must be a DNAbin object defined in ape, or haplotype object defined in pegas")
  }
  if(!is.matrix(x)){
    warning("please revise codes. when converting DNAbin to haplotype, it should be ",
            "automatically converted to matrix format.")
    x %<>% as.matrix()
  }
  wt <- attr(x=x, which="index") %>% lengths()
  x %<>% as.character()
  if(length(setdiff(x=unique(c(x)), y=c("a", "c", "g", "t", "-"))) != 0){
    stop("x contain invalid characters other than a, c, g, t, -.")
  }
  #main manipulation------------------------------------------------------------
  if(nrow(x) > 1){
    tulip <- utils::combn(x=1:nrow(x), m=2)
    ans_n_mismatch <- tulip %>% base::apply(MARGIN=2, FUN=function(datum, b){
      length(which(b[datum[1],] != b[datum[2],]))
    }, b=x)
    ans_wt <- tulip %>% base::apply(MARGIN=2, FUN=function(datum, b){
      b[datum[1]] * b[datum[2]]
    }, b=wt)
    tulip <- sum(ans_n_mismatch * ans_wt) / ncol(x) * 2 / sum(wt) / (sum(wt) - 1)#attention here!!!
    remove(ans_n_mismatch, ans_wt)
  }else{
    tulip <- 0
  }
  #clean environment and return results-----------------------------------------
  remove(x, wt)
  return(tulip)#remove(tulip)
}

#here are the test codes
if(FALSE){
  c("a", "c", "g", "t", "-") %>% rbind(.) %>% as.DNAbin() %>% nuc.div2()
  c("a", "c", "g", "t", "-") %>% rbind(., ., .) %>% as.DNAbin() %>% nuc.div2()
}


#Diffbot ezproxy Results Database
library(RSQLite)
library(topicmodels)
library(tidytext)
library(dplyr)
library(ggplot2)

conn <- dbConnect(RSQLite::SQLite(), "~/Git/EdLabResearch/ezproxy-research/ezproxy-DOI-old.db")

ezproxy_doi <- dbReadTable(conn, "ezproxy_doi")
subjects <- dbReadTable(conn, "subjects")
doi_subjects <- dbReadTable(conn, "doi_subjects")
users <- dbReadTable(conn, "ezproxy_users")
access_records <- dbReadTable(conn, "access_records")

userdata <- users[which(users$uni == "dnm2133"), "ezproxy_user_id"]
l <- ezproxy_doi[access_records[which(access_records$ezproxy_user_id == 14), "ezproxy_doi_id"], "title"]

subjectfreqpiedotchart <- function(doi_subjects) {
  piedata <- sort(table(doi_subjects$subject_id), decreasing = T)
  pie(piedata, labels = head(subjects[row.names(piedata),"subject"], 15))
  dotchart(head(piedata,50), labels = head(subjects[row.names(piedata),"subject"], 50), cex = 0.8)
}

get_dois_for_user <- function(user) {
  records <- access_records[which(access_records$ezproxy_user_id == which(users$uni == user)), "ezproxy_doi_id"]
  for (record in records) {
    i <- doi_subjects[which(doi_subjects$ezproxy_doi_id == record), "subject_id"]
    i
  }
}

library(janeaustenr)
book_words <- austen_books() %>%
  unnest_tokens(word, text) %>%
  count(book, word, sort = TRUE)

#subjectfreqpiedotchart(doi_subjects)

title_df <- tibble(text = ezproxy_doi$title, item = ezproxy_doi$ezproxy_doi_id)

title_words <- title_df %>%
  unnest_tokens(word, text) %>%
  count(item, word, sort = TRUE)

total_words <- title_words %>%
  group_by(item) %>%
  summarize(total = sum(n))

title_words <- left_join(title_words, total_words)

title_words <- title_words %>%
  bind_tf_idf(word, item, n) %>%
  filter(tf_idf > 0.4)

title_dtm <- title_words %>%
  cast_dtm(item, word, n)

title_LDA <- LDA(title_dtm, k=5, control = list(seed = 1234))

ezproxy_topics <- tidy(title_LDA, matrix = "beta")

ezproxy_top_terms <- ezproxy_topics %>%
  group_by(topic) %>%
  top_n(10, beta) %>%
  ungroup() %>%
  arrange(topic, -beta)

ezproxy_top_terms %>%
  mutate(term = reorder(term, beta)) %>%
  ggplot(aes(term, beta, fill = factor(topic))) +
  geom_col(show.legend = FALSE) +
  facet_wrap(~ topic, scales = "free") +
  coord_flip()

#count(text, sort = TRUE)


# read in monthly values, output seasonal and climate year totals

mD=read.csv("monthlyClimate.csv")

# add calendar year and season
mD$climYr=mD$year
mD$climYr[mD$month>9]=mD$climYr[mD$month>9]+1
mD$season="string"
mD$season[mD$month<=3]="Win"
mD$season[mD$month>3 & mD$month<=6]="Spr"
mD$season[mD$month>6 & mD$month<=9]="Sum"
mD$season[mD$month>9]="Fall"

# aggregate to calendar year and season and reshape
pptD=aggregate(PRCP~climYr+season,data=mD,FUN=sum)
pptD=reshape(pptD,timevar="season",idvar="climYr",direction="wide")
tmeanD=aggregate(TMEAN~climYr+season,data=mD,FUN=mean)
tmeanD=reshape(tmeanD,timevar="season",idvar="climYr",direction="wide")
seasD=merge(pptD,tmeanD,all=T)

# format for IPM
#seasD$pptAnnual=rowSums(seasD[,2:5])
#use July-June water year (to be consistent with old IPM model)
Nrows=NROW(seasD)
seasD$pptAnnual=c(NA,rowSums(seasD[2:Nrows,c("PRCP.Fall","PRCP.Win","PRCP.Spr")])+seasD$PRCP.Sum[1:(Nrows-1)])
seasD$ppt1=rowSums(seasD[,c(2,3,5)])
outD=seasD[,c("climYr","pptAnnual","ppt1","TMEAN.Spr")]
names(outD)=c("year","pptAnnual","ppt1","TmeanSpr1")
# add lag annual precip
tmpD=outD[,c("year","pptAnnual")]
tmpD$year=tmpD$year+1
names(tmpD)[2]="pptLag"
outD=merge(outD,tmpD,all.x=T)
# add next years ppt and tmean
tmpD=outD[,c("year","ppt1","TmeanSpr1")]
tmpD$year=tmpD$year-1
names(tmpD)[2:3]=c("ppt2","TmeanSpr2")
outD=merge(outD,tmpD,all.x=T)
outD=outD[,c("year","pptLag","ppt1","TmeanSpr1","ppt2","TmeanSpr2")]

write.csv(outD,"ClimateIPM.csv",row.names=F)


## get gene expression from Seurat object
## via function FetchData, where features
## correspond to i.e genes you wanna examine,
## slot corresponds to the data type you wanna
## get, FetchData returns a dataframe
data <- FetchData(object = object, vars = features, slot = data)

features <- colnames(x = data) # get gene names
cells <- colnames(x = object) # cell identity

# extract genes expression of cell indentity of interest
# which would downsample the data if cell identity is set
data <- data[cells, , drop = FALSE]

# extract group/condition info of each cell
# using cell identity as index, here are 2
# groups in total
idents <- object[["group", drop = TRUE]][cells]

# if idents is not factor
# idents <- factor(x = idents)

# extract genes expression of features(genes) of interest
data = data[, features, drop = FALSE]

# ridge plot via ggridges
library(ggridges)
ggplot(data, aes(x = data[, "Sparcl1"], y = idents)) +
  geom_density_ridges(aes(fill = idents)) +
  scale_fill_manual(values = c("#00AFBB", "#E7B800"))

Ridge plot of Seurat object via ggridges.r


# What does this code do?
# It runs multiple models to predict scores for the next Cartola round.

# O que esse script faz?
# Você rodará vários modelos para tentar predizer a próxima rodada do cartola.
# Ele é muito experimental. Vários modelos *demoram* tempo para convergir e parte do código pode estar quebrada.
# Uai, cadê o banco de dados? O banco de dados é gerado a partir da execução do script 'merge_all_years.R'. Leia os comentários do script para gerá-lo.

# Set the last cartola round
# Definir a rodada que quer prever
round <- 33

# Load libraries
# Carregar pacotes
library(caret)
library(dplyr)
library(parallel)
library(doParallel)

#%%%%%%%%%%%%%%%%%%%%%%%%%
# Subset Data Frame
#%%%%%%%%%%%%%%%%%%%%%%%%%
# source("lib/R/merge_all_years.R")

# Remove cases with no data
# Remover casos de jogadores que não participaram de partidas
df <- subset(cartola, cartola$Participou == TRUE | cartola$PrecoVariacao != 0)

# Pick only a subset of variables
# Selecionar somente variáveis que são candidatas a preditores
variaveis <- c(2, 3, 5, 7, 8, 29, 32:67, 73:77)
df <- df[, variaveis]

# Remove nearzero variance predictors
# Remover preditores com pouca informação
nzv <- nearZeroVar(df)
df <- df[, -nzv]

# Split training and validation
# Separar banco de dados de treino e validação
treino <- df %>%
  filter(!(Rodada == (round - 1) & ano == 2017))

validacao <- df %>%
  filter(Rodada == (round - 1) & ano == 2017)

# Selecionar somente resultados completos para validação
validacao <- validacao[complete.cases(validacao), ]

# Controles para os modelos
# Definir uma semente para garantir replicabilidade dos resultados
set.seed(123)
## Regression Models
ctrl <- trainControl(method = "repeatedcv", number = 10, allowParallel = TRUE, verboseIter = TRUE)
rfGrid <-  expand.grid(mtry = c(8))
rfGrid_1 <-  expand.grid(mtry = c(5:15))
rfGrid_2 <-  expand.grid(mtry = c(10,15,20,25,30))
rfGrid_final <-  expand.grid(mtry = 30)
eXGBGrid <-  expand.grid(nrounds = 150,
                         max_depth = c(3:5),
                         colsample_bytree = .8,
                         eta = .4,
                         subsample = .8,
                         gamma = 0,
                         min_child_weight = 1
                         )

###########
# Modeling
###########

###################
# Baseline
###################
glmModel_0  <- train(Pontos ~ PontosMedia, data = treino,
                     method="glm", metric = "RMSE", preProcess = c("scale", "center"), na.action = na.pass,
                     trControl = ctrl)
glmModel_0

###################
# GLM
###################
glmModel_1  <- train(Pontos ~ ., data = treino,
                     method="glm", metric = "RMSE", preProcess = c("scale", "center"), na.action = na.pass,
                     trControl = ctrl)
glmModel_1

###################
# Partial Least Square
###################
pls_0  <- train(Pontos ~ ., data = treino,
                method="pls", metric = "RMSE", preProcess = c("scale", "center"), na.action = na.pass,
                trControl = ctrl, tuneLength = 20)
pls_0

###################
# GBM
###################
boostModel  <- train(Pontos ~ ., data = treino,
                     method="gbm", metric = "RMSE",
                     preProcess = c("scale", "center"), na.action = na.pass,
                     trControl = ctrl)

###################
# Neural Networks
###################
nnModel  <- train(Pontos ~ ., data = treino,
                     method="nnet", metric = "RMSE",
                     preProcess = c("scale", "center"), na.action = na.pass,
                     trControl = ctrl)

###################
# eXtreme G Boosting
###################
eXModel  <- train(Pontos ~ . , data = treino,
                  method="xgbTree", metric = "RMSE",
                  preProcess = c("scale", "center"), na.action = na.pass,
                  trControl = ctrl)

# Tune model with better parameters based on prior experience
eXModel_v1  <- train(Pontos ~ . , data = treino,
                  method="xgbTree", metric = "RMSE",
                  preProcess = c("scale", "center"), na.action = na.pass,
                  tuneGrid = eXGBGrid, trControl = ctrl)

# Transform data to deal with outliers before running model
eXModel_v1_out  <- train(Pontos ~ . , data = treino,
                     method="xgbTree", metric = "RMSE",
                     preProcess = c("scale", "center", "spatialSign"), na.action = na.omit,
                     tuneGrid = eXGBGrid, trControl = ctrl)

###################
# SVM
###################
svmModel  <- train(Pontos ~ . , data = treino,
                  method="svmRadial", metric = "RMSE",
                  preProcess = c("scale", "center"), na.action = na.pass,
                  trControl = ctrl)

###################################
# RANDOM FOREST
###################################
ptm <- proc.time()
fit.raf_1 <- train(Pontos ~.,
                 data=treino,
                 method="ranger",
                 preProcess=c("center","scale"),
                 tuneGrid = rfGrid_1,
                 trControl=ctrl,
                 metric="RMSE",
                 na.action = na.omit,
                 verbose = TRUE
)
proc.time() - ptm

ptm <- proc.time()
modellist <- list()
for (ntree in c(1000,1500,2000)) {
  fit.raf_2 <- train(Pontos ~.,
                     data=treino,
                     method="ranger",
                     preProcess=c("center","scale"),
                     tuneGrid = rfGrid_2,
                     trControl=ctrl,
                     metric="RMSE",
                     na.action = na.omit,
                     verbose = TRUE)
  key <- toString(ntree)
  modellist[[key]] <- fit.raf_2
}
proc.time() - ptm

fit.raf_final <- train(Pontos ~.,
                   data=treino,
                   method="ranger",
                   preProcess=c("center","scale"),
                   tuneGrid = rfGrid_final,
                   trControl=ctrl,
                   metric="RMSE",
                   na.action = na.omit,
                   verbose = TRUE
)

fit.raf_f_out <- train(Pontos ~.,
                       data=treino,
                       method="ranger",
                       preProcess=c("center","scale", "spatialSign"),
                       tuneGrid = rfGrid_final,
                       trControl=ctrl,
                       metric="RMSE",
                       na.action = na.omit,
                       verbose = TRUE
)

#stopCluster(cluster)

###################
# COMPARE MODELS
###################

# Random Forest models
rf_results <- resamples(modellist)
summary(rf_results)
# From this model we can assume the number of tree is equal to 1000, mtry = 30, RMSE = 3.05.

models <- list(eXB = eXModel, glm = glmModel_0, pls = pls_0, NeurN = nnModel, GBM = boostModel,
               SVM = svmModel)

predictions_rf <- predict(fit.raf, newdata = validacao)
postResample(pred = predictions_rf, obs = validacao$Pontos)

predictions_raf_1 <- predict(fit.raf_1, newdata = validacao)
postResample(pred = predictions_raf_1, obs = validacao$Pontos)

predictions_raf_2 <- predict(modellist[[1]], newdata = validacao)
postResample(pred = predictions_raf_2, obs = validacao$Pontos)

predictions_rf_final <- predict(fit.raf_final, newdata = validacao)
postResample(pred = predictions_rf_final, obs = validacao$Pontos)

# Other models
results <- resamples(models)
summary(results)
bwplot(results)
dotplot(results)

predictions_glm <- predict(glmModel_0, newdata = validacao)
postResample(pred = predictions_glm, obs = validacao$Pontos)

predictions_pls <- predict(pls_0, newdata = validacao)
postResample(pred = predictions_pls, obs = validacao$Pontos)

predictions_exb <- predict(eXModel, newdata = validacao)
postResample(pred = predictions_exb, obs = validacao$Pontos)

predictions_nn <- predict(nnModel, newdata = validacao)
postResample(pred = predictions_nn, obs = validacao$Pontos)

predictions_gbm <- predict(boostModel, newdata = validacao)
postResample(pred = predictions_gbm, obs = validacao$Pontos)

predictions_svm <- predict(svmModel, newdata = validacao)
postResample(pred = predictions_svm, obs = validacao$Pontos)

# Best EGB Models
predictions_exb1 <- predict(eXModel_v1, newdata = validacao)
postResample(pred = predictions_exb1, obs = validacao$Pontos)

predictions_exb1_out <- predict(eXModel_v1_out, newdata = validacao)
postResample(pred = predictions_exb1_out, obs = validacao$Pontos)

summary(validacao$Pontos)
summary(predictions_glm)
summary(predictions_pls)
summary(predictions_exb1)
summary(predictions_rf_final)
summary(predictions_nn)
summary(predictions_gbm)
summary(predictions_svm)

# Remove home.score and away.score variables
df_pred_r <- df_pred
df_pred_r2 <- df_pred_r[complete.cases(df_pred_r), ]

# Create predictions based on specific model
df_pred_r2$next_round <- predict(eXModel_v1_out, df_pred_r2)
df_pred_r2 <- arrange(df_pred_r2, - next_round)

# Subset by position
ata <- subset(df_pred_r2, df_pred_r2$Posicao == "ata")
mei <- subset(df_pred_r2, df_pred_r2$Posicao == "mei")
zag <- subset(df_pred_r2, df_pred_r2$Posicao == "zag")
lat <- subset(df_pred_r2, df_pred_r2$Posicao == "lat")
gol <- subset(df_pred_r2, df_pred_r2$Posicao == "gol")
tec <- subset(df_pred_r2, df_pred_r2$Posicao == "tec")

# Write predictions as csv
write.csv(df_pred_r2[, c("Apelido","ClubeID","Posicao", "Preco", "risk_points", "next_round", "pred.home.score", "pred.away.score", "variable")], "~/rodada22.csv", row.names = FALSE)

# Create tables to select players
ata[,c("Apelido","ClubeID","Posicao", "Preco", "risk_points", "next_round", "pred.home.score", "pred.away.score", "variable")]


#loop into the fragments and extract the values for t-test. The values are either
#distance of half-life or intensity.
t_test_function <- function(data, par, par1, cdt1, cdt2, frag){
    data[,paste0("p_value_distance_", par)] <- NA
    for (i in seq_along(frag)) {
        print(i)
        par.cd1 <- data[which(data[,paste0(par,"_comb_fragment")] == frag[i]),
                        paste0(par1, ".", cdt1)]
        par.cd2 <- data[which(data[,paste0(par,"_comb_fragment")] == frag[i]),
                        paste0(par1, ".",cdt2)]
        if (length(par.cd1) < 3 | length(par.cd2) < 3 | par.cd1 == par.cd2) {
            next ()
        }
        t_h <-
            t.test(par.cd1,
                   par.cd2,
                   alternative = "two.sided",
                   var.equal = FALSE)
        #fill in the dataframe with the p_value
        data[which(data[,paste0(par,"_comb_fragment")] == frag[i]),
             paste0("p_value_distance_", par)] <- t_h[[3]]
    }
    return(data)
}