##' Prediction model for outbreaks in 2015
##'
##' @return glm object
##' @author Sebastian Funk
##' @param campaigns_2015 whether to include campaigns in 2015 as a variable
##' @importFrom dplyr select
##' @importFrom MASS glm.nb
##' @export
prediction_model <- function(provinces=FALSE, campaigns_2015=FALSE)
{
  df_201113 <- katanga_measles_cases %>%
    filter(between(year(week_start), 2011, 2013)) %>%
    group_by(health_zone) %>%
    summarise(cases_201113=sum(cases))

  df <- gather_2015_data() %>%
    left_join(df_201113, by="health_zone") %>%
    filter(!is.na(mean_coverage))

  df <- df %>%
    mutate(population=(population-mean(population))/sd(population),
           cases_201113=(cases_201113-mean(cases_201113))/sd(cases_201113),
           mean_coverage=(mean_coverage-mean(mean_coverage))/sd(mean_coverage),
           coverage_estimate=(coverage_estimate-mean(coverage_estimate, na.rm=TRUE))/sd(coverage_estimate, na.rm=TRUE))

  variables <- c("population", "cases_201113", "mean_coverage", "coverage_estimate")

  if (campaigns_2015) variables <- c(variables, "campaign")
  if (provinces) variables <- c(variables, "province")

  formula <- paste0("cases ~ ", paste(variables, collapse="+"))

  g <- glm.nb(as.formula(formula), data=df)

  return(g)
}


#Rscript

#########################
##    Beta diversity   ##
#########################

#####Packages : ggplot2
#               vegan
#               adespatial
#               dplyr
#               tibble
#               tdyr

#####Load arguments

args <- commandArgs(trailingOnly = TRUE)

if (length(args) < 2) {
    stop("This tool needs at least 2 arguments")
}else{
    table <- args[1]
    hr <- args[2]
    abund <- as.numeric(args[3])
    loc <- as.numeric(args[4])
    spe <- as.numeric(args[5])
    date <- as.numeric(args[6])
    map <- as.logical(args[7])
    sepa <- as.logical(args[8])
    not <- as.logical(args[9])
    lat <- as.numeric(args[10])
    long <- as.numeric(args[11])
    var <- as.numeric(args[12])
    source(args[13])
}

if (hr == "false") {
  hr <- FALSE
}else{
  hr <- TRUE
}

#####Import data
data <- read.table(table, sep = "\t", dec = ".", header = hr, fill = TRUE, encoding = "UTF-8")
colabund <- colnames(data)[abund]
colloc <- colnames(data)[loc]
if (map) {
  collat <- colnames(data)[lat]
  collong <- colnames(data)[long]
}
colspe <- colnames(data)[spe]
coldate <- colnames(data)[date]
data[, coldate] <- as.factor(data[, coldate])

data <- data[grep("^$", data[, spe], invert = TRUE), ]

if (sepa) {
colvar <- colnames(data)[var]
}

# Data for species
data_num <- make_table_analyse(data, colabund, colspe, colloc, coldate)
nb_spe <- length(unique(data[, spe]))
nb_col <- ncol(data_num) - nb_spe + 1

#Data with coordinates and environmental
if (map) {
  data_xy <- data_num[, c(collat, collong)]
  colnames(data_xy) <- c("latitude", "longitude")
  # Data for environment
  data_env <- data_num[, c(colloc, collat, collong)]
  colnames(data_env) <- c("site", "latitude", "longitude")
}

# Data with only species and their abundance
data_spe <- data_num[, nb_col:ncol(data_num)]
rownames(data_spe) <- paste0(data_num[, colloc], " - ", data_num[, coldate])

#####Your analysis

# Computation beta.div {adespatial}
# Beta.div on Hellinger-transformed species data
data_beta <- adespatial::beta.div(data_spe, method = "hellinger", nperm = 9999)

save(data_beta, file = "beta_diversity.Rdata")
cat("##############################################################################",
    "\n########################### Beta Diversity Summary ###########################",
    "\n##############################################################################",
    "\n\n### All data ###",
    "\nBeta diversity: ", data_beta$beta[[2]],
    "\nSum of Squares: ", data_beta$beta[[1]],
    "\n\n### Vector of Local Contributions to Beta Diversity (LCBD) for the sites each date ###",
    "\n", capture.output(data_beta$LCBD),
    "\n\n### Vector of P-values associated with the LCBD indices ###",
    "\n", capture.output(data_beta$p.LCBD),
    "\n\n### Vector of Corrected P-values for the LCBD indices, Holm correction ###",
    "\n", capture.output(data_beta$p.adj),
    "\n\n### Vector of Species contributions to beta diversity (SCBD) ###",
    "\n", capture.output(data_beta$SCBD), file = "LCBD.txt", fill = 1, append = TRUE)

# Which species have a SCBD larger than the mean SCBD?
scbd <- capture.output(data_beta$SCBD[data_beta$SCBD >= mean(data_beta$SCBD)])
write(scbd, "SCBD.txt")

##1st fonction
beta_div_ext <- function(data_beta, data_xy, data_env) {
   data_beta_ext <- data.frame(data_xy, data_env, LCBD = data_beta$LCBD * 100, p.LCBD = data_beta$p.LCBD, signif = data_beta$p.LCBD < 0.05)

  graph_beta_ext <- ggplot2::ggplot(data = data_beta_ext, ggplot2::aes(x = latitude, y = longitude, size = LCBD, col = signif)) +
  ggplot2::geom_point() +
  ggplot2::scale_colour_manual(values = c("#57bce0", "#ce0b0b"), labels = c("Non significant", "Significant"), name = "Significance at 0.05") +
  ggplot2::xlab("Longitude") + ggplot2::ylab("Latitude")

  ggplot2::ggsave("Beta_diversity_through_space.png", graph_beta_ext)
}

## Boyé et al. 2017 JSR Fig R
####################################################

####LCBD####
lcbd_site <- adespatial::beta.div(data_spe, "hellinger", nperm = 999)

compute_lcbd <- function(data_beta, data_spe, data_num) {

#############
  mat_lcbd_site <- data.frame(data_spe, LCBD = data_beta$LCBD * 100, p.LCBD = data_beta$p.LCBD, signif = data_beta$p.LCBD < 0.05, site = data_num[, colloc], date = data_num[, coldate])

## Map spatio-temp
##################
  p1 <- ggplot2::qplot(date, site, size = LCBD, col = signif, data = mat_lcbd_site)
  p1 <- p1 + ggplot2::scale_colour_manual(values = c("#57bce0", "#ce0b0b"), labels = c("Non significant", "Significant"), name = "Significance at 0.05")
  p1 <- p1 + ggplot2::theme_bw() + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90)) + ggplot2::xlab("Date") + ggplot2::ylab("Site")

  ggplot2::ggsave("LCBD_sites_time.png", p1)

## Par années
#############
  mean_time <- tapply(mat_lcbd_site$LCBD, mat_lcbd_site$date, mean)
  sd_time <- tapply(mat_lcbd_site$LCBD, mat_lcbd_site$date, sd)
  date <- unique(mat_lcbd_site$date)

  data <- data.frame(date, mean_time, sd_time)

  time <- ggplot2::ggplot() + ggplot2::geom_pointrange(ggplot2::aes(x = date, y = mean_time, ymin = mean_time - sd_time, ymax = mean_time + sd_time), data = data)
  time <- time + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90), axis.line.y = ggplot2::element_line(size = 0.5)) + ggplot2::ylab("mean LCBD")

  ggplot2::ggsave("Mean_LCBD_through_time.png", time)
}

## Choose another graph
#######################
compute_lcbd2 <- function(data_beta, data_spe, data_num) {

#############
  mat_lcbd_site <- data.frame(data_spe, LCBD = data_beta$LCBD * 100, p.LCBD = data_beta$p.LCBD, signif = data_beta$p.LCBD < 0.05, site = data_num[, colloc], date = data_num[, coldate], variable = data_num[, colvar])

  p1 <- ggplot2::qplot(date, variable, size = LCBD, col = signif, data = mat_lcbd_site)
  p1 <- p1 + ggplot2::scale_colour_manual(values = c("#57bce0", "#ce0b0b"), labels = c("Non significant", "Significant"), name = "Significance at 0.05")
  p1 <- p1 + ggplot2::theme_bw() + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90)) + ggplot2::xlab("Date") + ggplot2::ylab(colvar)

  ggplot2::ggsave(paste0("LCBD_per_", colvar, "_through_time.png"), p1)
}

####SCBD###
# Function to compute SCBD
library(dplyr)
make_scbd_uvc <- function(data_spe, z, data_beta) {
  # Computation using beta.div {adespatial} on
  # Hellinger-transformed species data

  # Which species have a SCBD larger than the mean SCBD?
  spe_scbd <-  data_beta$SCBD[data_beta$SCBD >= mean(data_beta$SCBD)] %>%
    as.data.frame() %>%
    tibble::rownames_to_column(var = "Taxon") %>%
    dplyr::mutate("Methode" = z)

  return(spe_scbd)
}

# Function to make a radar plot

coord_radar <- function(theta = "x", start = 0, direction = 1) {
  theta <- match.arg(theta, c("x", "y"))
  r <- if (theta == "x") "y" else "x"
  ggplot2::ggproto("CordRadar", ggplot2::coord_polar(theta = theta, start = start,
          direction = sign(direction)),
          is_linear = function(coord) TRUE)
}

# Make the radar plot
radar_plot <- function(scbd_uvc_tc) {
  uvc_rd_plot_data <- scbd_uvc_tc %>%
    rename(scbd_score = ".")

  rad_uvc <- ggplot2::ggplot(uvc_rd_plot_data, ggplot2::aes(x = Taxon, y = scbd_score, group = Methode)) +
    ggplot2::geom_line() +
    ggplot2::geom_point(size = 3) +
    coord_radar() +
    ggplot2::theme_bw() +
    ggplot2::theme(axis.text.x = ggplot2::element_text(size = 10),
        legend.position = "bottom")

  ggplot2::ggsave("SCBD_Species_Radar_plot.png", rad_uvc)
}

## LCBD

if (map) {
  #Beta diversity
  beta_div_ext(data_beta, data_xy, data_env)
}

#Lcbd per places and time
compute_lcbd(data_beta, data_spe, data_num)

#Lcbd of your choice
if (sepa) {
  compute_lcbd2(data_beta, data_spe, data_num)
}

##SCBD

scbd_uvc_tc <- make_scbd_uvc(data_spe, z = "TC", data_beta)

radar_plot(scbd_uvc_tc)


library(boot)
wideScreen <- function(howWide=Sys.getenv("COLUMNS")) {
  options(width=as.integer(howWide))
}
wideScreen()
generate_task_csvs(3,.1)

taskdf <- fread('output/distal_scaling_tasks.csv')
const1 <- generate_tasks_and_corresponding_constraints_via_df(cadaver_5k_dataset_train4k_LRM()$H_matrix%>%as.matrix, taskdf,cadaver_5k_dataset_train4k_LRM()$bounds_tuple_of_numeric)

num_muscles <- ncol(cadaver_5k_dataset_train4k_LRM()$H_matrix)
bounds_tuple_of_numeric <- rep(list(list(lower = 0, upper = 10)), length(muscle_name_per_index))
bounds_tuple_of_numeric_01 <- rep(list(list(lower = 0, upper = 1)), length(muscle_name_per_index))

zero_wrench_task <- constraint_H_with_bounds(cadaver_5k_dataset_train4k_LRM()$H_matrix[c(1:6),]%>%as.matrix, rep(0,6), bounds_tuple_of_numeric)
# identify max capability along distal_fz direction
# direction <- cadaver_5k_dataset_train4k_LRM()$H_matrix[1:2,1]
direction <- c(-1,0,0,0,0,0)
# note that direction is flipped to be negative because it was brought from the B side to the A side.

starter_mat <- zero_wrench_task
lhs_with_target_dir <- starter_mat$constr %>% as.matrix
plus_or_minus_margin <- c(0,0,0,.5,.5,.5)
upperbnd <- direction + plus_or_minus_margin
lowerbnd <- direction - plus_or_minus_margin
new <- cbind(lhs_with_target_dir, c(-lowerbnd,upperbnd, rep(0,num_muscles*2)))
colnames(new)[num_muscles+1] <- "wrench"
constr_task <- list(constr=new,rhs=starter_mat$rhs,dir=starter_mat$dir)
print_constraint(constr_task)
simplex(c(rep(0,7),0), constr_task$constr,constr_task$rhs)

poin <- constr_task %>% har_sample(1e5)
print(summary(poin))

max_task_in_dir <- simplex(c(rep(0,7),-1), constr_task$constr,constr_task$rhs)

simplex(rep(-1,21), inequality_constraints$constr,inequality_constraints$rhs)
is_feasible(zero_wrench_task)

inequality_constraints <- diagonal_merge_constraint_list(const1$constraints)

eliminate = TRUE
max_allowable_increasing_tension_speed=200 #activations per millisecond
max_allowable_decreasing_tension_speed=200 #activations per millisecond

st_constr <- generate_and_add_velocity_constraint(inequality_constraints,
                                                 max_allowable_increasing_tension_speed,
                                                 max_allowable_decreasing_tension_speed,
                                                 num_muscles)
is_feasible(st_constr)
res <- list(nonredundant_constr=eee, tasks_and_constraints=const1)

eee %>% har_sample(10, eliminate=TRUE)
return(res)

1124$7jbcaoqsdgad

$7jbcaoq


##CTE534_EDA=group
##Imagen=raster
##Vector=vector
##Campo=field Vector
##Puntos=number 50
##Salida= output table
##Media_Usos= output table
##Tipo=selection Regular;Aleatorio
##showplots
library(sp)
if (Tipo == 0) {
ptsamp<-spsample(Vector,Puntos,type="regular")
class <- over(ptsamp, Vector)
ptsamp$class <- class[[Campo]]
Salida<-extract(Imagen, ptsamp)

ms <- aggregate(Salida,list(ptsamp$class),mean)
# instead of the first column, we use row names
rownames(ms) <- ms[,1]
Media_Usos <- ms[,-1]
Media_Usos

#transform ms from a data.frame to a matrix
ms <-as.matrix(Media_Usos)
# First create an empty plot
plot(0, ylim=c(0,max(Media_Usos)), xlim =c(0,dim(Media_Usos)[2]), type='n', xlab="Bandas", ylab = "Reflectividad")#
# add the different classes
for(i in 1:nrow(ms)){
  lines(ms[i,], type = "l", lwd = 3, lty = 1, col=i)
  }
# Title
title(main="Perfil Espectral", font.main = 2)
# Legend
legend("topleft",rownames(ms),cex=0.8, col=c(1:nrow(ms)), lty = 1, lwd =3, bty = "n")

} else if (Tipo == 1) {
ptsamp<-spsample(Vector,Puntos,type="random")
class <- over(ptsamp, Vector)
ptsamp$class <- class[[Campo]]
Salida<-extract(Imagen, ptsamp)

ms <- aggregate(Salida,list(ptsamp$class),mean)
# instead of the first column, we use row names
rownames(ms) <- ms[,1]
Media_Usos <- ms[,-1]
Media_Usos

#transform ms from a data.frame to a matrix
ms <-as.matrix(Media_Usos)
# First create an empty plot
plot(0, ylim=c(0,max(Media_Usos)), xlim =c(0,dim(Media_Usos)[2]), type='n', xlab="Bandas", ylab = "Reflectividad")#
# add the different classes
for(i in 1:nrow(ms)){
  lines(ms[i,], type = "l", lwd = 3, lty = 1, col=i)
  }
# Title
title(main="Perfil Espectral", font.main = 2)
# Legend
legend("topleft",rownames(ms),cex=0.8, col=c(1:nrow(ms)), lty = 1, lwd =3, bty = "n")
}


path <- '/home/maanitou/programming/fsharp/rufc/Samples/schrodinger/'

content_f <- read.table(paste(path, 'output_schrodinger_forward.txt', sep=""))

factor <- 1000000

Xf <- sapply(content_f, function(x) as.numeric(x)/factor)

par(mfrow=c(1,1))

plot(1:128, Xf[1,], type='l',  xlim=c(0,128), ylim=c(min(Xf),max(Xf)))
lines(1:128, Xf[2,], type='l')

for (i in 1:(nrow(Xf)-1)) {
  plot(1:128, Xf[i,], type='l', col='red', xlim=c(0,128), ylim=c(min(Xf),max(Xf)))
  lines(1:128, Xf[i+1,], type='l', col='black')

  #Sys.sleep(0.001)
}


library(readxl)
library(nortest)

rouge_conceptual <- read_excel("D:/Tesis2016/Jarvis/Final/rouge_test_final.xlsx",
                               sheet = "ConceptualRST")
rouge_no_expantion_conceptual <- read_excel("D:/Tesis2016/Jarvis/Final/rouge_test_final.xlsx",
                               sheet = "NLG")
#View(rouge_final_conceptual)
#View(rouge_conceptual)

first_vector <- rouge_conceptual[,6]
second_vector <- rouge_no_expantion_conceptual[,6]

print(lillie.test(first_vector))
print(lillie.test(second_vector))

#wilconxon = wilcox.test(first_vector, second_vector)
#print(wilconxon)

ttest = t.test(first_vector, second_vector, mu=0, alternative = "two.sided", paired = T, conf.level = 0.95)
print(ttest)
#boxplot(first_vector, second_vector)
#plot(first_vector, second_vector)
#abline(a=0,b=1)
#lot(density(first_vector))
#hist(first_vector)
#qqnorm(second_vector)

print(round(mean(first_vector),3))
print(round(mean(second_vector),3))

#boxplot(first_vector, second_vector)

#qqnorm(rouge1_rst_noexp)
#qqline(rouge1_rst_noexp)


rm(list=ls())

train_13 <-  fread('c:/perforce/daniel/ex/segments/all/train_2013.csv')

s <- subset(train_13,  user_location_city==49272 & hotel_market==402  )
sqldf('select hotel_cluster,count(*) as c from s group by hotel_cluster order by c desc limit 20' )

s1 <- subset(s,    hotel_cluster==      74  )
s2 <- subset(s,   hotel_cluster==         84  )

ggplot() + geom_histogram(aes(col='s1',x=s1$orig_destination_distance),binwidth = 0.1,alpha=0.5) +
  geom_histogram(aes(col='s2',x=s2$orig_destination_distance),binwidth = 0.1,alpha=0.5) +
  coord_cartesian(xlim=c(175.0,175.5))


#read data

train <- read.csv(file = "Property_price_Train.csv", stringsAsFactors = F)
test <- read.csv(file = "Property_price_Test.csv", stringsAsFactors = F)

head(property.train)

#column names

names(property.train)
names(property.test)

str(property.train)

train$IsTrain <- T
test$IsTrain <- F

test$Sale_Price <- NA

#combining data into one

all <- rbind(train,test)

summary(all)

#taking only numeric variables

num_Var <- which(sapply(all, is.numeric)) #indexing numeric
all.num <- all[,num_Var]

#taking only character variables

char_Var <- which(sapply(all, is.character)) #index character
all.char <- all[,char_Var]

#checking for missing variables

NAcol <- which(colSums(is.na(all)) > 0)
sort(colSums(sapply(all[NAcol], is.na)), decreasing = TRUE)

#pool_quality

all$Pool_Quality[is.na(all$Pool_Quality)] <- 'None'

#label encode the variables
table(as.factor(all$Pool_Quality))

Qualities <- c('None' = 0, 'Fa' = 1, 'Gd' = 2, 'Ex' = 3)
library(plyr)
all$Pool_Quality<-as.integer(revalue(all$Pool_Quality, Qualities))
table(all$Pool_Quality)

#checking pool quality with pool area

all[all$Pool_Area>0 & all$Pool_Quality==0, c('Pool_Area', 'Pool_Quality')]
all$Pool_Quality[2420]<-2
all$Pool_Quality[2503]<-2
all$Pool_Quality[2420]<-3
all$Pool_Quality[2599]<-2

#Miscellaneous_Feature

table(all$Miscellaneous_Feature)

all$Miscellaneous_Feature[is.na(all$Miscellaneous_Feature)] <- 'None'

all$Miscellaneous_Feature <- as.factor(all$Miscellaneous_Feature)
library(tidyverse)
ggplot(all[!is.na(all$Sale_Price),], aes(x=Miscellaneous_Feature, y=Sale_Price)) +
  geom_bar(stat = "summary", data = all, fill = 'blue')

#Lane_Type

table(all$Lane_Type)
all$Lane_Type[is.na(all$Lane_Type)] <- 'None'

all$Lane_Type <- as.factor(all$Lane_Type)
ggplot(all[!is.na(all$Sale_Price),], aes(x=Lane_Type, y=Sale_Price)) +
  geom_bar(stat = "summary", data = all, fill = 'blue')

#fence quality

table(all$Fence_Quality)

all$Fence_Quality[is.na(all$Fence_Quality)] <- 'None'

all[!is.na(all$Sale_Price),] %>%
  group_by(Fence_Quality) %>%
  summarise(median = median(Sale_Price), counts=n())

all$Fence_Quality <- as.factor(all$Fence_Quality)
ggplot(all[!is.na(all$Sale_Price),], aes(x=Fence_Quality, y=Sale_Price))+
  geom_bar(stat = "summary", data = all, fill = 'blue')

#Fireplace_Quality

table(all$Fireplace_Quality)

all$Fireplace_Quality[is.na(all$Fireplace_Quality)] <- 'None'

Quality <- c('None' = 0, 'Po' = 1, 'Fa' = 2, 'TA' = 3, 'Gd' = 4, 'Ex' = 5)

#labeling

all$Fireplace_Quality<-as.integer(revalue(all$Fireplace_Quality, Quality))

table(all$Fireplace_Quality)

table(all$Fireplaces)

#Lot_Extent

ggplot(all[!is.na(all$Lot_Extent),], aes(x=as.factor(Neighborhood), y=Lot_Extent)) +
  geom_bar(stat = "summary", data = all, fill = 'blue')

#replacing the na value by median per neighborhood

for (i in 1:nrow(all)){
  if(is.na(all$Lot_Extent[i])){
    all$Lot_Extent[i] <- as.integer(median(all$Lot_Extent[all$Neighborhood==all$Neighborhood[i]], na.rm=T))
  }
}

table(all$Lot_Configuration)

ggplot(all[!is.na(all$Sale_Price),], aes(x=Lot_Configuration, y= Sale_Price)) +
  geom_bar(stat = "summary", data = all, fill = 'blue')

all$Lot_Configuration <- as.factor(all$Lot_Configuration)

#garage

all$Garage_Built_Year[is.na(all$Garage_Built_Year)] <- all$Construction_Year[is.na(all$Garage_Built_Year)]

all<- all %>% rename(Garage_Finish = Garage_Finish_Year)

all[!is.na(all$Garage) & is.na(all$Garage_Finish), c('Garage',
                                                     'Garage_Finish',
                                                     'Garage_Size',
                                                     'Garage_Area',
                                                     'Garage_Quality',
                                                     'Garage_Condition')]

table(all$Garage)
all$Garage_Finish[2126] <- 'Unf'
all$Garage_Quality[2126] <- 'TA'
all$Garage_Condition[2126] <- 'TA'

#as column 2576 indicates it have no garage

all$Garage_Area[2576] <- 0
all$Garage_Size[2576] <- 0
all$Garage[2576] <- NA

#now all garage variables have same number of missing value

all$Garage[is.na(all$Garage)] <- 'No Garage'
all$Garage <- as.factor(all$Garage)
table(all$Garage)

all$Garage_Finish[is.na(all$Garage_Finish)] <- 'None'
table(all$Garage_Finish)
Finish <- c('None'=0, 'Unf'=1, 'RFn'=2, 'Fin'=3)

all$Garage_Finish<-as.integer(revalue(all$Garage_Finish, Finish))
table(all$Garage_Finish)

all$Garage_Quality[is.na(all$Garage_Quality)] <- 'None'
table(all$Garage_Quality)
all$Garage_Quality<-as.integer(revalue(all$Garage_Quality, Quality))
table(all$Garage_Quality)

all$Garage_Condition[is.na(all$Garage_Condition)] <- 'None'
all$Garage_Condition<-as.integer(revalue(all$Garage_Condition, Quality))
table(all$Garage_Condition)

#Basement_variables

#checking how many variables have same no. of NA's

length(which(is.na(all$Basement_Condition) & is.na(all$Exposure_Level) & is.na(all$Basement_Height) & is.na(all$BsmtFinType1) & is.na(all$BsmtFinType2)))

all[!is.na(all$BsmtFinType1) &
      (is.na(all$Basement_Condition)|
         is.na(all$Basement_Height)|
         is.na(all$Exposure_Level)|
         is.na(all$BsmtFinType2)), c('Basement_Height', 'Basement_Condition', 'Exposure_Level', 'BsmtFinType1', 'BsmtFinType2')]

all$BsmtFinType2[333] <- names(sort(-table(all$BsmtFinType2)))[1]
all$Exposure_Level[c(949, 1487, 2348)] <- names(sort(-table(all$Exposure_Level)))[1]
all$Basement_Condition[c(2040, 2185, 2524)] <- names(sort(-table(all$Basement_Condition)))[1]
all$Basement_Height[c(2217, 2218)] <- names(sort(-table(all$Basement_Height)))[1]

all$Basement_Height[is.na(all$Basement_Height)] <- 'None'
table(all$Basement_Height)
all$Basement_Height<-as.integer(revalue(all$Basement_Height, Quality))
table(all$Basement_Height)

all$Basement_Condition[is.na(all$Basement_Condition)] <- 'None'
table(all$Basement_Condition)
all$Basement_Condition<-as.integer(revalue(all$Basement_Condition, Quality))
table(all$Basement_Condition)

all$Exposure_Level[is.na(all$Exposure_Level)] <- 'None'
table(all$Exposure_Level)
Exposure <- c('None'=0, 'No'=1, 'Mn'=2, 'Av'=3, 'Gd'=4)

all$Exposure_Level<-as.integer(revalue(all$Exposure_Level, Exposure))
table(all$Exposure_Level)

all$BsmtFinType1[is.na(all$BsmtFinType1)] <- 'None'
table(all$BsmtFinType1)
FinType <- c('None'=0, 'Unf'=1, 'LwQ'=2, 'Rec'=3, 'BLQ'=4, 'ALQ'=5, 'GLQ'=6)

all$BsmtFinType1<-as.integer(revalue(all$BsmtFinType1, FinType))
table(all$BsmtFinType1)

all$BsmtFinType2[is.na(all$BsmtFinType2)] <- 'None'

all$BsmtFinType2<-as.integer(revalue(all$BsmtFinType2, FinType))
table(all$BsmtFinType2)

all$BsmtFinSF1[is.na(all$BsmtFinSF1)] <-0

all$BsmtFinSF2[is.na(all$BsmtFinSF2)] <-0

all$BsmtUnfSF[is.na(all$BsmtUnfSF)] <-0

all$Total_Basement_Area[is.na(all$Total_Basement_Area)] <-0

#Brick vaneer variables

length(which(is.na(all$Brick_Veneer_Type) & is.na(all$Brick_Veneer_Area)))

all[is.na(all$Brick_Veneer_Type) &
      !is.na(all$Brick_Veneer_Area),
    c('Brick_Veneer_Type', 'Brick_Veneer_Area')]

table(all$Brick_Veneer_Type)

all$Brick_Veneer_Type[2610]<- 'BrkFace'

all$Brick_Veneer_Type[is.na(all$Brick_Veneer_Type)] <- 'None'

all[!is.na(all$Sale_Price),] %>%
  group_by(Brick_Veneer_Type) %>%
  summarise(median = median(Sale_Price), counts=n()) %>%
  arrange(median)

#let say common bricks/none are same as their median is almost same
#others have significant difference than brkCmn/none

all$Brick_Veneer_Type<-as.integer(revalue(all$Brick_Veneer_Type, c('None'=0,
                                                     'BrkCmn'=0,
                                                     'BrkFace'=1,
                                                     'Stone'=2)))
table(all$Brick_Veneer_Type)

all$Brick_Veneer_Area[is.na(all$Brick_Veneer_Area)] <-0

#zoning class

table(all$Zoning_Class)

all$Zoning_Class[is.na(all$Zoning_Class)] <- 'RLD'

all$Zoning_Class <- as.factor(all$Zoning_Class)

#utility type

table(all$Utility_Type)

#there are all values are same except one so its useless

all$Utility_Type <- NULL

#underground bathroom

length(which(is.na(all$Underground_Full_Bathroom) & is.na(all$Underground_Half_Bathroom)))

table(all$Underground_Full_Bathroom)
all$Underground_Full_Bathroom[is.na(all$Underground_Full_Bathroom)] <- 0

table(all$Underground_Half_Bathroom)
all$Underground_Half_Bathroom[is.na(all$Underground_Half_Bathroom)] <- 0

#Functional_Rate

table(all$Functional_Rate)

rate <- c('MajD1' = 1,
          'MajD2' =2,
          'MD' = 3,
          'MD1' = 4,
          'MD2' = 5,
          'Mod' = 6,
          'MS' = 7,
          'SD' = 8,
          'Sev' = 9,
          'TF' = 10)

all$Functional_Rate <- as.integer(revalue(all$Functional_Rate,rate))
table(all$Functional_Rate)
all$Functional_Rate[is.na(all$Functional_Rate)] <- 10

#exterior variables

table(all$Exterior1st)
all$Exterior1st[is.na(all$Exterior1st)] <- names(sort(-table(all$Exterior1st)))[1]

all$Exterior1st <- as.factor(all$Exterior1st)

table(all$Exterior2nd)
all$Exterior2nd[is.na(all$Exterior2nd)] <- names(sort(-table(all$Exterior2nd)))[1]

all$Exterior2nd <- as.factor(all$Exterior2nd)

#labeling
table(all$Exterior_Condition)
all$Exterior_Condition <- as.integer(revalue(all$Exterior_Condition,Quality))

table(all$Exterior_Material)
all$Exterior_Material <- as.integer(revalue(all$Exterior_Material,Quality))

#Electrical_System

table(all$Electrical)
all$Electrical_System[is.na(all$Electrical_System)] <- 'SBrkr'

all$Electrical_System <- as.factor(all$Electrical_System)

#kitchen

table(all$Kitchen_Quality)
all$Kitchen_Quality[is.na(all$Kitchen_Quality)] <- 'TA'
all$Kitchen_Quality <- as.integer(revalue(all$Kitchen_Quality,Quality))

#Sale_Type

table(all$Sale_Type)
table(all$Sale_Condition)

all$Sale_Type[is.na(all$Sale_Type)] <- 'WD'

all$Sale_Type <- as.factor(all$Sale_Type)
all$Sale_Condition <- as.factor(all$Sale_Condition)

#labeling and factorizing

names(all[,sapply(all, is.character)])

#roads

table(all$Road_Type)
all$Road_Type<-as.integer(revalue(all$Road_Type, c('Gravel'=0, 'Paved'=1)))

table(all$Pavedd_Drive)
all$Pavedd_Drive<-as.integer(revalue(all$Pavedd_Drive, c('N'=0, 'P'=1, 'Y'=2)))
table(all$Pavedd_Drive)

#foundation

table(all$Foundation_Type)
all$Foundation_Type <- as.factor(all$Foundation_Type)

#heating and air condition

table(all$Heating_Quality)
all$Heating_Quality <- as.integer(revalue(all$Heating_Quality, Quality))

table(all$Heating_Type)
all$Heating_Type <- as.factor(all$Heating_Type)

table(all$Air_Conditioning)
all$Air_Conditioning<-as.integer(revalue(all$Air_Conditioning, c('N'=0, 'Y'=1)))
table(all$Air_Conditioning)

#neighborhood

all$Neighborhood <- as.factor(all$Neighborhood)
table(all$Neighborhood)

table(all$Condition1)
all$Condition1 <- as.factor(all$Condition1)

all$Condition2 <- as.factor(all$Condition2)

#roof

table(all$Roof_Design)
all$Roof_Design <- as.factor(all$Roof_Design)
table(all$Roof_Quality)
all$Roof_Quality <- as.factor(all$Roof_Quality)

#land

table(all$Land_Outline)
all$Land_Outline <- as.factor(all$Land_Outline)

table(all$Property_Shape)
all$Property_Shape <- as.integer(revalue(all$Property_Shape, c('Reg'=0,
                                                               'IR1'=1,
                                                               'IR2'=2,
                                                               'IR3'=3)))

table(all$Property_Slope)
all$Property_Slope <- as.integer(revalue(all$Property_Slope, c('GS'=0,
                                                               'MS'=1,
                                                               'SS'=2)))

#house

table(all$House_Design)
ggplot(all[!is.na(all$Sale_Price),], aes(x=House_Design, y= Sale_Price)) +
  geom_bar(stat = "summary", data = all, fill = 'blue')
all$House_Design <- as.factor(all$House_Design)

table(all$House_Type)
ggplot(all[!is.na(all$Sale_Price),], aes(x=House_Type, y= Sale_Price)) +
  geom_bar(stat = "summary", data = all, fill = 'blue')
all$House_Type <- as.factor(all$House_Type)

num_Var <- which(sapply(all, is.numeric)) #indexing numeric
all.num <- all[,num_Var]

cor_numVar <- cor(all.num, use="pairwise.complete.obs")
#sort on decreasing correlations with Sale Price
cor_sorted <- as.matrix(sort(cor_numVar[,'Sale_Price'], decreasing = TRUE))
cor_sorted
#select only high corelations
CorHigh <- names(which(apply(cor_sorted, 1, function(x) abs(x)>0.5)))
cor_numVar <- cor_numVar[CorHigh, CorHigh]
CorHigh
library(corrplot)
corrplot.mixed(cor_numVar)
corrplot.mixed(cor_numVar, tl.col="black", tl.pos = "lt", tl.cex = 0.7,cl.cex = .7, number.cex=.7)

#split back into train and test

all<- all[,-1]
drop <- c("Remodel_Year",
          "Garage_Area",
          "Kitchen_Above_Grade",
          "BsmtFinSF2",
          "Garage_Condition")
all <- all[,!(names(all) %in% drop)]

train <- all[all$IsTrain==T,]
test <- all[all$IsTrain==F,]

train <- train[ , -which(names(train) %in% c("IsTrain"))]
test <- test[ , -which(names(test) %in% c("IsTrain"))]

#removing outliers

hist(train$Basement_Height)

boxplot(train$Sale_Price)$stat
quantile(train$Sale_Price, seq(0,1,.01))
train <- train[train$Sale_Price<340000,]
train$Sale_Price[train$Sale_Price>313000] <- 313000
boxplot(train$Sale_Price)

library(randomForest)
model1 <- randomForest(Sale_Price~.,
                       data = train)
predct_train <- predict(model1,train)

check <- cbind(train$Sale_Price, predct_train)

importance(model1,decreasing = T)
varImpPlot(model1)

test$Sale_Price <- predict(model1,test)
plot(model1)
write.csv(test,file = "new_prediction.csv", row.names = F)


roll_scatter = function()
{
  row = sample(NROW(gmh_directions), 1)
  df = gmh_directions[row, ]

  g = ggplot(df, ggplot2::aes(x, y)) +
    ggplot2::theme_void() +
    ggplot2::geom_segment(ggplot2::aes(xend=xend, yend=yend), arrow=ggplot2::arrow(), size=2.5) +
    ggplot2::scale_x_continuous(limits = c(-1, 1)) +
    ggplot2::scale_y_continuous(limits = c(-1, 1))

  g
}


# calculate nucleotide diversity for each species for each tree

library(seqinr)
options(scipen=999)

# identify the fasta files
all_fasta <- list.files("bloch_fasta_trees", pattern="*_aligned_trimmed.fasta$", full.names=T)

# label groups
groups <- list()
groups[[1]] <- c("28_vicinus", "5_vicinus", "39_vicinus")
groups[[2]] <- c("29_vicinusunk", "24_vicinusunk")
groups[[3]] <- c("3_laevigatus", "46_laevigatus")
groups[[4]] <- c("56_herculeanus", "49_herculeanus", "50_herculeanus")
groups[[5]] <- c("19_modoc", "2_modoc", "36_modoc")
groups[[6]] <- c("10_pennunk", "16_pennunk", "18_pennunk")

# return p and q allele freqs for each site in gene
# to be used with apply across columns for each slot in an alignment
# all the sites will then be summed and divided by number of sites genotyped

p_q_columns <- function(xxx) {
	# if no variation return zero
	if(length(unique(xxx)) == 1) {
		return(c(0,0))
	} else {
		# define number of chromosomes sampled
		n_chromosomes <- length(xxx)
		# alleles = ?
		alleles <- unique(xxx)
		# p and q freqs
		p_q <- c(length(xxx[xxx %in% alleles[1]]), length(xxx[xxx %in% alleles[2]]))
		return(p_q)
	}
}

# loop for each fasta
output <- c("gene_number", "gene_name", "n_sites", "vicinus_pi", "vicinusunk_pi", "laevigatus_pi", "herculeanus_pi", "modoc_pi", "pennunk_pi")
for(a in 1:length(all_fasta)) {
	a_rep <- read.fasta(all_fasta[a])
	# extract gene number
	a_output <- sapply(strsplit(all_fasta[a], "_"), "[[", 5)
	# extract gene name
	a_output <- c(a_output, sapply(strsplit(sapply(strsplit(all_fasta[a], "_"), "[[", 6), "gene-"), "[[", 2))

	# loop for each group
	for(b in 1:length(groups)) {
		# subset individuals
		b_rep <- a_rep[names(a_rep) %in% groups[[b]]]
		# row bind all individuals together
		if(length(b_rep) == 2) {
			d_rep <- rbind(b_rep[[1]], b_rep[[2]])
		} else if(length(b_rep) == 3){
			d_rep <- rbind(b_rep[[1]], b_rep[[2]], b_rep[[3]])
		}
		# calculate pi if there are two individuals in the species or calculate pi for each pairwise comparison of two
		# individuals and take the mean measurement for populations with 3 individuals
		# so that all species are directly comparable for sample sizes
		if(nrow(d_rep) == 2) {
			# find the p and q frequencies for each base in the gene
			p_q_rep <- t(apply(d_rep, 2, p_q_columns))
			# based on nucleotide diversity formula from:
			# Carlson et al. 2005: 10.1101/gr.4326505 (equation 2)
			p_freq <- p_q_rep[,1]
			q_freq <- p_q_rep[,2]
			n_chromosomes <- nrow(d_rep)
			n_sites <- ncol(d_rep)
			pi <- sum(2 * p_freq * q_freq) * (n_chromosomes / (n_chromosomes - 1)) / n_sites
		} else {
			combinations <- combn(c(1,2,3), 2)
			pi_reps <- c()
			# calculate pi for each pair of comparisons
			for(d in 1:ncol(combinations)) {
				dd_rep <- d_rep[c(combinations[1,d],combinations[2,d]),]
				# find the p and q frequencies for each base in the gene
				p_q_rep <- t(apply(dd_rep, 2, p_q_columns))
				# based on nucleotide diversity formula from:
				# Carlson et al. 2005: 10.1101/gr.4326505 (equation 2)
				p_freq <- p_q_rep[,1]
				q_freq <- p_q_rep[,2]
				n_chromosomes <- nrow(dd_rep)
				n_sites <- ncol(dd_rep)
				pi_reps <- c(pi_reps, sum(2 * p_freq * q_freq) * (n_chromosomes / (n_chromosomes - 1)) / n_sites)
			}
			pi <- mean(pi_reps)
		}
		# find the p and q frequencies for each base in the gene
		p_q_rep <- t(apply(d_rep, 2, p_q_columns))
		# based on nucleotide diversity formula from:
		# Carlson et al. 2005: 10.1101/gr.4326505 (equation 2)
		p_freq <- p_q_rep[,1]
		q_freq <- p_q_rep[,2]
		n_chromosomes <- nrow(d_rep)
		n_sites <- ncol(d_rep)
		pi <- sum(2 * p_freq * q_freq) * (n_chromosomes / (n_chromosomes - 1)) / n_sites
		# add to output for this gene
		if(b == 1) { a_output <- c(a_output, n_sites)}
		a_output <- c(a_output, pi)
	}

	# add gene's output to the total output
	output <- rbind(output, a_output)
}
# write output preliminary table
write.table(output, file="blochmannia_pi.txt", sep="\t", row.names=F, col.names=F, quote=F)

# read in output
x <- read.table("blochmannia_pi.txt", sep="\t", header=T, stringsAsFactors=F)
# order by gene number
x <- x[order(x[,1]),]

# read in outgroup annotations
flor <- read.table("BX248583_floridanus_annotations.tsv", stringsAsFactors=F, header=T, fill=T, row.names=NULL)
# keep only annotations that are for "CDS"
flor <- flor[flor[,2] == "CDS",]
# sort
flor <- flor[order(as.numeric(flor[,4])),]
# redo row names
rownames(flor) <- seq(from=1, to=nrow(flor), by=1)

# check that gene IDs in object x match those in the floridanus annotations
test <- c()
for(a in 1:nrow(x)) {
	if(x[a,2] == flor[x[a,1],1]) {
		test <- c(test, TRUE)
	} else {
		print(a)
		test <- c(test, FALSE)
	}
}

# if the above test matched everything, continue

# extract locations for each gene (outgroup genome coordinates)
coords <- c()
for(a in 1:nrow(x)) {
	coords <- c(coords, (as.numeric(flor[x[a,1],5]) + as.numeric(flor[x[a,1],4])) / 2)
}
# add to table
x <- cbind(x[,1:2], coords, x[,3:9])

# write table output
write.table(x, file="blochmannia_pi2.txt", sep="\t", quote=F, row.names=F, col.names=T)
# read in output
x <- read.table("blochmannia_pi2.txt", sep="\t", header=T, stringsAsFactors=F)

# 20kbp means for each stat
window_coords <- seq(from=0, to=700000, by=20000)
for(a in 1:length(window_coords)) {
	# skip the last row
	if(a != length(window_coords)) {
		a_start <- window_coords[a]
		a_end <- window_coords[a+1]
		a_middle <- mean(c(window_coords[a+1], window_coords[a]))
		a_rep <- x[x$coords >= a_start & x$coords <= a_end,]
		a_rep <- c(a_middle, apply(a_rep[,4:ncol(a_rep)], 2, mean))
		if(a == 1) {
			x_windows <- a_rep
		} else {
			x_windows <- rbind(x_windows, a_rep)
		}
	}
}
x_windows <- as.data.frame(x_windows)

#plot
par(mar=c(2,5,1,1))
par(mfrow=c(6,1))
plot(x$coords, x$vicinus_pi, pch=19, cex=0.3, xaxt="n", xlab="", col="gray70", ylab="C. vicinus pi", ylim=c(0,0.15))
lines(x_windows$V1, x_windows$vicinus_pi, lty=2, lwd=2)
plot(x$coords, x$vicinusunk_pi, pch=19, cex=0.3, xaxt="n", xlab="", col="gray70", ylab="C. vicinus unk pi", ylim=c(0,0.15))
lines(x_windows$V1, x_windows$vicinusunk_pi, lty=2, lwd=2)
plot(x$coords, x$laevigatus_pi, pch=19, cex=0.3, xaxt="n", xlab="", col="gray70", ylab="C. laevigatus pi", ylim=c(0,0.15))
lines(x_windows$V1, x_windows$laevigatus_pi, lty=2, lwd=2)
plot(x$coords, x$herculeanus_pi, pch=19, cex=0.3, xaxt="n", xlab="", col="gray70", ylab="C. herculeanus pi", ylim=c(0,0.15))
lines(x_windows$V1, x_windows$herculeanus_pi, lty=2, lwd=2)
plot(x$coords, x$modoc_pi, pch=19, cex=0.3, xaxt="n", xlab="", col="gray70", ylab="C. modoc pi", ylim=c(0,0.15))
lines(x_windows$V1, x_windows$modoc_pi, lty=2, lwd=2)
plot(x$coords, x$pennunk_pi, pch=19, cex=0.3, xaxt="n", xlab="", col="gray70", ylab="C. penn unk pi", ylim=c(0,0.15))
lines(x_windows$V1, x_windows$pennunk_pi, lty=2, lwd=2)


# Test for enrichment of hits in gene bodies for later FP timepoints...
#
time_thresh<-list("X0"=0,"X2"=0,"X5"=0,"X12.5"=7000,"X25"=30000,"X50"=100000)

# Different ways of getting contingency tables
upto_and_after<-function(data,time_points,nt,t,region){
    yes_upto<-sum((data[,region]!=0)&(!rowSums(cbind(rep(0,nrow(data)),data[,time_points[1:t]]))==0))
    no_upto<-sum((data[,region]==0)&(!rowSums(cbind(rep(0,nrow(data)),data[,time_points[1:t]]))==0))
    #yes_upto<-sum((data[,region]!=0)&(rowSums(cbind(rep(0,nrow(data)),data[,time_points[(t+1):nt]]))==0))
    #no_upto<-sum((data[,region]==0)&(rowSums(cbind(rep(0,nrow(data)),data[,time_points[(t+1):nt]]))==0))
    yes_after<-sum((data[,region]!=0)&(rowSums(cbind(rep(0,nrow(data)),data[,time_points[1:t]]))==0))
    no_after<-sum((data[,region]==0)&(rowSums(cbind(rep(0,nrow(data)),data[,time_points[1:t]]))==0))
    contingency.table<-matrix(c(yes_upto,yes_after,no_upto,no_after),2,2,byrow=TRUE)
    return(contingency.table)
}

compare_to_baseline<-function(data,time_points,nt,t,region){
    yes_base<-sum((data[,region]!=0)&(data[,time_points[1]]==1)&(data[,time_points[t+1]]==0))
    no_base<-sum((data[,region]==0)&(data[,time_points[1]]==1)&(data[,time_points[t+1]]==0))
    yes_when<-sum((data[,region]!=0)&(data[,time_points[1]]==0)&(data[,time_points[t+1]]==1))
    no_when<-sum((data[,region]==0)&(data[,time_points[1]]==0)&(data[,time_points[t+1]]==1))
    contingency.table<-matrix(c(yes_base,yes_when,no_base,no_when),2,2,byrow=TRUE)
    return(contingency.table)
}

# this one is really dumb tbh
presence<-function(data,time_points,nt,t,region){
    yes_no<-sum((data[,region]!=0)&(data[,time_points[t]]==0))
    no_no<-sum((data[,region]==0)&(data[,time_points[t]]==0))
    yes_yes<-sum((data[,region]!=0)&(data[,time_points[t]]==1))
    no_yes<-sum((data[,region]==0)&(data[,time_points[t]]==1))
    contingency.table<-matrix(c(yes_no,yes_yes,no_no,no_yes),2,2,byrow=TRUE)
    return(contingency.table)
}

# influenced
influenced_by_FP<-function(data,time_points,nt,t){
    # exclude the hits which have a distance of 0, because what even is that
    d<-data[((data$"gene_body"!=0)&(data[,time_points[t+1]]==1)&(data$"distance"!=0)),]
    #d<-data[((data$"gene_body"!=0)&(data[,time_points[t+1]]==1)),]

#    wt_inf<-sum((d[,time_points[1]]==1)&(d$"distance"<=time_thresh[time_points[t+1]]))
#    wt_ninf<-sum((d[,time_points[1]]==1)&(d$"distance">time_thresh[time_points[t+1]]))
#    nwt_inf<-sum((d[,time_points[1]]==0)&(d$"distance"<=time_thresh[time_points[t+1]]))
#    nwt_ninf<-sum((d[,time_points[1]]==0)&(d$"distance">time_thresh[time_points[t+1]]))

    wt_inf<-sum((rowSums(cbind(rep(0,nrow(d)),d[,time_points[1:t]]))!=0)&(d$"distance"<=time_thresh[time_points[t+1]]))
    wt_ninf<-sum((rowSums(cbind(rep(0,nrow(d)),d[,time_points[1:t]]))!=0)&(d$"distance">time_thresh[time_points[t+1]]))
    nwt_inf<-sum((rowSums(cbind(rep(0,nrow(d)),d[,time_points[1:t]]))==0)&(d$"distance"<=time_thresh[time_points[t+1]]))
    nwt_ninf<-sum((rowSums(cbind(rep(0,nrow(d)),d[,time_points[1:t]]))==0)&(d$"distance">time_thresh[time_points[t+1]]))

    contingency.table<-matrix(c(wt_inf,nwt_inf,wt_ninf,nwt_ninf),2,2,byrow=TRUE)
    return(contingency.table)
}
datapath<-'/Users/stephanie/ll/results/40m_SVM/dREG_regions_confident_0.8.bed.gz'
#datapath<-'/Users/stephanie/ll/results/40m_SVM/dREG_regions_maybe_0.5.bed.gz'
#datapath<-'/Users/stephanie/ll/results/40m_SVM/dREG_regions_preQC_0.8.bed.gz'

data<-read.table(datapath,header=T)

time_points<-c("X0","X2","X5","X12.5","X25","X50")
nt<-length(time_points)
gs.pvals<-list()
gb.pvals<-list()
ng.pvals<-list()
fp.pvals<-list()
gs.tables<-list()
gb.tables<-list()
ng.tables<-list()
fp.tables<-list()
for (t in seq(nt-1)){
    # test gene_start enrichment
    gs.contingency.table<-compare_to_baseline(data,time_points,nt,t,"gene_start")
    chisq.result<-chisq.test(gs.contingency.table)
    stat<-chisq.result$statistic
    pval<-chisq.result$p.value
    cat("Gene start?\n")
    print(gs.contingency.table)
    gs.pvals[time_points[t+1]]<-pval
    gs.tables[[time_points[t+1]]]<-gs.contingency.table

    # test gene_body enrichment
    gb.contingency.table<-compare_to_baseline(data,time_points,nt,t,"gene_body")
    chisq.result<-chisq.test(gb.contingency.table)
    stat<-chisq.result$statistic
    pval<-chisq.result$p.value
    cat("gene body?\n")
    print(gb.contingency.table)
    cat("Chi-sq stat:",stat,"\n")
    cat("p-value of association:",pval,"\n")
    gb.pvals[time_points[t+1]]<-pval
    gb.tables[[time_points[t+1]]]<-gb.contingency.table

    # test non_gene enrichment
    ng.contingency.table<-compare_to_baseline(data,time_points,nt,t,"non_gene")
    chisq.result<-chisq.test(ng.contingency.table)
    stat<-chisq.result$statistic
    pval<-chisq.result$p.value
    cat("non_gene enrichment?\n")
    print(ng.contingency.table)
    cat("Chi-sq stat:",stat,"\n")
    cat("p-value of association:",pval,"\n")
    ng.pvals[time_points[t+1]]<-pval
    ng.tables[[time_points[t+1]]]<-ng.contingency.table

    fp.contingency.table<-influenced_by_FP(subset(data,gene_body!=0),time_points,nt,t)
    chisq.result<-chisq.test(fp.contingency.table)
    stat<-chisq.result$statistic
    pval<-chisq.result$p.value
    cat("effects of FP?\n")
    print(fp.contingency.table)
    cat("Chi-sq stat:",stat,"\n")
    cat("p-value of association:",pval,"\n")
    fp.pvals[time_points[t+1]]<-pval
    fp.tables[[time_points[t+1]]]<-fp.contingency.table
}


### Under-sampling classifier

# setting
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library(doParallel)
cl <- makePSOCKcluster(detectCores(all.tests = FALSE, logical = TRUE) - 1)
registerDoParallel(cl)

set.seed(1234)

######################### Input data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

colnames(Data)
dim(Data)

Data[, table(TrainTest), ]

Data_train <- Data[TrainTest == "Train", , ] #*eligible

Data_test <- Data[TrainTest == "Test", , ] #*eligible

Noise <- function(Var, Data){
		Var + rnorm(mean = 0, sd = sd(Var)/5, n = nrow(Data))
	}

```

# Under-sampling setting
```{r}

# CV methods
CV_method <- "cv"
CV_number <- 5
Repeated_number <- 1
Tune_number <- 1

# Under-sampling parameters
Data_train_original <- data.frame(Data_train)

Parameter_grid <- expand.grid(
 	iii_Top_x_percentile = seq(0.90, 0.98, 0.01)
	) %>% as.data.frame

Population_cut <- Data_train[AMPM == "PM" & Population100000 >= 5, ID, ] %>% unique()
Population_cut

```

# Select top X% and make classifier
```{r}
tic(1)

tic(2)
for(iii in 1:nrow(Parameter_grid)){

############################################# step 1

# Select top X% training data
Data_train <- data.table(Data_train_original)

Top_cut <- Data_train[ID %in% Population_cut, quantile(SeverityAll, p = Parameter_grid[iii, "iii_Top_x_percentile"]), ]
Data_train_top <- Data_train[(ID %in% Population_cut) & (SeverityAll >= Top_cut), , ]

# Select low percentile
Data_train_low <- sample_n(
	tbl = Data_train[(ID %in% Population_cut) & (SeverityAll == 0), , ],     # action
	size = round(nrow(Data_train[(ID %in% Population_cut) & SeverityAll == 0, , ]) * 0.1),
	replace = F
	)
     # Data_train_low[, list(City, Date, SeverityAll), ]

############################################# step 2  make clusters
# clustres in data with top and lowest
# data with top + lowest, the other data
Data_train_top[, Cluster := 1, ]
Data_train_top[, table(ID, Cluster), ]

Data_train_low$Cluster <- as.character(99) # action
Data_train_low[, table(ID, Cluster), ]

Data_train_top_lowest <- rbind(Data_train_top, Data_train_low)  # action

############################################# step 3 xgboost for prediction clusters
### set seed

Size_n <- 36  ### set seed   2 = 16, 3 = 36  5 = 100
Seeds_fix <- vector(mode = "list", length = CV_number * Repeated_number + 1)
for(i in 1:(CV_number * Repeated_number)) Seeds_fix[[i]] <- sample.int(n = 10000, size = Size_n )
Seeds_fix[[(CV_number * Repeated_number + 1)]] <- sample.int(10000, 1)
Seeds_fix

# construct trainControl object for train method
fit_control = trainControl(
	allowParallel = TRUE,
	method = CV_method,
	number = CV_number,
	seeds = Seeds_fix#,
	#selectionFunction = "oneSE"
	)

# xgboost model for classifier
 tic(3)

 Classifier <- train(
    Cluster ~
		Population100000 +
		Mean_income_city_2015 +
		Green_area_percent +
		Age_median_city +
		Population_over_65_100000 +
		SexRatioF +

		RainySeason +
		DifDateRain +
		holiday_flag +
		Hour +
		Month +

		precip1Hour +
		windSpeed_ms +
		DownwardSolarRadiation_kwm2 +
		relativeHumidity +

		temperature +
		temperature_past1d_max_diff +
		temperature_past1d_mean_diff +
		temperature_past1d_min_diff,

    data = Data_train_top_lowest,
	method = "xgbTree",   # action
	trControl = fit_control,
	metric = "Accuracy",    # action
	preProcess = c("center", "scale"),
	tuneLength = 3   # action
      )
summary(Classifier)
Classifier

caret::confusionMatrix(data = predict(Classifier, Data_train_top_lowest) %>% as.factor(), reference = Data_train_top_lowest$Cluster %>% as.factor)

saveRDS(Classifier,
	paste("Classifier_top_",
	Parameter_grid[iii, "iii_Top_x_percentile"],
	"_percent.rds",
	sep = "")
	)

toc(3)

}

toc(2)

```


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

# R code to calculate Peak Hour Excessive Delay(PHED)
# i.e. Annual Hours of Peak Hour Excessive Delay (PHED) Per Capita

# Background:
# -----------
# Webinar providing key definitions here: https://www.fhwa.dot.gov/tpm/rule.cfm (see June 1 webinar, around 30 minutes in, slide 35)
# Slides from the webinar here (no longer available online): M:\Application\Model One\TIP2019\Excessive_delay\170601pm3.pdf
# Additional info here: https://www.fhwa.dot.gov/tpm/rule/pm3/phed.pdf

# Key definitions:
# ----------------
# "Threshold": Travel Time at 20mph OR at 60% of the posted speed limit

# "Peak hours": They define "peak travel hours" as 6-10 a.m. on weekday mornings; and the weekday afternoon period is 3-7 p.m. or 4-8 p.m. (State DOTs and MPOs can choose one that suits them).
# In our travel model we have AM as 6-10 am) and PM as 3-7 pm). So these are the two time periods that we need to analysis (not all five time periods).

# Excessive delay is calculated for three modes - car (drive alone, shared by two, and shared by 3+), trucks (small and medium, and heavy vehicles), and buses.

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

library(foreign)
library(dplyr)
library(tidyr)

##################################
# set file paths
##################################

Scenario <- "M:/Application/Model One/RTP2021/IncrementalProgress/2015_TM152_IPA_16"
PHED_output_file <- "C:/Users/rmccoy/Box/Horizon and Plan Bay Area 2050/Equity and Performance/7_Analysis/Metrics/Connected/PHED_2015.csv"

SFOakUAlinks_txt <-"M:/Application/Model One/TIP2019/Excessive_delay/LinksInSFOakUA_2020n2022.txt"
SJUAlinks_txt <-"M:/Application/Model One/TIP2019/Excessive_delay/LinksInSJUA_2020n2022.txt"

SFOakUAtaz_txt <-"M:/Application/Model One/TIP2019/Excessive_delay/SFOakUA_706TAZ.txt"
SJUAtaz_txt <- "M:/Application/Model One/TIP2019/Excessive_delay/SJUA_336TAZ.txt"

bp = "PlusCrossing"
year = 2050

##################################
# Calculations for cars and trucks
##################################

phed_calc = function(Scenario, bp, year){

  # read the standard output avgload5period_vehclasses.csv from a scenario
  file_cars_n_trucks <- paste0(Scenario, "/OUTPUT/avgload5period_vehclasses.csv")
  RoadwayData <- read.csv(file=file_cars_n_trucks, header=TRUE, sep=",")

  # check number of rows in the dataset
  nrow(RoadwayData)

  # keep cases where facility type does not equal to 6
  RoadwayData <- subset(RoadwayData, ft!=6)
  nrow(RoadwayData)

  # add a column to show 60 percent of posted speed
  RoadwayData$ffs60pc <- RoadwayData$ffs*0.6

  # determine threshold speed
  RoadwayData$threshold_speed <- pmax(RoadwayData$ffs60pc, 20)

  # determine threshold time (in minutes)
  RoadwayData$threshold_time <- RoadwayData$distance/RoadwayData$threshold_speed*60

  #------
  # analysis by time period
  #------

  # determine if the link is below threshold in a certain time period
  RoadwayData$below_thresholdAM <- ifelse(RoadwayData$cspdAM<RoadwayData$threshold_speed, 1, 0)
  RoadwayData$below_thresholdPM <- ifelse(RoadwayData$cspdPM<RoadwayData$threshold_speed, 1, 0)

  # congested travel time (ctim) - threshold_time
  RoadwayData$timediffAM <- RoadwayData$ctimAM - RoadwayData$threshold_time
  RoadwayData$timediffPM <- RoadwayData$ctimPM - RoadwayData$threshold_time

  # excessive delay by link in minutes
  RoadwayData$delayAM = RoadwayData$below_thresholdAM * RoadwayData$timediffAM
  RoadwayData$delayPM = RoadwayData$below_thresholdPM * RoadwayData$timediffPM

  # excessive delay taking volume into account
  RoadwayData$delayXvolAM = RoadwayData$delayAM * (RoadwayData$volAM_da * 1 + RoadwayData$volAM_s2 * 2 + RoadwayData$volAM_s3 * 3 + RoadwayData$volAM_sm * 1 + RoadwayData$volAM_hv * 1
  			+ RoadwayData$volAM_dat * 1 + RoadwayData$volAM_s2t * 2 + RoadwayData$volAM_s3t * 3 + RoadwayData$volAM_smt * 1 + RoadwayData$volAM_hvt * 1)

  RoadwayData$delayXvolPM = RoadwayData$delayPM * (RoadwayData$volPM_da * 1 + RoadwayData$volPM_s2 * 2 + RoadwayData$volPM_s3 * 3 + RoadwayData$volPM_sm * 1 + RoadwayData$volPM_hv * 1
  			+ RoadwayData$volPM_dat * 1 + RoadwayData$volPM_s2t * 2 + RoadwayData$volPM_s3t * 3 + RoadwayData$volPM_smt * 1 + RoadwayData$volPM_hvt * 1)

  # total excessive delay in hours - cars and trucks
  sum(RoadwayData$delayXvolAM)/60
  sum(RoadwayData$delayXvolPM)/60

  ##################################
  # Calculate for delay on buses
  ##################################

  # initiate a vector to store the 15 file paths
  file_busesAM <- vector()
  file_busesPM <- vector()

  dbfAM = read.dbf(paste0(Scenario, "/OUTPUT/trn/trnlinkAM_ALLMSA.dbf"))
  dbfPM = read.dbf(paste0(Scenario, "/OUTPUT/trn/trnlinkPM_ALLMSA.dbf"))

  # we only want bus lines
  # i.e. MODE >= 10 and MODE<100
  # according to this: https://github.com/BayAreaMetro/travel-model-one/blob/master/utilities/PBA40/metrics/bus_opcost.py
  # NewList1 <- filter(BusDataAM1, (MODE>=10 & MODE<100))
  # NewList2 <- filter(BusDataAM2, (MODE>=10 & MODE<100))
  # keep only 4 variables (A, B, MODE and AB_VOL)

  dbf_busonlyAM = dbfAM%>%filter((MODE>=10 & MODE <100))%>%select(A, B, MODE, AB_VOL)%>%group_by(A, B)%>%summarise(bus_vol = sum(AB_VOL))
  dbf_busonlyPM = dbfPM%>%filter((MODE>=10 & MODE <100))%>%select(A, B, MODE, AB_VOL)%>%group_by(A, B)%>%summarise(bus_vol = sum(AB_VOL))

  # write out a file to check
  # write.csv(BusData15FilesAM, file="M:/Application/Model One/TIP2019/Excessive_delay/temp_outfile_am.csv")
  # write.csv(BusData15FilesAM, file="M:/Application/Model One/TIP2019/Excessive_delay/temp_outfile_pm.csv")

  # -------
  # merge the bus volume to the RoadwayFile
  # ------
  RoadwayBusDataAM <- left_join(RoadwayData, dbf_busonlyAM, by = c("a" = "A", "b" = "B"))
  RoadwayBusDataPM <- left_join(RoadwayData, dbf_busonlyPM, by = c("a" = "A", "b" = "B"))

  # fill in the NAs after the left join
  RoadwayBusDataAM$bus_vol[is.na(RoadwayBusDataAM$bus_vol)] <- 0
  RoadwayBusDataPM$bus_vol[is.na(RoadwayBusDataPM$bus_vol)] <- 0

  RoadwayBusDataAM$delayXbus_vol <- RoadwayBusDataAM$delayAM * RoadwayBusDataAM$bus_vol
  RoadwayBusDataPM$delayXbus_vol <- RoadwayBusDataPM$delayPM * RoadwayBusDataPM$bus_vol

  # total excessive delay in hours - bus only
  sum(RoadwayBusDataAM$delayXbus_vol)/60
  sum(RoadwayBusDataPM$delayXbus_vol)/60

  # total excessive delay in hours - car, bus, and trucks
  (sum(RoadwayBusDataAM$delayXvolAM) + sum(RoadwayBusDataAM$delayXbus_vol))/60
  (sum(RoadwayBusDataPM$delayXvolPM) + sum(RoadwayBusDataPM$delayXbus_vol))/60

  # read the VMT file to get total population
  file_population <- paste(Scenario, "/OUTPUT/core_summaries/AutoTripsVMT_personsHomeWork.csv", sep="")
  VMTData <- read.csv(file=file_population, header=TRUE, sep=",")
  totpop_BayArea <- sum(VMTData$freq)
  totpop_BayArea

  # total excessive delay *per person* in hours - car, bus, and trucks (per day)
  PHED_AM <-(sum(RoadwayBusDataAM$delayXvolAM) + sum(RoadwayBusDataAM$delayXbus_vol))/60/totpop_BayArea
  PHED_PM <-(sum(RoadwayBusDataPM$delayXvolPM) + sum(RoadwayBusDataPM$delayXbus_vol))/60/totpop_BayArea

  PHED_annual = (PHED_AM+PHED_PM)*300

  ##################################
  # Add geographic definitions
  ##################################

  # Read the geographic defintions
  SFOakUA_links <- read.csv(file=SFOakUAlinks_txt, header=TRUE, sep=",")
  SJUA_links <- read.csv(file=SJUAlinks_txt, header=TRUE, sep=",")

  SFOakUA_links <- select(SFOakUA_links, A, B, DISTANCE)
  SJUA_links <- select(SJUA_links, A, B, DISTANCE)

  # merge files indicating links that lie within the two urbanized areas respectively
  SFOakUA_RoadwayBusDataAM <- left_join(RoadwayBusDataAM, SFOakUA_links, by = c("a" = "A", "b" = "B"))
  SFOakUA_RoadwayBusDataPM <- left_join(RoadwayBusDataPM, SFOakUA_links, by = c("a" = "A", "b" = "B"))

  SJUA_RoadwayBusDataAM <- left_join(RoadwayBusDataAM, SJUA_links, by = c("a" = "A", "b" = "B"))
  SJUA_RoadwayBusDataPM <- left_join(RoadwayBusDataPM, SJUA_links, by = c("a" = "A", "b" = "B"))

  # filter out the irrelevant links
  SFOakUA_RoadwayBusDataAM <- filter(SFOakUA_RoadwayBusDataAM, !is.na(DISTANCE))
  SFOakUA_RoadwayBusDataPM <- filter(SFOakUA_RoadwayBusDataPM, !is.na(DISTANCE))

  SJUA_RoadwayBusDataAM <- filter(SJUA_RoadwayBusDataAM, !is.na(DISTANCE))
  SJUA_RoadwayBusDataPM <- filter(SJUA_RoadwayBusDataPM, !is.na(DISTANCE))

  ##################################
  # Calculate population
  ##################################

  # read files indicating tazs that lie within the two urbanized areas respectively
  SFOakUA_TAZ <- read.csv(file=SFOakUAtaz_txt, header=TRUE, sep=",")
  SJUA_TAZ <- read.csv(file=SJUAtaz_txt, header=TRUE, sep=",")

  # merge the files
  VMTData_SFOakUA <- left_join(VMTData,SFOakUA_TAZ, by = c("taz" = "TAZ1454"))
  VMTData_SJUA <- left_join(VMTData,SJUA_TAZ, by = c("taz" = "TAZ1454"))

  # filter out the irrelevant zones
  VMTData_SFOakUA <- filter(VMTData_SFOakUA, !is.na(FID))
  VMTData_SJUA <- filter(VMTData_SJUA, !is.na(FID))

  # calculate total population by UA
  SFOakUA_totpop <- sum(VMTData_SFOakUA$freq)
  SJUA_totpop <- sum(VMTData_SJUA$freq)

  # display total population by UA
  SFOakUA_totpop
  SJUA_totpop

  # display excessive delay by UA and by time period (in minutes)
  SFOakUA_carstrucks_AM_minutes <- sum(SFOakUA_RoadwayBusDataAM$delayXvolAM)
  SFOakUA_carstrucks_AM_minutes

  SFOakUA_buses_AM_minutes <-sum(SFOakUA_RoadwayBusDataAM$delayXbus_vol)
  SFOakUA_buses_AM_minutes

  SFOakUA_carstrucks_PM_minutes <-sum(SFOakUA_RoadwayBusDataPM$delayXvolPM)
  SFOakUA_carstrucks_PM_minutes

  SFOakUA_buses_PM_minutes <- sum(SFOakUA_RoadwayBusDataPM$delayXbus_vol)
  SFOakUA_buses_PM_minutes

  SJUA_carstrucks_AM_minutes <-sum(SJUA_RoadwayBusDataAM$delayXvolAM)
  SJUA_carstrucks_AM_minutes

  SJUA_buses_AM_minutes <- sum(SJUA_RoadwayBusDataAM$delayXbus_vol)
  SJUA_buses_AM_minutes

  SJUA_carstrucks_PM_minutes <-sum(SJUA_RoadwayBusDataPM$delayXvolPM)
  SJUA_carstrucks_PM_minutes

  SJUA_buses_PM_minutes <- sum(SJUA_RoadwayBusDataPM$delayXbus_vol)
  SJUA_buses_PM_minutes

  # total excessive delay *per person* in hours - car, bus, and trucks (per day)
  SFOakUA_AM <-sum(SFOakUA_RoadwayBusDataAM$delayXvolAM + SFOakUA_RoadwayBusDataAM$delayXbus_vol)/60/SFOakUA_totpop
  SFOakUA_PM <-sum(SFOakUA_RoadwayBusDataPM$delayXvolPM + SFOakUA_RoadwayBusDataPM$delayXbus_vol)/60/SFOakUA_totpop

  SJUA_AM <- sum(SJUA_RoadwayBusDataAM$delayXvolAM + SJUA_RoadwayBusDataAM$delayXbus_vol)/60/SJUA_totpop
  SJUA_PM <- sum(SJUA_RoadwayBusDataPM$delayXvolPM + SJUA_RoadwayBusDataPM$delayXbus_vol)/60/SJUA_totpop

  ##################################
  # Annualize the results
  ##################################
  # assume 260 days RM: update to 300
  # 52 weeks * 5 weekdays per week = 260 days RM: update to 300
  # although 52*7 = 364 and the maximum number of days in a year is 366, so the max number of weekday in a year can be 262

  # total excessive delay *per person* in hours - car, bus, and trucks - annualized
  PHED_SFOakUA <- (SFOakUA_AM + SFOakUA_PM)* 300
  PHED_SJUA <- (SJUA_AM + SJUA_PM)* 300

  PHED_SFOakUA
  PHED_SJUA

  PHED <- data.frame(PHED_SFOakUA, PHED_SJUA, PHED_annual)

  PHED_export = gather(PHED, index, value, PHED_SFOakUA:PHED_annual, factor_key = TRUE)%>%mutate(Year = year,
                                                                                modelrunID = gsub('M:/Application/Model One/RTP2021/', '', Scenario),
                                                                                Blueprint = bp)

}

phed_2015 = phed_calc("M:/Application/Model One/RTP2021/IncrementalProgress/2015_TM152_IPA_16", "2015", 2015)
phed_2050_np = phed_calc("M:/Application/Model One/RTP2021/Blueprint/2050_TM152_DBP_NoProject_08", "No Project", 2050)
phed_2050_bp = phed_calc("M:/Application/Model One/RTP2021/Blueprint/2050_TM152_DBP_PlusCrossing_08", "PlusCrossing", 2050)

phed_export = rbind(phed_2015, phed_2050_np, phed_2050_bp)

# adjust so that 2015 matches 2017 observed data
SFOakUA_adjust_factor = 31.3/phed_2015[1,2]
SJUA_adjust_factor = 27.5/phed_2015[2,2]
region_adjust_factor = mean(SFOakUA_adjust_factor, SJUA_adjust_factor)

phed_export_adjust = phed_export%>%mutate(adjust_factor = 0)
phed_export_adjust$adjust_factor[phed_export_adjust$index == "PHED_SFOakUA"] = SFOakUA_adjust_factor
phed_export_adjust$adjust_factor[phed_export_adjust$index == "PHED_SJUA"] = SJUA_adjust_factor
phed_export_adjust$adjust_factor[phed_export_adjust$index == "PHED_annual"] = region_adjust_factor

phed_export_adjust = phed_export_adjust%>%mutate(value_adjusted = value * adjust_factor)

# write out the results
# Annual Hours of Peak Hour Excessive Delay (PHED) Per Capita
write.csv(phed_export_adjust, "C:/Users/rmccoy/Box/Horizon and Plan Bay Area 2050/Equity and Performance/7_Analysis/Metrics/Connected/phed.csv")

### calculate PM2.5 from vmt_vht_metrics.csv
# path for 2015 run
Path_2015 = "M:/Application/Model One/RTP2021/IncrementalProgress/2015_TM152_IPA_16/"

# path for 2050 No project run
Path_2050_NP = "M:/Application/Model One/RTP2021/Blueprint/2050_TM152_DBP_NoProject_08/"

# path for 2050 BP run
Path_2050_BP = "M:/Application/Model One/RTP2021/Blueprint/2050_TM152_DBP_PlusCrossing_08/"

PM25_calc = function(path, year, bp){
  df = read.csv(paste0(path, "OUTPUT/metrics/vmt_vht_metrics.csv"))%>%
    mutate(PM25_total_annual = 300*(Diesel_PM2.5+Gas_PM2.5+PM2.5_wear))%>%
    summarize(PM25_total_annual = sum(PM25_total_annual))%>%
    mutate(Year = year,
           Blueprint = bp,
           modelrunID = gsub("/OUTPUT.*$", "", gsub('M:/Application/Model One/RTP2021/', '', path)))%>%
    select(PM25_total_annual, Year, Blueprint, modelrunID)
}

pm25_15 = PM25_calc(Path_2015, 2015, "2015")
pm25_50_np = PM25_calc(Path_2050_NP, 2050, "No Project")
pm25_50_bp = PM25_calc(Path_2050_BP, 2050, "PlusCrossing")

pm25_export = rbind(pm25_15, pm25_50_np, pm25_50_bp)

# write csv
write.csv(pm25_export, "C:/Users/rmccoy/Box/Horizon and Plan Bay Area 2050/Equity and Performance/7_Analysis/Metrics/Healthy/pm25_annual.csv")


library(ggplot2)
library(gridExtra)
library(MASS)
library(grDevices)
library(cowplot)
library(gridGraphics)
library(RColorBrewer)

setwd("Enrichment-Inference-Supplemental-Materials\\simulation_files\\final_figure")
source("convenience.r")

############
# 1. Power plots
############

load("power_all_binorm_unpooled_corr.rdata")
k1.ls <- k.ls
k2.ls <- k.c.ls

m = 150000
pi.0.true = 1/500
params <- k1.ls[[1]][[1]]$params
r <- k1.ls[[1]][[1]]$r
dist <- "binorm"

k.diff.true <- computeTrueKDiff()

source("compare_power.r")
source("convenience.r")

powerplot <- function(){
  par(mfrow = c(1, 2), mai = c(1.02, 0.82, 0.25, 0.2), oma = c(0, 0, 1, 0))
  load("power_all_bibeta_unpooled_nocorr.rdata")
  allMetric(ls = k.ls, legend = 1)
  fig_label("A", cex=1.3, region="figure", pos="topleft", font = 2)
  load("power_all_bibeta_unpooled_corr.rdata")
  allMetric(ls = k.ls, legend = 0)
  fig_label("B", cex=1.3, region="figure", pos="topleft", font = 2)
}

#############################
# 2. Coverage Probability Plots
#############################

covProbPlot <- function() {

  par(mfrow = c(1, 2), mai = c(1.02, 0.82, 0.25, 0.2), oma = c(0, 0, 1, 0))

  all.k <- list(k1.ls, k2.ls)

  cols <- rep(brewer.pal(8,"Paired")[c(2, 4, 6, 8)], each = 2)
  type.v <- rep(c(2, 1), 4)
  frac <- log(all.k[[1]][[1]][[1]]$r * 150000, base = 2)
  xlim <- c(min(frac), max(frac))

  plot(1, type="n", xaxt = 'n', ylab = "Coverage Probability", xlab = "Compounds Tested",
       ylim = c(.5,1), xlim = xlim, main = "", cex.lab = 1)
  ticks <- c(1, 2, log(10, base = 2), seq(6, 8, by = 2), log(1500, base = 2), log(15000, base = 2))
  axis(1, at = ticks, labels = 2^ticks)

  simrep <- length(all.k[[1]][[1]][[1]]$interval.ls)
  idx <- 1
  for(met in c(1, 4, 3)) {
    for(i in 1:2){
      cov.out <- vector(mode = "numeric", length = length(k.diff.true))
      for(l in 1:simrep){
        CI.int <- (all.k[[i]][[1]][[met]]$interval.ls)[[l]]
        for(j in seq_along(k.diff.true)) {
          cov.out[j] <- cov.out[j] + ((round(CI.int[j, 1], 10) <= k.diff.true[j]) & (round(CI.int[j, 2], 10) >= k.diff.true[j]))
        }
      }
      covprobs <- cov.out/simrep

      lines(frac, covprobs, type="l", col = cols[idx], lty = type.v[idx], lwd = 2)
      se <- sqrt(covprobs*(1-covprobs)/simrep)
      ucl <- covprobs + 1.96 * se
      lcl <- covprobs - 1.96 * se
      polygon(c(frac, rev(frac)), c(ucl, rev(lcl)),
              col = add.alpha(cols[idx], .25), border = NA)
      idx <- idx + 1
    }
  }
  abline(h = .95, lty = "dashed")
  legend(x = frac[length(frac) - 13], y = .725, legend=c("EmProc", "CorrBinom","IndJZ"),
         col=cols[c(1, 3, 5)], lty=rep(1, 3), cex = .75, lwd = rep(2, 3), bty = "n")
  legend(x = frac[length(frac) - 13], y = .625, legend = c("Unadjusted", "Plus Adjusted"), col = c("black", "black"), lty = c(2, 1), cex = .75, bty = "n", lwd = 2)
  fig_label("C", cex=1.3, region="figure", pos="topleft", font = 2)

  plot(1, type="n", xaxt = 'n', ylab = "Average Width", xlab = "Compounds Tested",
       ylim = c(0, .1), xlim = xlim, cex.lab = 1)
  ticks <- c(1, 2, log(10, base = 2), seq(6, 8, by = 2), log(1500, base = 2), log(15000, base = 2))
  axis(1, at = ticks, labels = 2^ticks, cex.axis = 1)

  idx <- 1
  for (met in c(1, 4, 3)) {
    for(i in 1:2){
      widthout <- matrix(ncol = length(k.diff.true), nrow = simrep)
      for(l in 1:simrep){
        CI.int <- (all.k[[i]][[1]][[met]]$interval.ls)[[l]]
        widthout[l, ] <- (CI.int[, 2] - CI.int[, 1])
      }
      expwidth <- apply(widthout, MARGIN=2, mean)
      se <- apply(widthout, MARGIN=2, sd)/sqrt(simrep)
      lines(frac, expwidth, type="l", col = cols[idx], lty = type.v[idx], lwd = 1.5)
      ucl <- expwidth + 1.96 * se
      lcl <- expwidth - 1.96 * se
      polygon(c(frac, rev(frac)), c(ucl, rev(lcl)),
              col = add.alpha(cols[idx], .25), border = NA)
      idx <- idx + 1
    }
  }

  fig_label("D", cex=1.3, region="figure", pos="topleft", font = 2)

}

#############################
# 3. Make Plot
#############################

pdf("simulation_plot1.pdf", height = 9, width = 7)

plot_grid(powerplot, covProbPlot, ncol = 1, rel_heights = c( 1, 1))

dev.off()


#my-truth---writes auto.ARIMA model for all seq

rm(list=ls())
sunflower<-list.files("K:\\Project_Data_Sagar\\my_truth\\sangram_clipso\\")

library(forecast)  #loading for auto.arima

zangid<-NULL #for appending

for(ambada in sunflower){
inkar<-read.table(paste("K:\\Project_Data_Sagar\\my_truth\\sangram_clipso\\",ambada,sep=""),skip=1)
shukrana<-substr(ambada,1,nchar(ambada)-4)  #file name
krantivir<-auto.arima( ts(inkar$V4) )       #Auto Arima function

auto_arima_p_value<-krantivir$model$phi     #p-value
auto_arima_p_order<-length(krantivir$model$phi)  #p-order

auto_arima_q_value<-krantivir$model$theta
auto_arima_q_order<-length(krantivir$model$theta)   #q-value
auto_arima_aicc<-krantivir$aicc   #aicc value

sanghmitra<-cbind(shukrana,auto_arima_p_order,paste(auto_arima_p_value,collapse=" "),auto_arima_q_order,paste(auto_arima_q_value,collapse=" "),auto_arima_aicc,deparse.level=0)
zangid<-rbind(zangid,sanghmitra)

}

write.table(zangid,"K:\\Project_Data_Sagar\\Halwa\\BADMASHI\\my_truth\\Model\\Auto_ARIMA\\my_truth_Auto_arima_all.txt",col.names=c("PDB_id","P_order","P_value","Q_order","Q_value","Auto_arima_AICC"),row.names=F)


install.packages("tidyverse")
library(tidyr)
library(dplyr)
library(readr)

find_trees <- function(run, rise) {
  row <- 1
  column <- 1
  trees <- 0
  # Hard-coded total number of rows
  while(row <= 323) {
    if(data[row,column] == "#") {
      trees <- trees + 1
    }

    row <- row + rise
    column <- column + run
    # Hard-coded total number of columns
    if(column > 31) {
      column <- column - 31
    }
  }
  return(trees)
}

# Probably a better way to do this, but read in data as fixed-width values, each 1 char long
data <- read_fwf("input.txt", fwf_widths(c(1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1)))

# Part 1
print(find_trees(3,1))

# Part 2
total_trees <- find_trees(1,1) * find_trees(3,1) * find_trees(5,1) * find_trees(7,1) * find_trees(1,2)
print(total_trees)


##' Create null model forecasts
##'
##' Uses a truncated normal distribution fitted to past data points under the
##' assumption of no change. Contains uk-specific code on truncation at the time
##' of data availability
##'
##' @param forecasts existing forecast data frame
##' @param data data to create null model
##' @return data frame with null model forecasts
##' @importFrom dplyr arrange mutate group_by ungroup filter
##' @importFrom tidyr complete expand_grid nest unnest
##' @importFrom purrr map
##' @author Sebastian Funk
fit_null_model <- function(forecasts, data) {

  creation_dates <- forecasts %>%
    arrange(creation_date) %>%
    .$creation_date %>%
    unique

  use_data <- data %>%
    mutate(truncation = if_else(value_type == "death_inc_line", 4, 0),
           truncation = if_else(value_type == "hospital_inc" &
                                geography == "Wales", 2, truncation),
           truncation = if_else(value_type == "hospital_inc" &
                                geography == "Scotland", 4, truncation),
           truncation = if_else(value_type == "hospital_inc" &
                                geography == "Northern Ireland", 9, truncation)) %>%
    group_by(geography, value_type, value_desc, truncation) %>%
    tidyr::complete(value_date =
                      seq(min(value_date), max(value_date), by = "day"),
                    fill = list(value = 0)) %>%
  ungroup()

  null_model_forecast_df <-
    function(x, creation_date, horizon = 22, truncation = 0)
  {
    quant <-
      null_model_forecast_quantiles(x$value, horizon = horizon,
                                    truncation = truncation)
    df <-
      bind_rows(replicate(horizon + truncation, quant, simplify = FALSE)) %>%
      mutate(value_date = creation_date - truncation +
               seq(1, horizon + truncation),
             model = "null") %>%
      gather(quantile, value, starts_with("0")) %>%
      mutate(value = round(value),
             quantile = as.numeric(quantile))
  }

  fc <- use_data %>%
    group_by(geography, value_desc, value_type, truncation) %>%
    complete(value_date = seq(min(value_date), max(value_date), by = "day"),
             fill = list(value = 0)) %>%
    ungroup() %>%
    expand_grid(creation_date = creation_dates) %>%
    filter(value_date <= creation_date) %>%
    group_by(creation_date, geography, value_desc, value_type, truncation) %>%
    nest() %>%
    mutate(forecast = map(data, null_model_forecast_df,
                          creation_date = creation_date,
                          truncation = truncation)) %>%
    unnest(forecast) %>%
    ungroup() %>%
    select(model, geography, value_type, value_desc, creation_date, value_date,
           quantile, value)

  return(fc)
}

##' Makes a null model forecast based on a vector of values
##'
##' Null model assumes last value stays
##' @param values vector of values
##' @param horizon forecast horizon
##' @param truncation truncation of data series
##' @importFrom msm dtnorm qtnorm
##' @return quantiles of null model predictive distribution
##' @author Sebastian Funk
null_model_forecast_quantiles <- function(values, horizon, truncation = 0)
{
  if (truncation > 0) {
    values <- head(values, -truncation)
  }

  tnorm_unc_fit <- function(x, mean, true) {
    return(-sum(dtnorm(x = true, mean = mean, sd = x, lower = 0, log = TRUE)))
  }

  quantiles <- seq(0.05, 0.95, by = 0.05)
  ts <- tail(values, min(horizon, length(values)))

  if (length(ts) > 1) {
    ## null model
    null_ts <- rep(last(ts), horizon + truncation)

    interval <- c(0, max(abs(diff(ts))))

    if (diff(interval) > 0 ) {
      tnorm_sigma <-
        optimise(tnorm_unc_fit, interval = interval,
                 mean = head(ts, -1),
                 true = tail(ts, -1))

      quant <- round(qtnorm(p = quantiles, mean = last(ts),
                            sd = tnorm_sigma$minimum, lower = 0))
    } else {
      quant <- rep(last(ts), length(quantiles))
    }
  } else {
    quant <- rep(last(ts), length(quantiles))
  }

  names(quant) <- quantiles

  return(quant)
}


##### This script loads in the raw nanostring data, removes low-signal genes and samples,
#     normalizes the gene expression data, and creates well-formatted sample annotations.

source("RCC_gather_n_collect.r")

library(NormqPCR)
library(RColorBrewer)
library(colorspace)

fadecols = function(cols,fade=.5)
{
  fcols = c()
  for(i in 1:length(cols))
  {
    tmp = as.vector(col2rgb(cols[i])/256)
    fcols[i] = rgb(tmp[1],tmp[2],tmp[3],fade)
  }

  return(fcols)
}

#####
# load RCCs
#####

datasets = collate.lanes.2.dataset(allRCC.path = paste0("input_data/CITN_lysate RCC_258_Jan2018/"),
                                   sup.path = paste0("input_data/CITN_lysate RCC_258_Jan2018","//"))$datasets
dat = datasets[[1]]

###### look out for duplicates: #####
is.dup = names(table(dat$sample.annot$Sample.ID))[table(dat$sample.annot$Sample.ID)>1]
rownames(dat$sample.annot[is.element(dat$sample.annot$Sample.ID, is.dup), ])
# any difference in signal?
barplot(rowMeans(log2(pmax(dat$count[is.element(dat$sample.annot$Sample.ID, is.dup), ],1))), las = 2)

# there's one sample run in dup. Delete one of the duplicates:
dup.rcc = "20171228_CITN 22_107-27-013 FUW12_04"
remove = dat$sample.annot$sample.Name==dup.rcc
dat$count = dat$count[!remove,]
dat$sample.annot = dat$sample.annot[!remove,]

for(i in c("count","sample.annot")){rownames(dat[[i]])=dat$sample.annot$Sample.ID}

# extract raw data from the results object:
raw = log2(pmax(dat$count,1))

#####
# load annot
#####
annot = read.csv("input_data/CITN07 sample cohort info.csv",stringsAsFactors = F,row.names=1)
# remove the dup rcc from here as well:
head(annot)
remove = rownames(annot)==paste0(dup.rcc,".RCC")
annot = annot[!remove,]
rownames(annot) = annot$sample.ID

#####
# align annot to rccs, evaluate overlap
#####
sharedids = intersect(rownames(dat$count),rownames(annot))
setdiff(rownames(dat$count),rownames(annot))
setdiff(rownames(annot),rownames(dat$count))
annot = annot[sharedids,]
raw = log2(pmax(dat$count[sharedids,],1))
#rm(dat)
#### split out controls from gene expression data:
neg = raw[,grepl("NEG_",colnames(raw))]
pos = raw[,grepl("POS_",colnames(raw))]
raw = raw[,!grepl("NEG_",colnames(raw))&!grepl("POS_",colnames(raw))]

######
## Signal QC: genes
######

# drop genes in background: all with max below a threshold number of counts:
minrawthresh = 25
in.bg = (apply(raw,2,max)<log2(minrawthresh))
plot(apply(raw,2,mean),apply(raw,2,sd))
plot(apply(raw,2,mean),apply(raw,2,max),col=1+in.bg)
abline(h=log2(minrawthresh))

# remove low signal genes:
raw = raw[,!in.bg]

######
# get HKs and normalize:
######
is.hk = intersect(colnames(raw),rownames(dat$gannot)[dat$gannot$CodeClass=="Housekeeping"])
# run genorm to get good subset:
temp = selectHKs(raw[,is.hk],log=TRUE,minNrHKs=10,Symbols=is.hk)
selectedhks = temp$ranking[names(temp$ranking)<=14]

# calc hk geomean:
hk.factor = apply(raw[,selectedhks],1,mean)

# remove low-signal lanes:
hist(hk.factor,breaks=40,col="grey")
abline(v=5)
lowsignal = hk.factor<5
raw = raw[!lowsignal,]
neg = neg[!lowsignal,]
pos = pos[!lowsignal,]
annot = annot[!lowsignal,]
hk.factor = hk.factor[!lowsignal]
# normalize:
norm = sweep(raw,1,hk.factor,"-")+mean(hk.factor)
# remove HKs from analysis:
norm = norm[,setdiff(colnames(norm),is.hk)]

### assign colors:
timecols = colorspace::diverge_hcl(length(unique(annot$time)))
names(timecols)=levels(annot$time)
annot$timecol = timecols[annot$time]

cohortcols = c("cornflowerblue","orange")
names(cohortcols) = c("2","1")
annot$cohortcol = cohortcols[annot$cohort]

######
# load gene set matrix and align to norm:
######
gannot = as.matrix(read.csv("input_data/PCI gene set matrix.csv",row.names = 1,stringsAsFactors = F))
gannot = gannot[match(colnames(norm),rownames(gannot)),]
gannot = replace(gannot,is.na(gannot),0)

save(norm,annot,gannot,file="data_post_QC_and_normalization/CITN07 normalized data and parsed sample annotation.RData")
save(norm,annot,gannot,file="../NanoString_cell_scores_and_differential_expressoin/data/CITN07 normalized data and parsed sample annotation.RData")
write.csv(norm, file = "data_post_QC_and_normalization/CITN07 normalized expression data ready for analysis October2018.csv")
write.csv(annot, file = "data_post_QC_and_normalization/CITN07 sample annotation data ready for analysis October2018.csv")
write.csv(gannot, file = "data_post_QC_and_normalization/CITN07 gene annotation data ready for analysis October2018.csv")

NanoString_QC_and_normalization/CITN07 data qc and normalization_OLD.r


### Auditing
# The Goal: Reduce audit cost (it is currently a 'binding constraint').
# Making auditing between only a few choices.

# #Cleanup
# rm(list=ls())

# #Load everything
# tryCatch(expr=setwd("~/GitHub/Truthcoin/lib"), error=function(e) setwd(choose.dir(caption="Failed to set working directory automatically. Choose 'Truthcoin/lib' folder:")) )
# source(file="consensus/ConsensusMechanism.r")
#
# Use <- function(package) { if(suppressWarnings(!require(package,character.only=TRUE))) install.packages(package,repos="http://cran.case.edu/") ; require(package,character.only=TRUE) }

# Setup
#
# Data:
#
R <- c(.40, .25, .10, .10, .05, .05, .05)

VM <- matrix( c(1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                1, 0, 0, 0, 0), 7,5,byrow=TRUE)

VM2 <- matrix(c(1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                0, 0, 0, 0, 0,
                0, 0, 0, 0, 0,
                0, 0, 0, 0, 0,
                0, 0, 0, 0, 0,
                0, 0, 0, 0, 0), 7,5,byrow=TRUE)

VM3 <- matrix(c(1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                0, 1, 0, 1, 0,
                0, 0, 0, 0, 1,
                0, 0, 0, 0, 0,
                0, 0, 0, 0, 1,
                0, 0, 0, 0, 1), 7,5,byrow=TRUE)

VM4 <- matrix(c(1, 0, 0, 0, 0,
                1, 0, 0, 0, 0,
                .5, 0, 0, 0, 0,
                .5, 0, 0, 0, 0,
                0, 0, 0, 0, 0,
                0, 0, 0, 0, 0), 6,5,byrow=TRUE)

VM5 <- matrix(c(0.0, 1.0, 0.81, 0.20, 0.03,
                0.0, 1.0, 0.79, 0.20, 0.04, # confused
                0.0, 1.0, 0.80, 0.20, 0.02,
                0.0, 1.0, 0.80, 0.20, 0.03,
                0.0, 1.0, 0.80, 0.98, 0.55, # liars spamming
                0.0, 1.0, 0.80, 0.97, 0.56, # liars spamming
                0.0, 1.0, 0.80, 0.99, 0.57), # liars spamming
              7, 5, byrow=TRUE)

# drawing it out of the binary ballot - cuts everything in half
VM6 <- matrix(c(0.8, 0.0, 0.0, 0.25, 0.045,
                0.6, 0.5, 0.5, 0.20, 0.030,
                0.4, 1.0, 1.0, 0.15, 0.015),
              3, 5, byrow=TRUE)

R6a <- c(.34,.32,.34)

R2 <- c(.40, .20, .20, .17, .01, .01, .01)

# End Setup

GetUniqueBallots <- function(VoteMatrix, Reputation = DemocracyRep(VoteMatrix)) {
  Use('reshape2')
  # Takes a VoteMatrix and Reputation, and returns a minimal set of unique Ballots.

  Rep_VM <- matrix(c(Reputation,VoteMatrix), nrow = nrow(VoteMatrix))

  # Force Unique Names
  colnames(Rep_VM) <- c( "Rep", paste("D",1:(ncol(Rep_VM)-1), sep=".") )

  # Get the unique ballots ("unique"), but ignore non-unique VTC ownership ( " [,-1]" ).
  Map1 <- data.frame( unique(Rep_VM[,-1]) )

  # Relabel (for upcoming merge)
  names(Map1) <- colnames(Rep_VM)[-1] # Again, we're dropping "Rep"

  # Give each Ballot a LETTER label
  Map2 <- cbind( Map1, "BallotGroup"= factor(LETTERS[1:nrow(Map1)]) )

  # Vote Matrix, with labelled Ballots
  Merg <- merge(Rep_VM,Map2)
  MergSub <- Merg[,c("Rep","BallotGroup")]

  # Aggregate Ballots
  Map3 <- dcast(MergSub, formula = BallotGroup~., fun.aggregate = sum, value.var = "Rep") #
  names(Map3) <- c("BallotGroup","BallotRep")

  Merg2 <- merge(Map3,Map2)
  if( !is.null(colnames(VoteMatrix)) ) names(Merg2) <- c( names(Merg2)[1:2], colnames(VoteMatrix) ) # restore original column names (if the given VM had colnames)
  return(Merg2)
}

# GetUniqueBallots(VoteMatrix = VM3, R)
#   BallotGroup BallotRep D.1 D.2 D.3 D.4 D.5
# 1           A      0.65   1   0   0   0   0
# 2           B      0.10   0   1   0   1   0
# 3           C      0.20   0   0   0   0   1
# 4           D      0.05   0   0   0   0   0

# GetUniqueBallots(VoteMatrix = VM4)
#   BallotGroup BallotRep D.1 D.2 D.3 D.4 D.5
# 1           A 0.3333333 1.0   0   0   0   0
# 2           B 0.3333333 0.5   0   0   0   0
# 3           C 0.3333333 0.0   0   0   0   0

# GetUniqueBallots(VoteMatrix = VM5)
#   BallotGroup BallotRep D.1 D.2  D.3  D.4  D.5
# 1           A 0.1428571   0   1 0.81 0.20 0.03
# 2           B 0.1428571   0   1 0.79 0.20 0.04
# 3           C 0.1428571   0   1 0.80 0.20 0.02
# 4           D 0.1428571   0   1 0.80 0.20 0.03
# 5           E 0.1428571   0   1 0.80 0.98 0.55
# 6           F 0.1428571   0   1 0.80 0.97 0.56
# 7           G 0.1428571   0   1 0.80 0.99 0.57

# GetUniqueBallots(VM6,Reputation = R6a)
#   BallotGroup BallotRep D.1 D.2 D.3  D.4   D.5
# 1           A      0.34 0.8 0.0 0.0 0.25 0.045
# 2           B      0.32 0.6 0.5 0.5 0.20 0.030
# 3           C      0.34 0.4 1.0 1.0 0.15 0.015

# We have succeeded in paritioning the VoteMatrix into selections. Auditors need only choose their favorite Ballot.
#
# Can we do better?
# 1. An attacker will likely distort many Decisions at once, to maximize the Attack Revenue.
# 2. Double-Factory will already sort out only the contested Decisions.
# 3. It takes effort for each Auditor to consider each Ballot. Fewer Ballots = Less Effort, Easier Audit.
# 4. Likely, some attacked-Decisions will be extremely-obviously false (a claim that Romney was elected in 2012).
#
# Auditors should be doing MUCH less work than Voters.
# Reducing to an 0 / 1 Ballot Referendum easily allows reuse of the existing SVD consensus system.
#
# Goal: Reduce many unique Ballots to a maximally-representative set of 2 or 3.
# Strategy: calculated 'Moved Reputation' and minimize it.
#
# EasyAuditing
# ==========================

GetTravelMatrix <- function(UniqueBallotDf) {
  # Takes the results computed by 'GetUniqueBallots' and uses them to build a matrix describing how different the Ballots are from each other.

  nBals <- nrow(UniqueBallotDf)

  DistMat <- matrix(0, nBals, nBals,dimnames = list(UniqueBallotDf$BallotGroup, UniqueBallotDf$BallotGroup))

  for(i in 1:nBals) { # for each Ballot-Group A, B, C...
    for(j in 1:nBals) { # for each other Ballot-Group A, B, C...
      if(i!=j) { # Diagonals will always be zero

        RowDifference <- UniqueBallotDf[i,-1:-2] - UniqueBallotDf[j,-1:-2] # How different are these rows?
        Distance <- sum( abs( RowDifference ) ) # Aggregate distance
        DistMat[i,j] <- Distance

        }
      }
    }

  DistMat

  TravelMat <- diag(UniqueBallotDf$BallotRep) %*% DistMat
  row.names(TravelMat) <- colnames(TravelMat)

  return(TravelMat)
}

# GetTravelMatrix( GetUniqueBallots(VoteMatrix = VM3, R) )
#      A    B    C    D
# A 0.00 1.95 1.30 0.65
# B 0.30 0.00 0.30 0.20
# C 0.40 0.60 0.00 0.20
# D 0.05 0.10 0.05 0.00

# GetTravelMatrix( GetUniqueBallots(VoteMatrix = VM4) )
#           A         B         C
# A 0.0000000 0.1666667 0.3333333
# B 0.1666667 0.0000000 0.1666667
# C 0.3333333 0.1666667 0.0000000

### Now, our pooling algorithm

GetChosen <- function(TravMat, ExtractN = 2) {
  # Takes a matrix of travel-distances ("from" row-Ballot "to" column-Ballot) and finds the two nearest destinations (columns)

  Use('combinat')

  Options <- combn(colnames(TravMat), ExtractN)

  # If there is exactly one option, we know will chose it. Also, there will be no columns (as there will be no matrix, just a vector).
  if( is.null(ncol(Options)) ) return(Options)

  BallotPairs <- vector("numeric", ncol(Options))

  # Get Chosen
  for(i in 1:ncol(Options)) {

    ThisDestination <- Options[,i]

    # remove rows where the rowname matched the entries in this Option-column
    # "In a world where these Ballots are staying put (not going from anywhere to anwhere)."

    TravMatTemp <- TravMat[ , colnames(TravMat) %in% ThisDestination ]   # everyone must come to these rows
    TravMatTemp <- TravMatTemp[ !( row.names(TravMatTemp) %in% ThisDestination ) ,] # these rows aren't going anywhere

    if(class(TravMatTemp) =="numeric") {
      # In this case, we've removed all rows except one.
      BallotPairs[i] <- sum(TravMatTemp) # Total distance
      }

    if(class(TravMatTemp) =="matrix") {
      # Normal case
      ColMins <- apply( TravMatTemp, 1, function(x) x[which.min(x)]) # shortest path to a destination
      BallotPairs[i] <- sum(ColMins) # Total distance
      }

    # If TravMatTemp is of a different class, it is probably empty (and we can leave the distances at zero).
    }

  Chosen <- Options[ , which.min(BallotPairs) ]
  return(Chosen)
}

# GetChosen( GetTravelMatrix( GetUniqueBallots(VoteMatrix = VM3, R) ) )
# [1] "A" "C"
#
# GetChosen( GetTravelMatrix( GetUniqueBallots(VoteMatrix = VM4) ) )
# [1] "A" "C"

GetAuditChoices <- function(VoteMatrix, Reputation = DemocracyRep(VoteMatrix), Phi = .80) {
  # Putting it all together.

  # Call our functions.
  Ballots <- GetUniqueBallots(VoteMatrix, Reputation)
  Distance <- GetTravelMatrix(Ballots)

  # Filter small fish / spam Ballots ( because I will be doing combinatorial math next)
  SeriousCandidates <- Distance[, Ballots$BallotRep >= .05 ] # might change ".05" to the Branch's (1-Phi)

  # Grab the most-representative choices, and don't stop grabbing until you have enough
  CumulativeReputation <- 0
  ExtractN <- 2
  while(CumulativeReputation < Phi) {  # ".80" should definitly be Phi
    Chosen <- GetChosen(SeriousCandidates, ExtractN)
    CumulativeReputation <- sum( Ballots[ Ballots$BallotGroup %in% Chosen , "BallotRep" ] )
    ExtractN <- ExtractN + 1
  }

  # For simplicity
  InChosen <- ( row.names(Distance) %in% Chosen )

  # Create two dataframes
  Choices <- Ballots[ InChosen , ]
  NonChoices <- Ballots[ !(InChosen) , ]

  # Get some info to tell people which Ballots contain which.
  NonChDist <- as.matrix( Distance[ !(InChosen) , InChosen ] )

  NonChoices$SurrogateChoice <- apply( NonChDist, 1, function(x) colnames(NonChDist)[which.min(x)] )

  return(list("Choices"=Choices,"NonChoices"=NonChoices))

}

# GetAuditChoices(VM4)
#
# GetAuditChoices(VM3, R)
# GetAuditChoices(VM3, R2)
#
# GetAuditChoices(VM5)
# GetAuditChoices(VM5, R2)
#
# GetAuditChoices(VM6, R6a)
# Here, we've succeeded in drawing the 'real' ballot (B) off, using 68% of the votes. However, B still has a surrogate choice ("C")
# B will deterministically have a unique surrogate choice (not a "Tie") unless every single Decision was scaled and had a real outcome of exactly ".5" (which is nearly impossible).


# Prep ----
rm(list = ls())

remotes::install_gitlab("luccoffeng/virsim")

library(virsim)
library(ggplot2)
library(data.table)
library(rjson)
library(forecast)

work_dir <- getwd()
setwd(work_dir)

###############################################################
# the json input file containing the values of the parameters #
###############################################################

json_data <- fromJSON(file="corona_in.json")

rnd_seed <- unname(sapply(json_data$seed, as.integer))

output_filename <- json_data$outfile

# strategy
int_effect <- unname(sapply(json_data$intervention_effect, as.numeric))

uptake <- unname(sapply(json_data$uptake, as.numeric))

#################################
# define main set of parameters #
#################################

size_multiplier <- 1
param_main <- within(param_sim, {
  runtime <- 550

  n_agent <- 1e6 * size_multiplier
  n_cluster <- 1e3 * size_multiplier
  n_supercluster <- 20

  cluster_size_sd <- 0.95
  supercluster_size_sd <- 0

  efoi <- 0
  infection_init <- 50 * size_multiplier
  seed_supercluster <- c(rep(9, 2), rep(2, 6), rep(1, 6), rep(0, 6))
  inc_cum_cond <- 9500 * size_multiplier

  contact_rate <- 0.5
  contact_shape <- 3.4
  contact_assort <- 0.26
  population_mixing <- .05
  supercluster_mixing <- .05

  exposed_time <- list(name = "weibull",
                       shape = 20,
                       scale = exp(log(4.6) - lgamma(1 + 1 / 20)))
  infected_time <- list(name = "weibull",
                        shape = 1,
                        scale = exp(log(5) - lgamma(1 + 1 / 1)))

  trace_prob_E <- c(rep(0, 5))
  trace_rate_I <- c(rep(0, 5))
  trace_contact_reduction <- c(rep(0, 5))

  temp_storage <- "RAM"
  aggregate <- "population"
  output_quick <- TRUE
  output_steps <- 1
  verbose <- FALSE # turn off printing of progress to console
})

#######################################################################################
# Running an individual simulation for the Flattening the Curve strategy using virsim #
#######################################################################################

intervention_t <- cumsum(c(0, 10, 7, 53, 30))
intervention_effect <- c(1, .3, .15, .25, int_effect)
intervention_uptake <- rep(uptake, length(intervention_t))

# Select a random seed per each realization (using the system time)
#initial_seed <- as.integer(Sys.time())
# take the last 5 digits of the initial seed
#the_seed <- initial_seed %% 1e5
# set the seed
set.seed(rnd_seed)

flat_curve <- do.call(what = virsim,
                      args = c(param_main,
                               list(intervention_t = intervention_t,
                                    intervention_uptake = intervention_uptake,
                                    intervention_effect = intervention_effect,
                                    efoi = 50 / 365 / param_main$n_agent)))

flat_curve_data <- aggregate_output(flat_curve$monitor)
flat_curve_data[, c("IC_inc", "IC_prev") :=
                  gen_derived_outcome(inc = inc, time = time)]

###########################################################################
# Compute the moving average of total IC patients over a certain interval #
###########################################################################
L <- length(flat_curve_data$IC_prev)
IC_prev_avg <- vector(mode="numeric", length=L)

avg_window <- 30
#for (i in 1:L){
#  IC_prev_avg[i] <- mean(flat_curve_data$IC_prev[i:min(i+avg_window-1,L)])
#}
IC_prev_avg <- ma(x=flat_curve_data$IC_prev,order=avg_window)
#IC_prev_avg <- na.omit(IC_prev_avg)
flat_curve_data[, "IC_prev_avg"] <- IC_prev_avg
flat_curve_data[, "IC_prev_avg_max"] <- max(na.omit(IC_prev_avg))

###########################################################
# Compute the number of IC patients exceeding IC capacity #
###########################################################
IC_excess <- vector(mode="numeric", length=L)
IC_capacity <- 109

IC_excess[1] <- 0 # at the beginning of the simulation there are no IC patients in excess
for (i in 2:L){
  IC_excess[i] <- IC_excess[i-1] + max(0, flat_curve_data$IC_prev[i]-IC_capacity)
}

flat_curve_data[, "IC_ex"] <- IC_excess
flat_curve_data[, "IC_ex_max"] <- max(IC_excess)

#############################
# Write results to csv file #
#############################
write.csv(x=flat_curve_data, file=output_filename, row.names=FALSE)

### END OF CODE ###