#!/usr/bin/env Rscript

library(tidyverse)
library(parallel)
library(CoRC)
library(boot)
#library(gganimate)
#library(gifski)

# how many days are simulated
prediction_days <- 21

# function to bootrap mean values
fnmean <- function(d, i){
  d2 <- d[i,]
  return(mean(d2$UCH))
}

# read experimental data
datafile = "CT-Hartford-COVID19.tsv"
data_experimental <-  read_tsv(datafile)

# serial number of the day of this iteration, in the last row of data file
today <- as.double( data_experimental$'#day'[NROW(data_experimental)])

# which models to processget
modelnos <- c(7,11,14)

for (modelno in modelnos)
{
 modelfname <- sprintf("SIDARTHE-CT-Hartford_Model%d-%d.cps",modelno,today)
 newmodelfname <- sprintf("SIDARTHE-CT-Hartford_Model%d_stoch-%d.cps",modelno,today)
 # deal with each model

 loadModel(modelfname)

 # change the name
 mname <- sprintf("SIDARTHE Hartford Model %d stochastic",modelno)
 setModelName(mname)
 # let's run the model until the last day with data
 runTimeCourse(duration = today, intervals = 1, update_model = TRUE, executable = TRUE, method = "deterministic")
 # set the initial time back to zero, as previous run set it to today
 setInitialTime(0)
 # update the parameters that have changed
 setGlobalQuantities("alpha", initial_value = getGlobalQuantities(key = quantity_strict("alpha"))$value)
 setGlobalQuantities("beta", initial_value = getGlobalQuantities(key = quantity_strict("beta"))$value, initial_expression = NULL )
 setGlobalQuantities("gamma", initial_value = getGlobalQuantities(key = quantity_strict("gamma"))$value, initial_expression = NULL )
 setGlobalQuantities("delta", initial_value = getGlobalQuantities(key = quantity_strict("delta"))$value, initial_expression = NULL )
 setGlobalQuantities("theta", initial_value = getGlobalQuantities("theta")$value)
 setGlobalQuantities("epsilon", initial_value = getGlobalQuantities("epsilon")$value)
 # remove the explicit ODEs as these don't work with stochastic simulation
 deleteGlobalQuantity("Diagnosed Cumulative infected")
 deleteGlobalQuantity("Recovered")
  # remove all events
 deleteEvent("Day 08")
 deleteEvent("Day 11")
 deleteEvent("Day 15")
 deleteEvent("Day 21")
 deleteEvent("Day 32")
 deleteEvent("Day 60")
 deleteEvent("Day 67")
 deleteEvent("Day 75")
 deleteEvent("Day 73 ReOpenStage 4")
 deleteEvent("Seeding")
 deleteEvent("T no new case")
 deleteEvent("T peak detection")
 # set the time course parameters for the stochastic simulation
 setTimeCourseSettings(duration = prediction_days, dt = 1, executable = TRUE, save_result_in_memory = TRUE,  method = list(method = "directMethod", use_random_seed = T) )

 # save the model
 saveModel(newmodelfname)
 unloadModel()

 # run stochastic simulations in parallel
 cl <- makeCluster(detectCores())
 clusterExport(cl,"newmodelfname")
 clusterCall(cl = cl, function(){library(CoRC); loadModel(newmodelfname); NULL } )
 rtc <- function(x) return(runTimeCourse(method = list(random_seed = x))$result)
 timeseries <- parLapplyLB(cl = cl, 1:1000,  rtc)
 stopCluster(cl)

 # select just the data we need
 data1 <-
   timeseries %>%
   bind_rows() %>%
   select(Time,UCH) # %>%
 # function for get bootstrap percentile confidence intervals
 btl <- function(x) {
     bootm <-boot(x, fnmean, R=500)
     bp <- boot.ci(boot.out = bootm, type = c("perc"))
     return(bp)
     }
 # function to filter out all values for a single time point
 tp <- function(i){return(filter(data1, Time==i))}
 # define a list of all time points
 times <- as.list(seq (1,prediction_days,1))
 # bootstrap mean values and get list of confidence intervals for each time point
 cis <- lapply(lapply(times, tp),btl)
 # shape the data format to contain
 data2 <- data1 %>%
   group_by(Time) %>%
   summarise_all(list(mean=mean,sd=sd,min=min,max=max))
  # put lower ci bounds in vector
 data2$ci_lb <- append(c(data2$mean[1]),unlist(lapply(times,function(i){cis[[i]]$percent[4]})))
 # put upper ci bounds in vector
 data2$ci_ub <- append(c(data2$mean[1]),unlist(lapply(times,function(i){cis[[i]]$percent[5]})))
 # offset the values of time
 data2$Time <- data2$Time + today
 data2 = rename(data2, "#Time" = Time)
 datafname <-  sprintf("TStoch-%d-%d.tsv",modelno,today)
 write.table(data2, file = datafname, row.names = FALSE, sep = "\t")
 #plotT <- ggplot(plotdata, aes(UCH)) + geom_histogram(binwidth=1, color="black", fill="cyan", aes(y=..density..)) +
 #          geom_density(size=2, color=rgb(0,0.5,0.5,0.8)) + theme_classic(base_size=14) +
 #         labs(title = 'Distribution: t={frame_time}', x = 'UCH', y = 'density')
 #anim_save(plotT, nframes = 21, renderer = gifski_renderer("test.gif"))

 #ggsave("Harford-distri-t20.gif",plot=plotT, path="/home/mendes/UCHC/COVID19/Report")
}


library(xgboost)
library(magrittr)
library(dplyr)
library(Matrix)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# keep away training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with too many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# class imbalance problem
hist(as.numeric(finalData$DE) - 1, col = 'blue', main = 'Class Imbalance', xlab = 'FALSE = 0 \t TRUE = 1', ylim = c(0,length(finalData$DE)))
#XGBoost Model Parameters
constant_params <- list(booster = 'gbtree',
                        silent = 0,
                        objective = 'binary:logistic',
                        eval_metric = 'error',
                        gamma = 0,
                        early.stop.round = 50
)
tunable_params_grid <- expand.grid(eta = (1:6)*0.05,
                                   nrounds = (1:6)*150,
                                   max_depth = c(4:9),
                                   subsample = c(0.6:1),
                                   colsample_bytree = c(0.5,0.8,1)
)
colnames(tunable_params_grid) <- c("eta", "nrounds", "max_depth", "subsample", "colsample_bytree")
currParams <- as.data.frame(matrix(data = NA, nrow = 1, ncol = ncol(tunable_params_grid) + 5))
colnames(currParams) <- c(colnames(tunable_params_grid), "Accuracy", "AUC", "F1score", "trainingLength", "testingLength")
currParams <- tunable_params_grid[sample(nrow(tunable_params_grid), size = 1), ] #sample random combination and train the trees
currParams[c(1:20),c(1:5)] <- currParams
numModels <- 20; #increase
n <- nrow(finalData)
split <- .99
# measure time while decreasing training set
for (i in 1:numModels){
  print(paste0("building model", i))
  # set seed
  set.seed(123)
  # shuffle data
  finalData <- finalData[sample(nrow(finalData)),]
  # enconding
  label <- ifelse(test = finalData[,'DE'] == TRUE, yes = 1, no = 0)
  train.index = sample(n, split*n)
  train.data = as.matrix(sapply(finalData[train.index,-ncol(finalData)], as.numeric))
  train.label = label[train.index]
  test.data = as.matrix(sapply(finalData[-train.index,-ncol(finalData)], as.numeric))
  test.label = label[-train.index]
  trainm = xgb.DMatrix(data=train.data,label=train.label)
  testm = xgb.DMatrix(data=test.data,label=test.label)
  test.label <- as.factor(ifelse(test = test.label == 1, yes = TRUE, no = FALSE))
  # Train Model
  xgbModel <- xgb.train(params = constant_params,
                        eta = currParams[i, "eta"],
                        nrounds = currParams[i, "nrounds"],
                        max_depth = currParams[i, "max_depth"],
                        subsample = currParams[i, "subsample"],
                        colsample_bytree = currParams[i, "colsample_bytree"],
                        data = trainm,
                        verbose = 0)
  # Predict
  xgb.pred <- predict(xgbModel, test.data)
  xgb.pred <- as.data.frame(xgb.pred)
  pred.class <- ifelse(test = xgb.pred > 0.5, yes = TRUE, no = FALSE)
  # Evaluate model
  confusionMatrix(data = as.factor(pred.class), reference = test.label, positive = 'TRUE')
  # accuracy
  currParams[i, "Accuracy"] <- Accuracy(y_pred = pred.class, y_true = test.label)
  pred_obj = prediction(xgb.pred, test.label, label.ordering = c("FALSE", "TRUE"))
  # auc
  currParams[i, "AUC"] <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
  # f1score
  currParams[i, "F1score"] <- F1_Score(y_true = test.label, y_pred = pred.class, positive = 'TRUE')
  currParams[i, "trainingLength"] <- nrow(train.data)
  currParams[i, "testingLength"] <- nrow(test.data)
  split <- split - .05
}
saveRDS(object = currParams[,c(6:10)], file = "./test/xgbAccAucF1.rds")


# Data Wrangling in R
# Social Security Disability Case Study

# Load the tidyverse
library(tidyverse)
library(lubridate)
library(stringr)

# Read in the coal dataset
ssa <- read_csv("http://594442.youcanlearnit.net/ssadisability.csv")

# Take a look at how this was imported
glimpse(ssa)

# Make the dataset long
ssa_long <- gather(ssa, month, applications, -Fiscal_Year)

# And what do we get?
print(ssa_long, n=20)


suppressMessages(library(fmlr))

m = 2
n = 3
x = cpumat(m, n)

source("internals/common.r")
source("internals/mat.r")


# R code to plot heatmap (all 377 radiomics features)
library("openxlsx")
library("stringr")
library(ComplexHeatmap)
library(circlize)
library(colorspace)
library(GetoptLong)
library(ggplot2)
library(gplots)

library("RColorBrewer")

# install.packages('OpasnetUtils')
library(reticulate)

data_path = "./Data/"
output_path = "./Results/"

# load all features
xlfeatures = read.xlsx(paste(data_path , "allBlockData.xlsx",sep = ""), sheet = 1, colNames = TRUE)

xlfeatures = data.frame(xlfeatures)

colnames(xlfeatures)

features = xlfeatures[,3:length(colnames(xlfeatures))]

# fat volumes (ml), age
features$Age <- features$Age*10
features$VFat <- features$VFat*1000
features$SFat <- features$SFat*1000

length(colnames(features))

features[1,1:377]

imagefeatures = features[, 1:(length(colnames(features))-9)]
imagefeatures = scale(imagefeatures)
features[, 1:(length(colnames(features))-9)] = imagefeatures

features = features[c(colnames(imagefeatures), 'Age', 'Gender', 'VFat' ,'SFat', 'IsCTVO', 'IsIR' ,'IsMS')]

# plot heatmap
ha1 = HeatmapAnnotation(df = features[,378:length(colnames(features))],
    col = list(

               IsCTVO = c("1"="Orange","0"="blue"), IsIR = c("1"="purple","0"="darkgreen"),
                IsMS = c("1"="Brown","0"="green"),
        Gender = c("1"= "pink", "0"= "darkgray")

    ),

     annotation_legend_param = list(
               IsCTVO = list(title = "Visceral Obesity (CT)", at = c("1", "0"), labels = c("Yes", "No")),
               IsIR = list(title = "Insulin Resistance", at = c("1", "0"), labels = c("Yes", "No")),
         VFat = list(title = "Visceral Fat"),
         SFat = list(title = "Subcutaneous Fat"),
      IsMS = list(title = "Metabolic Syndrome", at = c("1", "0"), labels = c("Yes", "No")),
       Gender = list(title = "Gender", at = c("1", "0"), labels = c("Female", "Male"))

      )
   )

ht = Heatmap(t(features[,1:377]), name = "Z-Score",row_names_gp = gpar(fontsize = 8),
        show_row_dend = FALSE,show_column_dend = FALSE, cluster_rows = TRUE,
        cluster_columns = TRUE, show_row_names = FALSE, show_column_names = FALSE,clustering_distance_columns = "pearson",
        show_heatmap_legend = TRUE,
       ,top_annotation=ha1)

p = draw(ht, heatmap_legend_side = "right")
decorate_annotation("IsIR", {grid.text("Insulin Resistance", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("IsCTVO", {grid.text("Visceral Obesity (CT)", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("IsMS", {grid.text("Metabolic Syndrome", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("Age", {grid.text("Age", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("Gender", {grid.text("Gender", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("SFat", {grid.text("Subcutaneous Fat(ml)", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("VFat", {grid.text("Viceral Fat(ml)", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})

# save to file
title = paste(output_path , "inner_block_for_heatmap_allfeatures.tif",sep = "")
tiff(title, width=900*3, height=800*3, units="px", res=96*3, compression = "lzw")
p = draw(ht, heatmap_legend_side = "right")
decorate_annotation("IsIR", {grid.text("Insulin Resistance", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("IsCTVO", {grid.text("Visceral Obesity (CT)", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("IsMS", {grid.text("Metabolic Syndrome", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("Age", {grid.text("Age", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("Gender", {grid.text("Gender", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("SFat", {grid.text("Subcutaneous Fat(ml)", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
decorate_annotation("VFat", {grid.text("Viceral Fat(ml)", unit(1, "npc") + unit(2, "mm"), 0.5, default.units = "npc", just = "left" , gp = gpar(fontsize = 10))})
dev.off()


library(ggplot2)

refugees = c(23,175,15543,11,338796,1244,63,53)
asylumseekers = c(140,77,2872,6,255,91,6,7)
origins = c('Burundi','Dem. Rep. of the Congo', 'Eritrea', 'Rwanda', 'Somalia','South Sudan','Sudan','Uganda')
countries <- factor(origins)

print(qplot(refugees, asylumseekers, color = countries))


#Script for SET thermal comfort index calculation using any number of cases or csv files

#---Set the working directory to this file path, to ensure the correct linking
setwd(dirname(rstudioapi::getSourceEditorContext()$path))
code_path <- getwd()

source("f(x) setashrae.R")
input_path <- paste0(code_path,"/datasets/setashrae_fast_input")
output_path <- paste0(code_path,"/datasets/setashrae_fast_output")

#---Get file names in full or short length
name.full=list.files(path=input_path,pattern="*.csv",full.names=TRUE)
print(name.full)
name.short=list.files(path=input_path,pattern="*.csv")
print(name.short)

#---Get the colunm length of the first file
num.files=length(x=name.full)
print(num.files)
get.col=length(read.table(file=name.full[1],header=TRUE,sep=",",
                          as.is=TRUE,na.strings=TRUE))

#---Set the class of all colunms to numeric
classes.n=NULL
classes.n[1:get.col]="numeric"
i=1

#---Loop in the input folder files
for (i in 1:num.files) #---change to num.files
{

  file.i=read.table(file=name.full[i],header=TRUE,sep=",",
                    as.is=TRUE,na.strings=TRUE,colClasses=classes.n)

  num.col=ncol(file.i)
  num.row=nrow(file.i)

  #---input(CLO,MET,WME,TA,TR,VEL,RH,PA,APA)
  CLO.j=file.i[,"CLO"]
  MET.j=file.i[,"MET"]
  WME.j=file.i[,"WME"]
  TA.j=file.i[,"TA"]
  TR.j=file.i[,"TR"]
  VEL.j=file.i[,"VEL"]
  RH.j=file.i[,"RH"]
  PA.j=file.i[,"PA"]
  APA.j=101.325 #---Use default

  SET.ashrae=mapply(setashrae,CLO.j,MET.j,WME.j,TA.j,TR.j,VEL.j,RH.j,APA.j)

  #---Output files
  output.file=data.frame(SET.ashrae)
  name.output=as.character(paste0(output_path,"/output_",name.short[i]), sep ="")
  write.table(output.file,file=name.output,row.names=FALSE,col.names=TRUE,sep = ",")

  print(paste("file ",i," finished",sep=""))
}


#!/usr/bin/env Rscript

### Read a CosmoSIS standard output file, and generate a series of 1-
### and 2-dimensional posterior probability density plots.

suppressPackageStartupMessages(library("optparse"))
suppressPackageStartupMessages(library("lattice"))
suppressPackageStartupMessages(library("MASS"))    # for kde2d

### Create a dataframe from CosmoSIS output. We expect the first line of
### the output to contain the names of the parameters, separated by
### spaces, and with section names separated from parameter names by a
### double-hyphen.

make.data.frame <- function(fname, burn)
{
  d <- read.table(fname)
  # Remove the first 'burn' elements
  d <- d[-c(1:burn),]
  first <- readLines(fname, n=1)
  first <- sub("#", "", first)          # Remove comment
  parts <- strsplit(first, "\t")[[1]]   # split on tabs
  cols <- sub("[a-zA-Z_]+--", "", parts) # remove leading section names
  names(d) <- cols
  likes <- exp(d$like)
  norm <- sum(likes)
  d$l <- likes/norm
  return(d)
}

# Make a 1-d posterior density plot for each variable in the dataframe.
# We use bw="nrd", which gives a bandwidth calculation according to:
#    Scott, D. W. (1992) Multivariate Density Estimation: Theory, Practice, and
#    Visualization. Wiley.
make.1d.density.plots <- function(df, prefix, output, device, verbose)
{
  cols <- Filter(function(n) { ! n %in% c("l","LIKE") }, names(dframe))
  for(col in cols)
  {
    if (verbose) cat("Making 1-d density plot for", col, "\n")
    dev.fcn <- get(device)
    filename <- file.path(output, paste(prefix, "_", col, ".", device, sep=""))
    form = as.formula(paste("~", col, sep=""))
    dev.fcn(filename)
    print(densityplot( form
                     , df
                     , type="l"
                     , lwd=2
                     , panel = function(...)
                     {
                       panel.grid(-1,-1)
                       panel.densityplot(...)
                     }
                     , ylab = "posterior probability density"
                     , plot.points = FALSE
                     , bw = "nrd"
                     ))
    invisible(dev.off())
  }
}

find.contours <- function(kde, levels = c(0.68, 0.95))
{
  probs.sorted <- sort(kde$z, decreasing=TRUE)
  probs.cs <- cumsum(probs.sorted)
  # Get the indices of the first values greater than the given confidence levels.
  indices <- sapply( levels
                   , function(x) which(probs.cs>x)[1]
                   )
  probs.sorted[indices]
}

# vmat2df will convert the kind of list returned by kde2d (containing two)
# vectors and a matrix, named x, y and z) into a dataframe with columns
# x, y, z.
vmat2df <- function(u)
{
  g = expand.grid(u$x, u$y)
  data.frame( x = g$Var1, y = g$Var2, z = as.numeric(u$z))
}

# Make a 2-d density plot of  xcol vs. ycol, using data from df.
make.2d.density.plot <- function( df, xcol, ycol, prefix, output, device
                                , use.color
																, nbins)
{
  kde <- kde2d(df[,xcol], df[,ycol], n=nbins	)

  # kde$x and kde$y carry the bin co-ordinates.
  # kde$z carries the estimated density at (x,y). We convert kde$z into
  # the probability for the corresponding bin. We could multiply the density
  # by the area of the bin, but encounter less trouble from rounding if we
  # normalize the sum to 1.
  norm <- sum(kde$z)
  kde$z <- kde$z/norm

  # Find the values of z which correspond to the given confidence levels.
  conf.levels = c(0.68, 0.95)
  zvals = find.contours(kde, conf.levels)

  # Convert from vectors+matrix to dataframe, to use lattice plotting.
  d <- vmat2df(kde)

  dev.fcn <- get(device)
  filename <- file.path( output
                       , paste(prefix, "_", xcol, "_", ycol, ".", device, sep=""))
  levels <- c(0, zvals, 1)
  labels <- as.character(c(0, conf.levels, 1))
  p <- contourplot( z~x*y, d, at=levels, labels=labels
                  , panel=function(...){panel.grid(-1,-1); panel.contourplot(...)}
                  , xlab = xcol
                  , ylab = ycol
                  , region = use.color
                  , lwd=2
                  , col.regions = function(n,a) rev(terrain.colors(n,a))
                  , colorkey = FALSE
                  )
  dev.fcn(filename)
  print(p)
  invisible(dev.off())
}

# For each pair, generate the kde2d result matrix.
# Determine the values of z at which the 68% and 95% contour lines lie.
# Transform the matrix to a dataframe.
# Make the contour plot.

make.2d.density.plots <- function(df, prefix, output, device, verbose, use.color, nbins)
{
  # Go through all pairs of interesting variables (all but 'LIKE' and 'l',
  # the last two columns).
  n.interesting <- ncol(df)-2
  cols <- names(df)[1:n.interesting]
  pairs <- combn(cols, 2, simplify=FALSE)
  for(pair in pairs)
  {
    xcol <- pair[[1]]
    ycol <- pair[[2]]
    if (verbose) cat("Making 2-d density plot of", xcol, "vs.", ycol, "\n")
    make.2d.density.plot(df, xcol, ycol, prefix, output, device, use.color, nbins)
  }

}

################################################################################
###
### Start of the main program.

option_list <-
  list( make_option( c("-v", "--verbose")
                   , action="store_true"
                   , default = FALSE
                   , help = "Print extra output [%default]"
                   )
      , make_option( c("-p", "--prefix")
                   , default="plot"
                   , type="character"
                   , help="Prefix for all output files"
                   )
      , make_option( c("-o", "--output")
                   , default="."
                   , type="character"
                   , help="Directory for all output files"
                   )
      , make_option( c("-d", "--device")
                   , default="png"
                   , type="character"
                   , help="Graphics device for plots: png or pdf"
                   )
      , make_option( c("-f", "--fill")
                   , action="store_true"
                   , default=FALSE
                   , help="Color regions in 2-d density plots"
                   )
      , make_option( c("-b", "--burn")
                   , default = 0
                   , type="integer"
                   , help="Number of burn-in samples to ignore [%default]"
                   )
      , make_option( c("-n", "--nbins")
                   , default = 101
                   , type = "integer"
                   , help="Number of bins in KDE for each of x and y [%default]"
                   )
      )

parser <- OptionParser(option_list=option_list, usage="%prog [options] infile")
args   <- parse_args(parser, positional_arguments = TRUE)
opt    <- args$options

if (length(args$args) != 1)
{
  cat("Incorrect number of required arguments\n\n")
  print_help(parser)
  stop()
}

input.file <- as.character(args$args)
if (file.exists(input.file) == FALSE )
{
  cat("Unable to open input file", input.file, "\n")
  stop()
}

if (opt$output != ".")
  if (! file.exists(opt$output))
    dir.create(opt$output, recursive=TRUE)

opt$device <- tolower(opt$device)

if (opt$device %in% c("png", "pdf") == FALSE)
{
  cat("Device", opt$device, "is not supported, using png\n")
  opt$device <- "png"
}

if (opt$verbose)
   cat("Processing file", input.file, "\n")

dframe = make.data.frame(input.file, opt$burn)
make.1d.density.plots(dframe, opt$prefix, opt$output, opt$device, opt$verbose)
make.2d.density.plots(dframe, opt$prefix, opt$output, opt$device, opt$verbose, opt$fill, opt$nbins)


library(ggplot2)
library(dplyr)
library(tidyr)
library(usdata)

setwd("/Users/merekmecham/Documents/INFO201/a3-merekmecham/")

filename <- "https://raw.githubusercontent.com/vera-institute/incarceration-trends/master/incarceration_trends.csv"
data <- read.csv(filename)

by_race <- data %>%
  select(year, aapi_jail_pop, black_jail_pop, latinx_jail_pop, native_jail_pop, white_jail_pop) %>%
  filter(year >= 2010) %>%
  gather(key = race, value = population, -year)

chart_one <- ggplot(by_race) +
  geom_col(
    mapping = aes(x = year, y = population, fill = race), position = "dodge",
    alpha = .5
  ) +
  labs(
    title = "Jail Population Rates Among Different Races",
    x = "Year",
    y = "Jail Population Rate",
    fill = "Race"
  )
comparison <- data %>%
  select(year, total_jail_pop, black_jail_pop) %>%
  filter(year >= 1984) %>%
  gather(key = pop_type, value = jail_pop, -year)
chart_two <- ggplot(comparison) +
  geom_col(
    mapping = aes(x = year, y = jail_pop, fill = pop_type), position = "dodge",
  ) +
  labs(
    title = "Total Jail Populations vs. Black Jail Populations",
    x = "Year",
    y = "Population",
    fill = "Population Type"
  )

black_rate <- data %>%
  filter(year == 2018) %>%
  select(state, black_jail_pop)

blank_theme <- theme_bw() +
  theme(
    axis.line = element_blank(),
    axis.text = element_blank(),
    axis.ticks = element_blank(),
    axis.title = element_blank(),
    plot.background = element_blank(),
    panel.grid.major = element_blank(),
    panel.grid.minor = element_blank(),
    panel.border = element_blank(),
  )
state_shape <- map_data("state") %>%
  rename(state = region) %>%
  mutate(state = state2abbr(state))

map <- state_shape %>%
  left_join(black_rate, by = "state")

black_map <- ggplot(map) +
  geom_polygon(
    mapping = aes(x = long, y = lat, group = group, fill = black_jail_pop),
    color = "white",
    size = .3
  ) +
  coord_map() +
  scale_fill_continuous(low = "#fee8c8", high = "#de2d26") +
  labs(title = "Black Jail Population in 2018", fill = "Black Jail Population") +
  blank_theme


library(dplyr)
library(tidyr)

###########################################################################################################
# in this script we calculate the accuracy values for each participant
###########################################################################################################
d <- read.csv("all_data.csv")

###########################################################################################################
# we first get the total observations per participant and group
# mode ordered distance and if it was correct or not
###########################################################################################################
d$correct_num[is.na(d$correct_num)] <- FALSE
d$correct_dual[is.na(d$correct_dual)] <- FALSE

dat <- d
unique_prob_codes <- unique(dat$prob_code)

dat <- dat %>% filter(practice == FALSE)  %>%
    group_by(prob_code,mode,ordered,distance,correct_num)   %>% summarise( total_observations=n() )

dat$total_observations[is.na(dat$total_observations)] <- 0

dat <- data.frame(dat)
dat <- reshape(dat, idvar=c("prob_code","mode","ordered","distance"), timevar = c("correct_num"), direction="wide")

# replace na values with 0
dat$total_observations.FALSE[is.na(dat$total_observations.FALSE)] <- 0
dat$total_observations.TRUE[is.na(dat$total_observations.TRUE)] <- 0
dat$accuracy <- dat$total_observations.TRUE / (dat$total_observations.TRUE+dat$total_observations.FALSE)

write.csv(dat,file="data_accuracy.csv",row.names=FALSE,na="")

############################################################################################################
# get dual task accuracy.
############################################################################################################
dat <- d

dat <- dat %>% filter(practice == FALSE) %>% filter(mode == "dual_vis" | mode == "dual_phon")  %>%
    group_by(prob_code,mode,correct_dual)   %>% summarise( total_observations=n() )

dat$total_observations[is.na(dat$total_observations)] <- 0

dat <- data.frame(dat)

dat <- reshape(dat, idvar=c("prob_code","mode"), timevar = c("correct_dual"), direction="wide")

# replace na values with 0
dat$total_observations.FALSE[is.na(dat$total_observations.FALSE)] <- 0
dat$total_observations.TRUE[is.na(dat$total_observations.TRUE)] <- 0
dat$accuracy <- dat$total_observations.TRUE / (dat$total_observations.TRUE+dat$total_observations.FALSE)

write.csv(dat,file="data_accuracy_p_participant_dual.csv",row.names=FALSE,na="")


library(plotrix)
x <- c(11, 6.3, 6.1, 6.1, 5.6, 5.2, 2.0, 1.8, 1.8, 1.6)
lbl <- c("Russia", "China", "Canada", "USA", "Brazil", "Australia", "India", "Argentina", "Kazakstan", "Algeria")
pie3D(x, labels = lbl, explode=0.1, main = "3D Pie Chart Of The World's Largest Countries (In Terms Of Landmass)")


sapply(mapply(compose,f1,f2),do.call,list(.5))
[1] 0.5 0.5 0.5


#' Unit Testing script for NMF package: seeding methods.
#'
#' @author Renaud Gaujoux
#' @creation 17 Jul 2009

# make the internal functions/objects visible
if( isNamespaceLoaded('NMF') ){
	seed <- NMF:::seed
}

.testData <- function(n=20, r=3, m=10, ...){
	syntheticNMF(n, r, m, ...)
}

#' Unit test for seeding method: none
test.none <- function(){

	# create a random target matrix
	r <- 3; V <- .testData(r=r)
	n <- nrow(V); m <- ncol(V);

	# seed with the matrix
	obj <- seed(V, r, 'none')
	checkTrue( is(obj, 'NMFfit') , "Seeded object is an instance of class 'NMFfit'")
	checkTrue( is(fit(obj), 'NMFstd') , "Seeded model is an instance of class 'NMFstd'")
	checkTrue( is.empty.nmf(obj), 'Should not initialize the NMF object')
	checkEquals( nbasis(obj), r, 'Seeded object have the correct rank')

	# seed with empty object
	obj.init <- nmfModel(r)
	obj <- seed(V, obj.init, 'none')
	checkTrue( identical(fit(obj), obj.init), 'Empty object: seeded object is identical to the initial one')

	# seed with dummy object
	obj.init <- nmfModel(r, model='NMFstd', W=matrix(seq(n*r), n, r), H=matrix(seq(r*m), r, m))
	obj <- seed(V, obj.init, 'none')
	checkTrue( identical(fit(obj), obj.init), 'Dummy object: seeded object is identical to the initial one')

}

#' Utility function for \code{test.seed}: performs a set of test on a seeded object
check.seed <- function(title, obj, V, r, seeding.meth, expect.class, exact.class=TRUE){

	checkTrue( inherits(obj, 'NMFfit'), paste(title, ": result class inherits from 'NMFfit'") )
	checkTrue( inherits(fit(obj), 'NMF'), paste(title, ": model class inherits from 'NMF'") )

	if( exact.class )
		checkTrue( is(fit(obj), expect.class), paste(title, ": default class returned is '", expect.class, "'") )
	else
		checkTrue( inherits(fit(obj), expect.class), paste(title, ": default class returned inherits from '", expect.class, "'") )

	checkTrue( !is.empty.nmf(obj) , paste(title, ": Seeded object is not empty"))
	checkEquals( nbasis(obj), r , paste(title, ": Seeded object has correct rank"))
	checkEquals( nrow(obj), nrow(V) , paste(title, ": Seeded object has correct number of rows"), checkNames=FALSE)
	checkEquals( ncol(obj), ncol(V) , paste(title, ": Seeded object has correct number of columns"), checkNames=FALSE)
	checkEquals( seeding(obj), seeding.meth, "Seeding method's name is correctly set")

}

#' Unit test for compatibility of algorithms and seeding methods
test.zzz.all <- function(){

	set.seed(123)
	# create a random target matrix
	r <- 3; V <- .testData(r=r)
	n <- nrow(V); m <- ncol(V);

	# list the available algorithms
	algorithms <- nmfAlgorithm()
	algorithms <- algorithms[!algorithms %in% c('ls-nmf', 'pe-nmf', 'siNMF')]
	# list the available seeding methods
	seed.methods <- nmfSeed()
	seed.methods <- seed.methods[which(seed.methods != 'none')]

	test_algo <- function(name.algo, ..., target_rank=r){
		sapply(seed.methods,
				function(name.seed, ...){
					message("\n###########\n# ", name.algo, " + ", name.seed, "\n#############")
					err <- try(obj <- nmf(..., method=name.algo, seed=name.seed))
					checkTrue( !is(err, 'try-error'), paste('Run OK - Algo:', name.algo, '+ Seed:', name.seed, if( is(err, 'try-error') ) paste('[Error: ', err, ']') else NULL) )
					check.seed(paste('Algo:', name.algo, '+ Seed:', name.seed), obj, V, target_rank, name.seed, 'NMF', exact.class=FALSE)
				}
		, ...)
	}

	# all algorithms
	sapply(algorithms, test_algo, V, r)
	# PE-NMF
	test_algo('pe-nmf', V, r, alpha=1, beta=0.1)
	# LS-NMF
	test_algo('ls-nmf', V, r, weight=rmatrix(V))
	# siNMF
	g <- gl(2, m/2)
	test_algo('siNMF', V ~ g, r, target_rank=r+2)
}

#' Utility check function: checks the range of value in a NMF object
check.range <- function(title, nmf.fit, max){
	obj <- fit(nmf.fit)
	checkTrue( all(basis(obj) <= max & basis(obj) >= 0), paste(title, ': All entries of W are between 0 and', max) )
	checkTrue( all(coef(obj) <= max & coef(obj) >= 0), paste(title, ': All entries of H are between 0 and', max) )
}

#' Unit test for seeding method: random
test.random <- function(){

	.seedTest <- 123456
	# create dummy matrix
	V.na <- matrix(NA, 50, 20)
	r <- 3

	# check the range of the generated values
	obj <- seed(V.na, r, 'random')
	check.range('NA matrix', obj, 1)

	max <- 0.05
	obj <- seed(matrix(max, 50, 20), r, 'random')
	check.range(paste('Matrix', max), obj, max)

	# seed with the matrix
	set.seed(.seedTest)
	obj <- seed(V.na, r, 'random')
	check.seed('With matrix', obj, V.na, r, 'random', 'NMFstd')

	# test randomness
	obj2 <- seed(V.na, r, 'random')
	checkTrue( !identical(obj2, obj), 'Seeded objects are different if seed has not been fixed before seeding')
	# test reproducibility
	set.seed(.seedTest)
	obj.bis <- seed(V.na, r, 'random')
	checkTrue( nmf.equal(obj.bis, obj), 'Seeded NMF models are identical if seed has been reset to the same value before seeding')

	# seed with object
	set.seed(.seedTest)
	nmfOff <- nmfModel(r, model='NMFOffset')
	obj <- seed(V.na, nmfOff, 'random')
	max <- 1
	check.seed('With NMFOffset object', obj, V.na, r, 'random', 'NMFOffset')
	check.range(paste('Object NMFOffset', max), obj, max)
	checkTrue( all(offset(fit(obj)) <= max & offset(fit(obj)) >= 0), paste('Object NMFOffset: All entries of Offset are between 0 and', max) )

	# seed with numeric value
	res <- seed(V.na, r, .seedTest)
	# manually reset name for seeding method
	set.seed(.seedTest)
	checkTrue( nmf.equal(seed(V.na, r, 'random'), res), "Seeded NMF models are identical when setting random generator seed and call method 'seed' with the same numerical seed (except for name of seeding method)")

}

check.seed.change <- function(msg, expr, base){

	bs <- .Random.seed
	e <- parent.frame()
	eval(expr, env=e)

	if( base ) checkTrue( any(bs != .Random.seed), paste(msg, ": .Random.seed IS changed"))
	else checkIdentical(bs, .Random.seed, paste(msg, ": .Random.seed is NOT changed"))

}

#' Unit tests for checking the impact of seeding nmf computation on the .Random.seed
test.seed.effect <- function(){
	# set random seed
	set.seed(123456)
	# create a random target matrix
	r <- 3; V <- .testData(r=r)

	# Single runs
	check.seed.change("After single run without seed", nmf(V, r), TRUE)
	check.seed.change("After single run without seed (NO-REPRO has no effect)", nmf(V, r), TRUE)
	check.seed.change("After single run with seed", nmf(V, r, seed=123), FALSE)
	#
	# Multiple runs: NO seed
	check.seed.change("After multiple runs without seed (sapply)", nmf(V, r, nrun=3, .opt='-p'), TRUE)
	check.seed.change("NO-REPRO: After multiple runs without seed (sapply)", nmf(V, r, nrun=3, .opt='-pR'), TRUE)
	check.seed.change("After multiple runs without seed (foreach-MC)", nmf(V, r, nrun=3, .opt='P', .pbackend='par'), TRUE)
	check.seed.change("NO-REPRO: After multiple runs without seed (foreach-MC)", nmf(V, r, nrun=3, .opt='P-R', .pbackend='par'), TRUE)
	check.seed.change("After multiple runs without seed (foreach-SEQ)", nmf(V, r, nrun=3, .opt='P', .pbackend='seq'), TRUE)
	check.seed.change("NO-REPRO: After multiple runs without seed (foreach-SEQ)", nmf(V, r, nrun=3, .opt='P-R', .pbackend='seq'), TRUE)

	# Multiple runs: WITH numeric seed
	check.seed.change("After multiple runs with seed (sapply)", nmf(V, r, nrun=3, seed=1234, .opt='-p'), FALSE)
	check.seed.change("NO-REPRO: After multiple runs with seed (sapply)", nmf(V, r, nrun=3, seed=1234, .opt='-pR'), FALSE)
	check.seed.change("After multiple runs with seed (foreach-MC)", nmf(V, r, nrun=3, seed=1234, .opt='P', .pback='par'), FALSE)
	check.seed.change("NO-REPRO: After multiple runs with seed (foreach-MC)", nmf(V, r, nrun=3, seed=1234, .opt='P-R', .pback='par'), FALSE)
	check.seed.change("After multiple runs with seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=1234, .opt='P', .pback='seq'), FALSE)
	check.seed.change("NO-REPRO: After multiple runs with seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=1234, .opt='P-R', .pback='seq'), FALSE)

	# Multiple runs: WITH NA seed
#	check.seed.change("After multiple runs with NA seed (sapply)", nmf(V, r, nrun=3, seed=NA, .opt='-p'), FALSE)
#	check.seed.change("NO-REPRO: After multiple runs with NA seed (sapply)", nmf(V, r, nrun=3, seed=NA, .opt='-pR'), TRUE)
#	check.seed.change("After multiple runs with NA seed (foreach-MC)", nmf(V, r, nrun=3, seed=NA, .opt='P', .pback='par'), FALSE)
#	check.seed.change("NO-REPRO: After multiple runs with NA seed (foreach-MC)", nmf(V, r, nrun=3, seed=NA, .opt='P-R', .pback='par'), FALSE)
#	check.seed.change("After multiple runs with NA seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=NA, .opt='P', .pback='seq'), FALSE, TRUE)
#	check.seed.change("NO-REPRO: After multiple runs with NA seed (foreach-SEQ)", nmf(V, r, nrun=3, seed=NA, .opt='P-R', .pback='seq'), TRUE)
}

#' test the restoration of the random seed
test.restore <- function(){

	DEACTIVATED("The option 'restore.seed' is deprecated. Related tests are now in test.seed.effect")

	# create a random target matrix
	r <- 3; V <- .testData(r=r)

	# default call no seed
	os <- .Random.seed
	nmf(V, r)
	checkTrue( !(all.equal(os, .Random.seed) == TRUE ), "call with no seed: seed is correctly NOT restored")

	# default call
	os <- .Random.seed
	nmf(V, r, seed=1)
	checkIdentical(os, .Random.seed, "Default behaviour is to restore the seed: seed is correctly restored")

	# force restore
	os <- .Random.seed
	nmf(V, r, .opt='r', seed=12)
	checkIdentical(os, .Random.seed, "force seed restoration with 'r': seed correctly restored")
	os <- .Random.seed
	nmf(V, r, .opt=list(restore.seed=TRUE), seed=123)
	checkIdentical(os, .Random.seed, "force seed restoration with 'restore.seed=TRUE': seed correctly restored")

	# do not restore
	os <- .Random.seed
	nmf(V, r, .opt='-r', seed=1234)
	checkTrue( !(all.equal(os, .Random.seed) == TRUE), "Disable seed restoration with '-r': seed correctly NOT restored")
	os <- .Random.seed
	nmf(V, r, .opt=list(restore.seed=FALSE), seed=12345)
	checkTrue( !(all.equal(os, .Random.seed) == TRUE), "force seed restoration with 'restore.seed=FALSE': seed correctly NOT restored")

}

#' Unit test for seeding method: Non-Negative Double SVD (nndsvd)
test.nndsvd <- function(){

	.seedTest <- 123456
	set.seed(.seedTest)

	# create a random target matrix
	r <- 3; V <- .testData(r=r)

	# perform NMF with seed 'nndsvd'
	check.seed.change('seeding with "nndsvd"', obj <- seed(V, r, 'nndsvd'), FALSE)
	check.seed('With matrix', obj, V, r, 'nndsvd', 'NMF')
	# redo: should be the same (one needs identical=FALSE because svd() may return slightly different values)
	obj.bis <- seed(V, r, 'nndsvd')
	checkTrue( nmf.equal(obj.bis, obj, identical=FALSE), 'Seeded NMF models are identical for every run')

}


library(tidyr)
library(magrittr)
library(reticulate)
library(cowplot)
library(ggbeeswarm)
source("config.r")

np <- import("numpy")
data <- np$load(
  "./outputs/all_scores_camcan_error_decomposition.npy",
# "all_scores_mag_models_mnecommonsubjects.npy",
  allow_pickle = T)

data_mod_comp <- np$load(
  "./outputs/all_scores_models_camcan_mae_shuffle-split.npy",
# "./outputs/all_scores_mag_models_mnecommonsubjects_interval_rep-kfold.npy",
# "all_scores_mag_models_mnecommonsubjects.npy",
  allow_pickle = T)[[1]] %>%
  as.data.frame()

data_comp_scores <- read.csv(
  "outputs/camcan_component_scores.csv",
  stringsAsFactor = T
)

data_comp_scores_long <- data.frame(
  score = c(data_comp_scores$spoc, data_comp_scores$riemann),
  estimator = factor(rep(c("SPoC", "Riemann"),
                         each = nrow(data_comp_scores))),
  n_components = rep(data_comp_scores$n_components, times = 2),
  fold_idx = factor(rep(data_comp_scores$fold_idx, times = 2))
)

agg_scores <- aggregate(cbind(spoc, riemann) ~ n_components,
                        data = data_comp_scores, FUN = mean)
dummy_mean <- mean(data_mod_comp$dummy)

n_folds <- length(data[[1]]$leadfield$spoc)
sim_names <- names(data[[1]])
n_sim_models <- length(sim_names)

model_names_ <- names(data[[1]]$full)
model_names <- model_names_[c(5, 3, 4, 2, 1)]
model_labels <- c(
  sprintf("Riemann[%d]", which.min(agg_scores$riemann)),
          "Riemann",
  sprintf("SPoC[%d]", which.min(agg_scores$spoc)),
          "SPoC", "diag")

n_models <- length(model_names)
n_rows <- n_folds * n_sim_models * n_models

get_long <- function() {
  scores <- c()
  estimator <- c()
  simulation <- c()
  for (simu in sim_names){
    for (model in model_names){
      print(model)
      scores <- c(scores, data[[1]][[simu]][[model]])
      estimator <- c(estimator, rep(model, n_folds))
      simulation <- c(simulation, rep(simu, n_folds))
    }
  }
  data.frame(
    score = scores,
    estimator = estimator,
    generator = simulation
)}

data_long <- get_long()
data_long$estimator <- factor(data_long$estimator, levels = model_names)

data_long$generator <- factor(data_long$generator, levels = sim_names)

print(
  aggregate(score~estimator*generator, data_long, mean))

data_diff <- do.call("rbind", by(
  data_long,
  list(data_long$estimator, data_long$generator),
  FUN = function(x){
    x_ref <- data_long[data_long$generator == "full" &
                       data_long$estimator == x$estimator[[1]],]
    data.frame(
      score = x$score - mean(x_ref$score),
      estimator = x$estimator,
      generator = x$generator)
}))
levels(data_diff$estimator)

my_colors <- setNames(
  with(color_cats, c(black, vermillon, orange)),
  c("full", "power", "leadfield")
)
my_labels <- setNames(
  c("full", "leadfield + power", "leadfield"),
  c("full", "power", "leadfield")
)

data_diff$score <- -data_diff$score

data_plot <- rbind(data_long, data_diff)
data_plot$mode <- 'absolute'
data_plot$mode[(nrow(data_plot) / 2 + 1):nrow(data_plot)] <- 'diff'
data_plot$mode <- factor(data_plot$mode)
data_plot$hline <- dummy_mean
data_plot$hline[data_plot$mode == 'diff'] <- 0

fun_breaks <- function(x) {
  if (min(x) > 0) c(6, 8, 10, 12, 14, 16) else c(-10, -8, -6, -4, -2, 0)
}

data_plot$est_type <- gsub(
  sprintf("spoc_%d", which.min(agg_scores$spoc)),
  "spoc", data_plot$estimator)
data_plot$est_type <- gsub(
  sprintf("riemann_%d", which.min(agg_scores$riemann)),
  "riemann", data_plot$est_type)

model_labels_best <- model_labels[!model_names %in% c("riemann", "spoc")]

model_labels_shape <- model_labels[
  model_names %in% c("log-diag", "riemann", "spoc")]
model_names_shape <- model_names[
  model_names %in% c("log-diag", "riemann", "spoc")]

shape_labels <- setNames(
  model_labels_shape,
  model_names_shape
)

shape_values <- setNames(
  c(0, 1, 2),
  model_names_shape
)

annot_data <- data.frame(
  x = c(3, 5),
  y = c(dummy_mean, 0),
  label = c("predicting~bar(age)", "full[i]-bar(full)"),
  mode = c("absolute", "diff"))

fig_error <- ggplot(
    data = subset(data_plot, score < 18 & score > -10 &
                  !estimator %in% c("riemann", "spoc")),
    mapping = aes(y = score,
                  x = interaction(estimator, generator),
                  shape = est_type,
                  color = generator,
                  fill = generator)) +
  geom_beeswarm(alpha=0.25, size = 2, cex = 1.1) +
  coord_flip() +
  geom_boxplot(alpha = 0.25, outlier.shape = NA, width = 0.9) +
  facet_wrap(.~mode,  scales = 'free_x') +
  scale_x_discrete(
    labels = parse(text = rep(model_labels_best, times = n_sim_models))) +
  guides(shape = guide_legend(title = 'Estimator')) +
  scale_color_manual(breaks = names(my_colors),
                     values = my_colors,
                     labels = my_labels,
                     name = 'Generator') +
  scale_fill_manual(breaks = names(my_colors),
                    values = my_colors,
                    labels = my_labels,
                    name = 'Generator') +
  scale_shape_manual(breaks = names(shape_values),
                     values = shape_values,
                     labels = shape_labels,
                     name = 'Estimator') +
  my_theme +
  scale_y_continuous(breaks = fun_breaks) +
  geom_hline(aes(yintercept = hline),
             linetype = 'dashed',
             color = color_cats[["black"]]) +
  geom_text(
    data = annot_data,
  aes(y = y, x = x, label = label),
    color = color_cats[['black']], vjust = -0.5,
    angle = 270,
    inherit.aes = F,
    parse = T,
    size = annotate_text_size) +
  ylab("MAE") +
  xlab("Model") +
  theme(legend.position = c(0.6, 0.5))

fig_error

fname <- './outputs/fig_error_decomposition'
ggsave(paste0(fname, '.pdf'),
       plot = fig_error, width = 10, height = 4,
       useDingbats = FALSE)
embedFonts(file = paste0(fname, ".pdf"), outfile = paste0(fname, ".pdf"))

ggsave(paste0(fname, '.png'),
       plot = fig_error, width = 10, height = 4)


# sliding window size
window_size <- 100000

# turn off scientific notation for output with large numbers in sliding windows
options(scipen=999)

# read in simple vcf
vcf_names <- c("Dryobates_nuttallii_KU123600", "Dryobates_scalaris_KU128764", "Dryobates_scalaris_KU128776", "Dryobates_scalaris_KU128777", "Dryobates_scalaris_KU29797", "Dryobates_scalaris_KU30061", "Dryobates_nuttallii_KU123601", "Dryobates_nuttallii_KU131213", "Dryobates_nuttallii_KU29815", "Dryobates_nuttallii_KU29816", "Dryobates_pubescens_KU11987", "Dryobates_pubescens_KU130208", "Dryobates_pubescens_KU132134", "Dryobates_pubescens_KU15939")

# read in reference index
x <- read.table("Picoides_pubescens.fa.fai", sep="\t")
x.list <- as.character(x[x[,2] >= 1000000,1]) #scaffold list of those > 1 Mbp

# TE polymorphisms
MELT <- read.table("MELT_for_ROH.txt", sep="\t", stringsAsFactors=F, header=T)

# individual runs of homozygosity
roh <- read.table("runs_of_homozygosity.txt", sep="\t", stringsAsFactors=F, header=T)

# TEs
TEs <- read.table("repeatmask.txt", sep="\t", stringsAsFactors=F)

# genes
genes <- read.table("genes.txt", sep="\t", stringsAsFactors=F)

# loop for each scaffold
# output headers = scaffold, start, end, prop TEs, prop genes
output <- c()
for(a in 1:length(x.list)) {
	num_windows <- floor(x[x[,1] == x.list[a], 2] / window_size)
	start <- 1
	end <- window_size
	a_TEs <- TEs[TEs[,1] %in% x.list[a], ]
	a_genes <- genes[genes[,1] %in% x.list[a], ]
	# for each window
	for(b in 1:num_windows) {
		b_TEs <- a_TEs[a_TEs[,2] >= start & a_TEs[,2] <= end | a_TEs[,3] >= start & a_TEs[,3] <= end,]
		b_genes <- a_genes[a_genes[,2] >= start & a_genes[,2] <= end | a_genes[,3] >= start & a_genes[,3] <= end,]
		if(nrow(b_TEs) > 0) {
			b_TEs[b_TEs[,3] > end, 3] <- end
			b_TEs[b_TEs[,2] < start, 2] <- start
			b_seq <- c()
			for(c in 1:nrow(b_TEs)) {
				b_seq <- c(b_seq, b_TEs[c,2]:b_TEs[c,3])
			}
			b_TE_count <- length(unique(b_seq)) / window_size
		} else {
			b_TE_count <- 0
		}
		if(nrow(b_genes) > 0) {
			b_genes[b_genes[,3] > end, 3] <- end
			b_genes[b_genes[,2] < start, 2] <- start
			b_seq <- c()
			for(c in 1:nrow(b_genes)) {
				b_seq <- c(b_seq, b_genes[c,2]: b_genes[c,3])
			}
			b_gene_count <- length(unique(b_seq)) / window_size
			if(b_gene_count > 1) {
				print(c(a,b))
			}
		} else {
			b_gene_count <- 0
		}
		output <- rbind(output, c(x.list[a], start, end, b_TE_count, b_gene_count))
		start <- start + window_size
		end <- end + window_size
	}
}
output <- data.frame(Scaffold=as.character(output[,1]), Start=as.numeric(output[,2]), End=as.numeric(output[,3]), Prop_TEs=as.numeric(output[,4]), Prop_Genes=as.numeric(output[,5]))

# loop for each individual
output2 <- list()
for(a in 1:length(vcf_names)) {
	a_roh <- roh[roh[,1] == vcf_names[a],]
	a_melt <- MELT[MELT[,1] == vcf_names[a],]
	output_rep <- c()
	# loop for each window
	for(b in 1:nrow(output)) {
		b_roh <- a_roh[a_roh[,2] == output[b,1], ]
		b_roh <- b_roh[b_roh[,3] >= output[b,2] & b_roh[,3] <= output[b,3] | b_roh[,4] >= output[b,2] & b_roh[,4] <= output[b,3],]
		b_melt <- a_melt[a_melt[,2] == output[b,1],]
		b_melt <- b_melt[b_melt[,3] >= output[b,2] & b_melt[,3] <= output[b,3],]
		sum_NR_TE <- nrow(b_melt)
		sum_NR_TE_poly <- nrow(b_melt[b_melt$het == "het",])
		if(nrow(b_roh) > 0) {
			b_roh[b_roh[,4] > output[b,3], 3] <- output[b,3]
			b_roh[b_roh[,3] < output[b,2], 2] <- output[b,2]
			sum_b_roh <- sum(b_roh[,4] - b_roh[,3] + 1) / window_size
		} else {
			sum_b_roh <- 0
		}
		output_rep <- rbind(output_rep, c(as.character(output[b,1]), as.numeric(output[b,2:5]), sum_b_roh, sum_NR_TE, sum_NR_TE_poly))
	}
	output2[[a]] <- output_rep
}

# convert all output to dataframes
for(a in 1:length(vcf_names)) {
	output2[[a]] <- data.frame(Scaffold=as.character(output2[[a]][,1]), Start=as.numeric(output2[[a]][,2]), End=as.numeric(output2[[a]][,3]), Prop_ROH=as.numeric(output2[[a]][,6]), Prop_TEs=as.numeric(output2[[a]][,4]), Prop_Genes=as.numeric(output2[[a]][,5]), Num_NR_TEs=as.numeric(output2[[a]][,7]), Num_Poly_NR_TEs=as.numeric(output2[[a]][,8]))
}

# correlation coefficients for each individual
require(Hmisc)
output_corr <- c()
for(a in 1:length(vcf_names)) {
	a_rep <- rcorr(as.matrix(output2[[a]][,4:8]))$r
	a_rep <- c(vcf_names[a], as.vector(a_rep[2:nrow(a_rep), 1]))
	output_corr <- rbind(output_corr, a_rep)
}
output_corr <- data.frame(Individual=as.character(output_corr[,1]), TE_corr=as.numeric(output_corr[,2]), Gene_Corr=as.numeric(output_corr[,3]), Num_NR_TEs_corr=as.numeric(output_corr[,4]), Num_Poly_NR_TEs_corr=as.numeric(output_corr[,5]))

# confidence intervals on correlation coefficients
require(boot)
require(DescTools)
bootstrap.effect <- function(input, indices) {
	d <- input[indices]
	d <- FisherZ(d)
	d <- mean(d)
	d <- FisherZInv(d)
	return(d)
}

output3 <- c()
# tes
results <- boot(data=output_corr$TE_corr, statistic=bootstrap.effect, R=1000)
ci <- boot.ci(results)
ci2 <- c("TEs", mean(results$data), ci$bca[4:5])
output3 <- rbind(output3, ci2)

# genes
results <- boot(data=output_corr$Gene_Corr, statistic=bootstrap.effect, R=1000)
ci <- boot.ci(results)
ci2 <- c("Genes", mean(results$data), ci$bca[4:5])
output3 <- rbind(output3, ci2)

#non-reference tes
results <- boot(data=output_corr$Num_NR_TEs_corr, statistic=bootstrap.effect, R=1000)
ci <- boot.ci(results)
ci2 <- c("NR_TEs", mean(results$data), ci$bca[4:5])
output3 <- rbind(output3, ci2)

# polymorphic non-reference tes
results <- boot(data=output_corr$Num_Poly_NR_TEs_corr, statistic=bootstrap.effect, R=1000)
ci <- boot.ci(results)
ci2 <- c("NR_Poly_TEs", mean(results$data), ci$bca[4:5])
output3 <- rbind(output3, ci2)

output3 <- data.frame(Dataset=as.character(output3[,1]), Mean=as.numeric(output3[,2]), CI_low=as.numeric(output3[,3]), CI_high=as.numeric(output3[,4]))
write(paste("# Mean effect sizes (correlation coefficients) with ROH proportion per 100 kbp window"), file="per_100kbp_window_effect_sizes.txt", sep="\t")
write.table(output3, file="per_100kbp_window_effect_sizes.txt", sep="\t", row.names=F, quote=F, append=T)


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Determinants of taxonomic resources flow: data analysis (GLM)
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Set up
source('2019-06-19-jsa-type-ch3-flow/analysis1/prep.R')
source('2019-06-19-jsa-type-ch3-flow/analysis1/data_analysis1b.R')

# Libraries
library(tidyr)
library(car)
library(ResourceSelection) # mcfadden
library(pscl)              # hoslem
library(caret)             # cross validation
# library(ROCR)            # roc

# Process data  ------------------------------------------------------------------------------------
# Read and process describer data
auth <- get_des(write=F)
auth <- auth[ns_spp_N >=1,c("idx_auth", "residence.country.describer.n")]
auth <- data.table(auth %>% separate_rows(residence.country.describer.n, sep="; "))
auth_N <- auth[residence.country.describer.n != "[unknown]", list(N_taxonomist=.N),
               by=c("residence.country.describer.n")]
auth <- auth[, idx:= 1:.N, by=c("idx_auth")]
auth <- auth[!duplicated(idx_auth)]
auth <- unique(auth[residence.country.describer.n != "[unknown]"]$residence.country.describer.n)

# Read bee data
df <- fread(paste0(dir_data_ch3_flow, "2019-11-01-flow-GLM.csv"), encoding="UTF-8")
df <- df[class_check != 'Unclassed']
df <- df[continent_ori != 'Unclassed']
df <- df[ori %in% auth]
df <- merge(df, auth_N, by.x="ori", by.y="residence.country.describer.n", all.x=T, all.y=F)
df <- unique(df)

# Remove where ori and des are same
df <- df[ori!=des]

sapply(df[, 5:10], unique)
sapply(df[, 5:10], table)
table(df$ori)

# Derived values
df$prop_flow <- ifelse(df$N_flow==0, 0, df$N_flow / df$N_total)
df$N_self <- df$N_total-df$N_flow
df$flow <- ifelse(df$N_flow >0, "Yes",  "No")

# Create factors
df$continent_check <- factor(df$continent_check, levels=c("Different continent", "Same continent"))
df$class_check <- factor(df$class_check, levels=c("Equal", "Low-to-high", "High-to-low"))
df$col_check <- factor(df$col_check, levels=c("Not colonised", "Colonised"))
df$adj_check <- factor(df$adj_check, levels=c("Not adjacent", "Adjacent"))
df$continent_ori <- factor(df$continent_ori,
                           levels=c("Africa", "Oceania", "Asia", "Australia",
                                    "South America", "North America",  "Europe"))
df$continent_des <- factor(df$continent_des,
                           levels=c("Africa", "Oceania", "Asia", "Australia",
                                    "South America", "North America",  "Europe"))
df$Class_ori <- factor(df$Class_ori,
                       levels= c("Upper middle income", "Low income",
                                 "Lower middle income", "High income"))
df$Class_des <- factor(df$Class_des,
                       levels= c("Upper middle income", "Low income",
                                 "Lower middle income", "High income"))
df$flow <- factor(df$flow, levels=c("No", "Yes"))
any(sapply(df, function(x) any(is.na(x))))

# Create model -------------------------------------------------------------------------------------
# Model 1: predict binary
# baseline: Same continent, equal class, not colonised, not adjacent, Australia, Low income

# Using number of taxonomists
a1 <- glm(flow ~ continent_check + adj_check + col_check + class_check + N_taxonomist,
          data=df, family="binomial")
# anova(a0, a1, test="Chisq") # if significant = keep complex model

# Using origin continent
table(df$flow)
a1 <- glm(flow ~ continent_check + adj_check + col_check + class_check + continent_ori + continent_des,
          data=df, family=binomial)
# in v1 i was using logit (assumes flow has equal classes)
# see https://fukamilab.github.io/BIO202/04-B-binary-data.html
# to change to cloglog as flow is highly inbalanced
# this resulted in decreased but similar effect sizes
vif(a1)

# Model summary ------------------------------------------------------------------------------------
glm_summary = summary(a1)
glm_odds_ratio = exp(cbind(OR = coef(a1), confint(a1, level=0.95)))
glm_odds_ratio = glm_odds_ratio[!is.na(glm_odds_ratio[,1]),]
glm_results = cbind(glm_summary$coefficient, glm_odds_ratio)
glm_results = cbind(glm_results, "")
glm_results[, (dim(glm_results)[2])] = ifelse(as.numeric(glm_results[,4])<.05, "*", "")
write.csv(glm_results,
          paste0(dir_data_ch3_flow, "2020-06-24-flow-GLM-summary.csv"),
          fileEncoding="UTF-8", row.names=T)

# Model diagnostics --------------------------------------------------------------------------------

# source: https://www.r-bloggers.com/evaluating-logistic-regression-models/

# Macfadden's pseudo Rsq
pR2(a1) # !IMPORTANT

# Deviance explained
with(a1, null.deviance - deviance)
with(a1, df.null - df.residual)
with(a1, pchisq(null.deviance - deviance, df.null - df.residual, lower.tail = FALSE))
logLik(a1)

# Homer-Lemeshow Test
# source: http://ijbssnet.com/journals/Vol_4_No_3_March_2013/6.pdf
hoslem.test(as.numeric(df$flow), fitted(a1), g=10)

# Variable importance
varImp(a1)

# Model 2: predict proportion ----------------------------------------------------------------------

a2 <- glm(cbind(N_flow, N_total-N_flow) ~ continent_check + class_check + col_check + adj_check +
    continent_ori, data=df, family="binomial")
summary(a2)
par(mfrow=c(2,2)); plot(a2)

# Model diagnostics --------------------------------------------------------------------------------

# Overdispersion
resid.ssq <- sum(residuals(a2, type="pearson")^2)   ## sum of squares of Pearson resids
resid.df <- nrow(df)-length(coef(a2))               ## estimated resid df (N-p)
resid.ssq/resid.df


# -*- coding: utf-8 -*-

#' Created on Fri Apr 13 15:38:28 2018
#' R version 3.4.3 (2017-11-30)
#'
#' @group   Group 2, DM2 2018 Semester 2
#' @author: Mendes R.
#' @author: Santos R.
#' @author: Martins T.
#'

# Libs --------------------------------------------------------------------
options(warn=-1)
source("src/packages.r")
include_packs(c("dygraphs","d3heatmap","rockchalk","forcats","rJava",
                "xlsxjars","xlsx","tidyverse","stringi","stringr","ggcorrplot",
                "sm","lubridate","magrittr","ggplot2","openxlsx","RColorBrewer",
                "psych","treemap","data.table","pROC","class",'gmodels','klaR',
                "C50","caret",'gmodels'))

normalizedDataset <- xlsx::read.xlsx('datasets/normalizedDataset.xlsx',1, header= TRUE)

fields <- c("JobLevel","NumCompaniesWorked","TenureWorking","TenureRole",
            "LastPromotion","JobDedication","FacilitiesSatisfaction","Age",
            "JobTypeLevels" ,"isAfterHours","isChurn")
normalizedDataset <- normalizedDataset[ , (names(normalizedDataset) %in% fields)]

# Prep Training and Test data.
set.seed(333)
trainingRowIndex <- sample(1:nrow(normalizedDataset), 0.7*nrow(normalizedDataset))
trainData <- normalizedDataset[trainingRowIndex, ]
testData <- normalizedDataset[-trainingRowIndex, ]

train_labels <- as.factor(trainData$isChurn)
test_labels <- as.factor(testData$isChurn)

drops <- c("isChurn")
trainData <- trainData[ , !(names(trainData) %in% drops)]
testData <- testData[ , !(names(testData) %in% drops)]

knn_pred <- knn(train = trainData, test = testData,
                     cl = train_labels, k = 1)

caret::confusionMatrix(knn_pred, test_labels, positive = '1',
                       dnn=c("Pred","Actual"))


Gurka
Rebol []

factorial: func [n][
  either n > 0 [n * factorial n - 1] [1]
]

loop 100000 [factorial 12]


REBOL[MY TEST]
System/ports/serial: [ com3 ] ;if using linux this line is slightly different
ser: open/direct/no-wait serial://port1/250000/none/8/1
ser/rts-cts: false
update ser
buffer: make string! 1
logFile: "Hx19log.txt"
xdata: array/initial 6 0
bb: 0 bc: 0 tt: "" kt: "" nm: 1 kk: "" bd: 0
zz: -30
;***************************************** CONDITIONS ********************************
;This program utilizes equations found at www.hexamite.com/hx19posb.htm. For this
;set of relationship to work, line distance from first receiver to the second presents
;the X axis, and line distance from first receiver to third represents the Y-axis. And
;it follows that there is a 90 degree angle between X, Y and Z axis.
;-------------------------------------------------------------------------------------
;Following function computes xx string checksum and appends /hexsum to the string
;where hexsum is the hexadecimal representation of the sum of the string characters
hx19: funct [xx]
   [
     pp: copy xx
     ss: 0
     foreach char pp [ss: ss + char]
     hx: to-hex ss
     until [sn: take hx sn > #"0"]
     insert hx sn
     append pp "/" append pp hx append pp CR
     return pp
   ]
;following function sets the display layout with check buttons and etc.
view/new/title layout
  [
    across
	label "SYNC"
	check [
               either bb > 0
		[bb: 0 insert ser hx19 "M&%" update ser]
		[bb: 1 insert ser hx19 "M&$" update ser]
               ]
	label "LOG"
	check [
                either bc > 0
                 [bc: 0 close log]
                 [bc: 1 log: open/new %hx19log.txt]
               ]
	label "STOP"
 	check [
                either bd > 0
                 [bd: 0]
                 [bd: 1]
               ]

     f: field 200
   	btn "TX" [insert ser hx19 f/text update ser]
	btn "SetUP File"
	 [
	   px: read/lines %hx19setup.txt
           repeat nn 20
            [
             kk: pick px nn
             if 0 = length? kk [break]
             print kk
             insert ser hx19 kk update ser
             wait 0.05
            ]
         ]
  ] "HX19 ACCESS"
insert-event-func [switch event/type [close [close ser if bc > 0 [close log] quit]]event]
;the following code monitors incoming data from a serial port and prints in a popup box
forever
[
until 	 [
	  while[empty? buffer][read-io ser buffer 1 wait 0.0001]
	  x: to-integer first buffer
	  append tt buffer
	  clear buffer
	  x = 13
	 ]

   either (length? tt) > 13
    [
     kx: copy/part (at tt 10) length? tt
     foreach char kx
      [
       if char < 33 [break]
       kk: append kk char
      ]
     poke xdata nm to decimal! kk
     kt: copy/part (at tt 5) 3
     nm: nm + 1
     clear kk
    ]
    [
;print ["tag" kt " R1:" xdata/1 " R2:" xdata/2 " R3:" xdata/3]
;round(square-root zz)]]
      x0: (xdata/1) * (xdata/1)
      x1: (xdata/2) * (xdata/2)
      x2: (xdata/3) * (xdata/3)		;tag to receiver distance array
      xx: ((x0 - x1) + 1000000) / 2000
      yy: ((x0 - x2) + 1000000) / 2000  ;find these equations explained on the hexamite website
      zz: (x0 - (xx * xx) - (yy * yy))
      if bd = 0
	[
     	 if zz > 2 [print ["tag" kt " X:" round(xx) " Y:" round(yy) " Z:" round(square-root zz)]]
	]
      nm: 1
    ]
    if bc > 0 [append log tt]
    clear tt
]


source("functions_setup/mlab-setup.r")

# Install your US Census API key (add your key below and run once)
census_api_key("<INSERT YOUR US CENSUS API KEY HERE>", install=TRUE)

# Get all of the geom files for a country
us <- unique(fips_codes$state)[1:51]

# Example - returns total population by census tract for US
totalpop_sf <- reduce(
  map(us, function(x) {
    get_acs(geography = "tract", variables = "B01003_001",
            state = x, geometry = TRUE)
  }),
  rbind
)


plot.width = {img_width}
plot.height = {img_height}
plot.range = {date_range}
plot.locationid = {locationid}
plot.title = '{plot_title}'
plot.path = '{plot_path}'

date.min <- Sys.Date() - plot.range

## Event List ##
event.query <- paste0(
    'SELECT datetime, eventName ',
    'FROM event_list ',
    'WHERE eventGroup in (\'patch\') ',
    'AND datetime > \'', date.min, '\' '
)
event <- sqlQuery(emd, event.query)
event$datetime <- as.POSIXlt(event$datetime, tz='GMT')
do_lines <- TRUE
if(nrow(event)==0){{do_lines <- FALSE}}

## SDE Fetch ##
types.query <- paste0(
    'SELECT conv1.typeid as `typeID`, ',
    'conv1.typename as `typeName`, ',
    'COALESCE(dgm.valueInt, dgm.valueFloat, 0) AS `meta`, ',
    'grp.groupName AS `groupName`, ',
    'conv1.groupID AS `groupID`, ',
    'cats.categoryID AS `categoryID`, ',
    'cats.categoryName AS `categoryName` ',
    'FROM invTypes conv1 ',
    'JOIN invGroups grp ON (conv1.groupID=grp.groupID) ',
    'JOIN invCategories cats ON (grp.categoryID=cats.categoryID) ',
    'LEFT JOIN dgmTypeAttributes dgm ON (conv1.typeid=dgm.typeid AND dgm.attributeid=633) ',
    'WHERE conv1.marketgroupid IS NOT NULL ',
    'AND conv1.published=1 ',
    'AND grp.categoryID IN (6, 7, 8, 18) ',
    'AND ((grp.categoryID in (6, 7, 18) AND COALESCE(dgm.valueInt, dgm.valueFloat, 0) < 8) ',
    '   OR grp.categoryID=8)'
)

mats.query <- paste0(
    'SELECT conv.typeName, ',
    'conv.typeID, ',
    'grp.groupID, ',
    'grp.groupName, ',
    'grp.categoryID, ',
    'cat.categoryName ',
    'FROM invTypes conv ',
    'JOIN invGroups grp ON (grp.groupID=conv.groupID) ',
    'JOIN invCategories cat ON (cat.categoryID=grp.categoryID) ',
    'WHERE conv.marketGroupID IS NOT NULL ',
    'AND conv.published=1 ',
    'AND grp.categoryID IN (4, 43) ',
    'AND grp.groupID NOT IN (428, 712, 886) '
)
types <- sqlQuery(sde, types.query)
mats  <- sqlQuery(sde, mats.query)

list.ships <- types$typeID[types$categoryName=='Ship']
list.mats  <- mats$typeID
list.RMT   <- c(29668,34133,34132,40519,40520,44992)
list.skill <- c(40519,40520)

crest.query <- paste0(
    'SELECT price_date, ',
    'itemid AS `typeID`, ',
    'regionID, ',
    'CONCAT(YEAR(price_date), \'-\', IF(WEEK(price_date)<10, 0, \'\'), WEEK(price_date)) AS `weekNum`, ',
    'volume * avgPrice as `netTrade` ',
    'FROM crest_markethistory ',
    'WHERE price_date > \'', date.min, '\' ',
    'AND itemid NOT IN (29668) ',
    'AND regionID=', plot.locationid, ' '
)
print(crest.query)
crest <- sqlQuery(emd, crest.query)

odbcClose(sde)
odbcClose(emd)

## Mung Data ##
crest <- subset(crest,
    typeID %in% types$typeID |
    typeID %in% list.RMT |
    typeID %in% list.mats
)
crest$RMT <- 0
crest$RMT[crest$typeID %in% list.RMT] <- crest$netTrade[crest$typeID %in% list.RMT]
crest$not_RMT <- 0
crest$not_RMT[!(crest$typeID %in% list.RMT)] <- crest$netTrade[!(crest$typeID %in% list.RMT)]
crest$Ships <-0
crest$Ships[crest$typeID %in% list.ships] <- crest$netTrade[crest$typeID %in% list.ships]
crest$Materials <- 0
crest$Materials[crest$typeID %in% list.mats] <- crest$netTrade[crest$typeID %in% list.mats]
crest$SkillTrade <- 0
crest$SkillTrade[crest$price_date < '2016-02-09'] <- NA
crest$SkillTrade[crest$typeID %in% list.skill] <- crest$netTrade[crest$typeID %in% list.skill]

crest <- subset(crest, price_date < Sys.Date()) #clip "today"
crest <- data.table(crest)
plot.data <- crest[,
    list(
        net_trade=sum(netTrade),
        RMT_trade=sum(RMT),
        NOT_rmt_items=sum(not_RMT),
        ship_trade=sum(Ships),
        skill_trade=sum(SkillTrade),
        material_trade=sum(Materials)),
    by=c('price_date')
]

k = 7
align = 'right'
plot.data$net_trade.smooth <- rollmean(
    plot.data$net_trade,
    k=k,
    align=align,
    na.pad=TRUE
)
plot.data$RMT_trade.smooth <- rollmean(
    plot.data$RMT_trade,
    k=k,
    align=align,
    na.pad=TRUE
)
plot.data$NOT_rmt_items.smooth <- rollmean(
    plot.data$NOT_rmt_items,
    k=k,
    align=align,
    na.pad=TRUE
)
plot.data$ship_trade.smooth <- rollmean(
    plot.data$ship_trade,
    k=k,
    align=align,
    na.pad=TRUE
)
plot.data$skill_trade.smooth <- rollapply(
    plot.data$skill_trade,
    width=k,
    FUN=function(x) mean(x),
    align=align,
    fill=NA
)
plot.data$material_trade.smooth <- rollmean(
    plot.data$material_trade,
    k=k,
    align=align,
    na.pad=TRUE
)
plot.data.melt <- melt.data.frame(
    plot.data,
    id.vars=c('price_date'),
    measure.vars=c(
        'net_trade',
        'RMT_trade',
        'ship_trade',
        'material_trade',
        'NOT_rmt_items',
        'skill_trade')
)
plot.data.smooth <- melt.data.frame(
    plot.data,
    id.vars=c('price_date'),
    measure.vars=grep(
        '.smooth',
        names(plot.data),
        value=TRUE),
    value.name='smoothed'
)

plot.data.melt$Label[plot.data.melt$variable=='net_trade']      <- 'Total Market Trade'
plot.data.melt$Label[plot.data.melt$variable=='RMT_trade']      <- 'RMT Market'
plot.data.melt$Label[plot.data.melt$variable=='ship_trade']     <- 'Ship Market'
plot.data.melt$Label[plot.data.melt$variable=='material_trade'] <- 'Material Market'
plot.data.melt$Label[plot.data.melt$variable=='NOT_rmt_items']  <- 'General Market'
plot.data.melt$Label[plot.data.melt$variable=='skill_trade']    <- 'Skill Trading'

plot.data.smooth$Label[plot.data.smooth$variable=='net_trade.smooth']      <- 'Total Market Trade'
plot.data.smooth$Label[plot.data.smooth$variable=='RMT_trade.smooth']      <- 'RMT Market'
plot.data.smooth$Label[plot.data.smooth$variable=='ship_trade.smooth']     <- 'Ship Market'
plot.data.smooth$Label[plot.data.smooth$variable=='material_trade.smooth'] <- 'Material Market'
plot.data.smooth$Label[plot.data.smooth$variable=='NOT_rmt_items.smooth']  <- 'General Market'
plot.data.smooth$Label[plot.data.smooth$variable=='skill_trade.smooth']    <- 'Skill Trading'

plot.data <- merge(
    plot.data.melt, plot.data.smooth,
    by=c(
        'price_date',
        'Label')
)
plot.data$value <- plot.data$value.x
plot.data$smooth <- plot.data$value.y
plot.data <- plot.data[order(plot.data$price_date),]
plot.data$price_date <- as.POSIXlt(plot.data$price_date, tz='GMT')

#plot.min.log <- floor(10*log(min(plot.data$value, na.rm=TRUE)))/10
#plot.max.log <- floor(10*log(max(plot.data$value, na.rm=TRUE)))/10
plot.min <- round_any(min(plot.data$value, na.rm=TRUE), 1e11, floor)
plot.max <- round_any(max(plot.data$value, na.rm=TRUE), 1e11, floor)

plot.levels <- seq(
    from=1e12,
    to=plot.max,
    by=4e12
)
## Plot Theme ##
theme_dark <- function( ... ) {{
  theme(
    text = element_text(color="gray90"),
    title = element_text(size=rel(2.5),hjust=0.05,vjust=3.5),
    axis.title.x = element_text(size=rel(0.75),hjust=0.5, vjust=0),
    axis.title.y = element_text(size=rel(0.75),hjust=0.5, vjust=1.5),
    plot.margin = unit(c(2,1,1,1), "cm"),
    plot.background=element_rect(fill="gray8",color="gray8"),
    panel.background=element_rect(fill="gray10",color="gray10"),
    panel.grid.major = element_line(colour="gray17"),
    panel.grid.minor = element_line(colour="gray12"),
    axis.line = element_line(color = "gray50"),
    plot.title = element_text(color="gray80"),
    axis.title = element_text(color="gray70"),
    axis.text = element_text(color="gray50",size=rel(1.1)),
    legend.key = element_rect(fill="gray8",color="gray8"),
    legend.background = element_rect(fill="gray8"),
    legend.title = element_text(size=rel(0.6)),
    legend.text = element_text(size=rel(1.1)),
    strip.background = element_rect(fill="#252525"),
    strip.text = element_text(size=rel(1.2))
  ) + theme(...)
}}

## Build Plot ##
plot <- ggplot(
    plot.data,
    aes(
        x=price_date,
        y=smooth,
        color=Label)
)
plot <- plot + geom_line(size=1.2)
plot <- plot + geom_line(
    linetype=3,
    alpha=0.8,
    data=plot.data,
    aes(
        x=price_date,
        y=value,
        color=Label)
)
if(do_lines){{
    plot <- plot + geom_vline(
        xintercept=as.numeric(event$datetime),
        linetype=2,
        color='white'
    )
    plot <- plot + geom_text(
        aes(
            x=datetime,
            y=Inf,
            label=eventName),
        color='white',
        angle=-90,
        vjust=1.2,
        hjust=0,
        data=event,
        inherit.aes=FALSE
    )
}}
plot <- plot + theme_dark()
plot <- plot + scale_y_log10(labels=function(x)sprintf('%.2fT', x/1e12))
plot <- plot + labs(
    title = plot.title,
    x='date',
    y='Net Trade (daily) log-scale'
)

png(
    plot.path,
    width=plot.width,
    height=plot.height
)
print(plot)
dev.off()


# Install my packages
list.of.packages <- c("doParallel","doMC","kableExtra", "foreach", "MASS", "copula", "foreach", "devtools", "KernSmooth")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
lapply(list.of.packages, require, character.only = TRUE)

# install_github("jrash/chemmodlab", force = T, quiet = T, upgrade = "never")
# library(chemmodlab)

cl <- makeCluster(6)
registerDoParallel(cl)

setwd("Enrichment-Inference-Supplemental-Materials/simulation_files/power_figures/binorm/")
source("../../power_type1.r")
source("../../hypothesis_test.r")

r.vec <- c(2^seq(1, 13), 3^seq(1, 8), 10, 105, 300, 1500, 15000)
r.vec <- r.vec[order(r.vec)]/150000
simreps = 10000

method.v <- c("AH", "binomial", "JZ ind", "mcnemar", "binomial ind")

dist <- "binorm"
params.ls <- list(list(c(sqrt(2) * .8, 0), c(sqrt(2) * .6, 0)), list(c(sqrt(2) * .8, 0), c(sqrt(2) * .8, 0)),
                  list(c(sqrt(2) * .6, 0), c(sqrt(2) * .6, 0)))
rho <- c(.1, .1, .1)

k.ls <- rep(list(list()), length(params.ls))
k.c.ls <- rep(list(list()), length(params.ls))
for(i in seq_along(params.ls)) {
  for(j in seq_along(method.v)) {
    print(paste(params.ls[i], method.v[j]))
    k.ls[[i]][[j]] <- power.test(params= params.ls[[i]], dist = dist, pi.0.true = 1/500,
                                 myseed=569, method = method.v[j], plus = F, pool = F,
                                 simreps = simreps, m = 150000,
                                 r.vec = r.vec, metric = "k", rho = rho[i])
    k.c.ls[[i]][[j]] <- power.test(params= params.ls[[i]], dist = dist, pi.0.true = 1/500,
                                   myseed=569, method = method.v[j], plus = T, pool = F,
                                   simreps = simreps, m = 150000,
                                   r.vec = r.vec, metric = "k", rho = rho[i])
    save.image("power_all_binorm_unpooled_nocorr.rdata")
  }
}


library(pitchRx)

# get data from the no hitter game
bdat <- scrape(game.ids='gid_2015_06_20_pitmlb_wasmlb_1')

# get the at bat and pitch data from the scraped data

atbat <- bdat$atbat
pitch <- bdat$pitch

# inner join the atbat and pitch dataframes

nh <- inner_join(atbat, pitch, by='num') %>%
  filter(inning_side.x=='top') %>%
  select(num,start_tfs,stand,event,inning.x,batter_name, des, tfs,start_speed,px,pz,pitch_type)

x <- c(-0.95, 0.95, 0.95, -0.95, -0.95)
z <- c(1.6,1.6,3.5,3.5,1.6)
sz <- data.frame(x,z)

# creating better pitch labels
temp <- nh$pitch_type
temp[which(temp=='FF')] <- 'Fastball'
temp[which(temp=='CU')] <- 'Curveball'
temp[which(temp=='CH')] <- 'Change-up'
temp[which(temp=='SL')] <- 'Slider'
temp[which(temp=='FF')] <- 'Fastball'
temp[which(temp=='FC')] <- 'Cut fastball'

nh$pitch_description <- temp

# prep stand_xcoord so that L and R show up in batter's box
stand_xcoord <- nh$stand
stand_xcoord[which(stand_xcoord=='R')] <- -1.5
stand_xcoord[which(stand_xcoord=='L')] <- 1.5
stand_xcoord <- as.numeric(stand_xcoord)
nh$stand_xcoord <- stand_xcoord

# Reorder stand as factor so R is first factor
# This places right handed batter on the left side
nh$stand <- factor(nh$stand, levels=c('R','L'))

batter <- 'Pedro Alvarez'
inning <- 5

# plot the strikezone
ggplot()+
  # set up strike zone square
  geom_path(data=sz, aes(x=x,y=z)) +
  # len of units on x axis same as y axis
  coord_equal() +
  xlab('feet from home plate') +
  ylab('feet above the ground') +
  # plot the pitches
  geom_point(data=nh, aes(x=px, y=pz,size=start_speed,color=pitch_description)) +
  # smallest points for slower pitches are too small, adjust scale
  # scale means size vs regular dot
  scale_size(range=c(2,4)) +
  # set range for different 'degrees' on color wheel with h
  # setting stauration by c=
  # set brightness/luminence with l=
  ### scale_color_hue(h=c(0,10),c=50, l=0)

  # can also set color palette
  ### scale_color_brewer(palette = 'Dark2')

  # can also set colors manually
  # check colors by using colors() or hexadecimals
  scale_color_manual(values=c('red','blue','green','#FFFF99','purple')) +

  # If using pitch types, must change pitch_description to factor vector
  # from a chr vector
  ### nh$pitch_description <- factor(nh$pitch_description, levels=c('Fastball', 'Cut fastball', 'Slider', 'Curveball', 'Change-up'))

  # want to see platoon splits with two charts
  ### facet_wrap(~stand) +

  # facet the charts by at bat 'num'
  facet_wrap(~num) +
  # adding text somehwere on the plot
  geom_text(data=nh, aes(label=stand, x=stand_xcoord), y=2.5, size=5) +

  # add batter name to each at bat plot
  geom_text(data=nh, aes(label=batter_name), x=0, y=0.5, size=3) +

  # add inning
  geom_text(data=nh, aes(label=inning.x), x=0, y=4.5, size = 3)


portfolio.stats <- function(holding) {
    out <- quantmod::getQuote(holding, src='yahoo',
                              what = quantmod::yahooQF(c('Previous Close',
                                                         'P/E Ratio',
                                                         'Price/EPS Estimate Next Year',
                                                         'Price/Book',
                                                         'EPS',
                                                         '50-day Moving Average',
                                                         '200-day Moving Average')))
    out$'Trade Time' <- NULL
    names(out) <- c('close', names(out[2:ncol(out)]))
    return(out)
}


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " | ", fixed=TRUE), function(s) {
  t <- sapply(strsplit(s[1], " ")[[1]], as.integer)
  n <- as.integer(s[2])
  l <- 2
  for (i in 1:n) {
    p <- l
    l <- 0
    for (j in p:length(t)) {
      if (t[j-1] > t[j]) {
        tmp <- t[j-1]
        t[j-1] <- t[j]
        t[j] <- tmp
        l <- if(j > 2) j - 1 else 3
        break
      }
    }
    if (l == 0) { break }
  }
  paste(t, collapse=" ")
}), sep="\n")


library(Biobase)

fn.in = "data/SLE/expression/SLE_Longitudinal_972_eset.RData"
load(file.path(PROJECT_DIR, fn.in), verbose = T)

# eset expression data matrix
dat = exprs(eset)

# eset phenotype data (sample info, demographics, clinical, CBC, SLEDAI components, etc...)
info = pData(eset)
colnames(dat) = info$SAMPLE_NAME

dir.create("./generated_data/SLE", showWarnings = F)

# probe to gene symbol mapping
probes = featureData(eset)@data %>% tibble::rownames_to_column("ID")
probes.map = probes[,c("ID", "ILMN_Gene")]
colnames(probes.map) = c("ID","gene")
probes.map = probes.map[grep("///",probes.map$gene,invert=T),]
probes.map = probes.map[apply(probes.map!="" & !is.na(probes.map), 1, all, na.rm=T),]
fn.map = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_probe_map.txt")
fwrite(probes.map, file=fn.map, sep="\t", quote=F)

# select best probe for each gene
source(file.path(PROJECT_DIR, "R/functions/pick.probeset.r"))
pick.probeset(eset, fn.map)

# log2-transform epxression data
dat = log2(dat)

# output gene expression data and sample info
fn.ge = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_ge_matrix.txt")
fn.si = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_sample_info.txt")
dat %>% as.data.frame() %>% tibble::rownames_to_column("ID") %>%
  fwrite(fn.ge, sep="\t", quote=T)
fwrite(info, fn.si, sep="\t", quote=T)