#############################################################
# spatially averages outputs other than streamflow
#############################################################

## load libraries
library(dplyr)
# library(readr)
library(stringr)
library(tidyr)
library(lubridate)
library(data.table)
library(tools)
library(doParallel)
library(foreach)

## user inputs
setwd('/work/dbroman/projects/skokomish/run_vic')
loca_run_list = scan('lib/loca_run_list.txt', what = 'character')
longitude_list = scan('lib/longitude_list.txt')
latitude_list = scan('lib/latitude_list.txt')
date_vec = seq(from = as.Date('1950-01-01'), to = as.Date('2099-12-31'), by = 'day')
date_vec_historic = seq(from = as.Date('1950-01-01'),
	to = as.Date('2013-12-31'), by = 'day')

nlon = length(longitude_list)
nlat = length(latitude_list)

nproj = length(loca_run_list)
coord_tbl = data.table(lon = longitude_list,
	lat = rep(latitude_list, each = nlon))
nfiles = nrow(coord_tbl)

# swe
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('data/output/', proj_sel, '/')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp,
			'snow_', lat_sel, '_', lon_sel))$V5, lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/swe_future.csv',
	row.names = F, quote = F)
#sm
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('data/output/', proj_sel, '/')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp, 'etsm_',
			lat_sel, '_', lon_sel))$V10, lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/sm_future.csv',
	row.names = F, quote = F)

#aet
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('data/output/', proj_sel, '/')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp, 'etsm_',
			lat_sel, '_', lon_sel))$V4, lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/aet_future.csv',
	row.names = F, quote = F)

#pet (short-grass reference)
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('data/output/', proj_sel, '/')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp, 'etsm_',
			lat_sel, '_', lon_sel))$V7, lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/pet_future.csv',
	row.names = F, quote = F)

# swe (historic)
filepath_temp = paste0('data/output/livneh_historic/')
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, 'snow_',
		lat_sel, '_', lon_sel))$V5, lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/swe_historic.csv',
	row.names = F, quote = F)

# sm (historic)
filepath_temp = paste0('data/output/livneh_historic/')
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, 'etsm_',
		lat_sel, '_', lon_sel))$V10, lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/sm_historic.csv',
	row.names = F, quote = F)

# aet (historic)
filepath_temp = paste0('data/output/livneh_historic/')
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, 'etsm_',
		lat_sel, '_', lon_sel))$V4, lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/aet_historic.csv', row.names = F, quote = F)

# pet (historic)
filepath_temp = paste0('data/output/livneh_historic/')
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, 'etsm_',
		lat_sel, '_', lon_sel))$V7, lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/pet_historic.csv',
	row.names = F, quote = F)

#precip
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('/work/dbroman/projects/skokomish/process_loca/data/processed/vic/', proj_sel, '/Meterology_LOCA_skokomish_', proj_sel, '_')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp, lat_sel, '_', lon_sel))$V1, lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/precip_future.csv', row.names = F, quote = F)

#max temperature
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('/work/dbroman/projects/skokomish/process_loca/data/processed/vic/', proj_sel, '/Meterology_LOCA_skokomish_', proj_sel, '_')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp, lat_sel, '_', lon_sel))$V2, lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/tmax_future.csv', row.names = F, quote = F)

#min temperature
dat_future = data.table()
for(i in 1:nproj){
	proj_sel = loca_run_list[i]
	filepath_temp = paste0('/work/dbroman/projects/skokomish/process_loca/data/processed/vic/',
		proj_sel, '/Meterology_LOCA_skokomish_', proj_sel, '_')
	dat_proj = data.table()
	for(j in 1:nfiles){
		lon_sel = coord_tbl$lon[j]
		lat_sel = coord_tbl$lat[j]
		dat_temp = data.table(value = fread(paste0(filepath_temp, lat_sel, '_', lon_sel))$V3,
			lon = lon_sel, lat = lat_sel)
		dat_proj = bind_rows(dat_proj, dat_temp)
	}
	dat_proj$date = date_vec
	dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))
	dat_proj$proj = proj_sel
	dat_future = bind_rows(dat_future, dat_proj)
}
dat_future_sp = dat_future %>% spread(proj, value)
write.csv(dat_future_sp, 'data/processed/spatial_avg/tmin_future.csv',
	row.names = F, quote = F)

# precip (historic)
filepath_temp = '/data/vic/forcings/livneh_1_16/ascii/Meteorology_Livneh_NAmerExt_15Oct2014_'
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, lat_sel, '_', lon_sel))$V1,
		lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/precip_historic.csv',
	row.names = F, quote = F)

# tmax (historic)
filepath_temp = '/data/vic/forcings/livneh_1_16/ascii/Meteorology_Livneh_NAmerExt_15Oct2014_'
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, lat_sel, '_', lon_sel))$V2,
		lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/tmax_historic.csv',
	row.names = F, quote = F)

# tmin (historic)
filepath_temp = '/data/vic/forcings/livneh_1_16/ascii/Meteorology_Livneh_NAmerExt_15Oct2014_'
dat_proj = data.table()
for(j in 1:nfiles){
	lon_sel = coord_tbl$lon[j]
	lat_sel = coord_tbl$lat[j]
	dat_temp = data.table(value = fread(paste0(filepath_temp, lat_sel, '_', lon_sel))$V2,
		lon = lon_sel, lat = lat_sel)
	dat_proj = bind_rows(dat_proj, dat_temp)
}
dat_proj$date = date_vec_historic
dat_proj = dat_proj %>% group_by(date) %>% summarise(value = mean(value))

dat_historic = data.table(historic = dat_proj$value)
write.csv(dat_historic, 'data/processed/spatial_avg/tmin_historic.csv',
	row.names = F, quote = F)


library(ape)

##Read in probeCertain ASTRAL tree
setwd("~/PleuroceridaePhylogenetics/probeRegion/CertainPruned/multipleIQtreeRuns_finalTrees/")
tree2<-read.tree(file = "probeCertain_LB_RCFV_newIQTREE-BS10.astral.renamed.tre")
tree2$edge.length

##Branch lengths not set by ASTRAL are read in as NaN, which allows use of below command
tree2$edge.length[is.nan(tree2$edge.length)]<-0.15
tree2$edge.length
write.tree(tree2,file="probeCertain_LB_RCFV_newIQTREE-BS10.astral.renamed.rescaled.tre")

##Read in probeCertain astralMap Trees
astralMapTree<-read.tree(file ="probeCertain_LB_RCFV_newIQTREE-BS10.astral.mapCahabaPleuro2Lepto.tre")
astralMapTree$edge.length
astralMapTree$edge.length[is.nan(astralMapTree$edge.length)]<-0.15
write.tree(astralMapTree,file="probeCertain_LB_RCFV_newIQTREE-BS10.astral.mapCahabaPleuro2Lepto.rescaled.tre")

##NEXT TREE  ##Just without taxon map
setwd("~/PleuroceridaePhylogenetics/threeRegions/Alicut/CertainTrimmed/ASTRAL/")
##Read in probeCertain ASTRAL tree
tree2<-read.tree(file = "threeAlicutCertain_LB_RCFV_newIQTREE-BS10.astral.renamed.tre")
tree2$edge.length

##Branch lengths not set by ASTRAL are read in as NaN, which allows use of below command
tree2$edge.length[is.nan(tree2$edge.length)]<-0.15
tree2$edge.length
write.tree(tree2,file="threeAlicutCertain_LB_RCFV_newIQTREE-BS10.astral.renamed.rescaled.tre")

##NEXT TREE
setwd("~/PleuroceridaePhylogenetics/threeRegions/noMasking/CertainTrimmed/multipleIQTREEruns_finalTrees/")
##Read in probeCertain ASTRAL tree
tree2<-read.tree(file = "threeCertain_LB_RCFV_newIQTREE-BS10.astral.renamed.tre")
tree2$edge.length

##Branch lengths not set by ASTRAL are read in as NaN, which allows use of below command
tree2$edge.length[is.nan(tree2$edge.length)]<-0.15
tree2$edge.length
write.tree(tree2,file="threeCertain_LB_RCFV_newIQTREE-BS10.astral.renamed.rescaled.tre")


#### Usage: Rscript this.r <query_mean_log10_Pgen> <title> <output_prefix> <Pgen_merged_filenames> ...

args = c("-6.50983782728612", "NP2", "scenarios_without_mismatches.parsed_back_Pgen_merged_20191008/debug", "run_igor_PP1_5_NP1_2_20190925/scenarios_without_mismatches/Pgen_merged.back_71_4models.20191008.tsv", "run_igor_PP1_5_NP1_2_20190925/scenarios_without_mismatches/Pgen_merged.back_72_4models.20191008.tsv")
args = c("-9.58015253617941", "PP11", "scenarios_without_mismatches.parsed_back_Pgen_merged_20191008/debug", "run_igor_PP6_13_20190925/scenarios_without_mismatches/Pgen_merged.back_6_4models.20191008.tsv")
args = c("-9.88303666161822", "PP12", "parsed_back_Pgen_merged_20191008/debug", "run_igor_PP6_13_20190925/Pgen_merged.20191002/back_7_4models.tsv")
if(!interactive()){
	args = commandArgs(TRUE)
}

#query_part = as.integer(args[1])
#query_seq_idx = as.integer(args[2])
query_log10_Pgen = as.numeric(args[1])
title = args[2]
output_prefix = args[3]

# setwd("/Users/yyx/Documents/work/huan/IGoR")
options(stringsAsFactors=FALSE)

`%.%` = function(x,y) paste0(x,y)

join = function(sep, vec, ...) paste(collapse=sep, c(vec, ...))
cat0 = function(...) cat(sep="", ...)

echo_str <- function(x, sep=" =\t", collapse=", ") deparse(substitute(x)) %.% sep %.% join(collapse, x)
echo <- function(x, sep=" =\t", collapse=", ") cat0(deparse(substitute(x)), sep, join(collapse, x), "\n");

final_DF = character(0)
query_DF = character(0)
#query_log10_Pgen = log10(query_Pgen)

for(Pgen_merged_filename in args[4:length(args)]){
	echo(Pgen_merged_filename)
	input = read.delim(Pgen_merged_filename)
	echo(dim(input))

	if(nrow(input) <= 0){
		next
	}

	Pgen_DF = input[,-1]
	log10_Pgen_DF = log10(Pgen_DF)
	names(log10_Pgen_DF) = "log10_" %.% names(log10_Pgen_DF)

	log10_Pgen_DF$mean = rowMeans(log10_Pgen_DF)

	log10_Pgen_DF$mean[log10_Pgen_DF$mean < -20] = -20
#	log10_Pgen_DF$mean[is.nan(log10_Pgen_DF$mean)] = -21

	names(log10_Pgen_DF)[names(log10_Pgen_DF)=="mean"] = "mean_log10_Pgen"
	output_DF = cbind(input, log10_Pgen_DF)
	output_DF$exp10_mean_log10_Pgen = 10^output_DF$mean_log10_Pgen
	echo(dim(output_DF))

#	if(Pgen_merged_filename == "run_igor_20190308/scenarios_without_mismatches/Pgen_merged.back_" %.% query_part %.% "_4models.20181207.tsv"){   # hard-coded, bad
#		query_rowidx = which(input$seq_index == query_seq_idx)
#		query_DF = output_DF[query_rowidx, ]
#		query_log10_Pgen = query_DF$mean_log10_Pgen[1]
#	}

	final_DF = rbind(final_DF, output_DF)
}
echo(dim(final_DF))

print(query_DF)

if(!is.nan(query_log10_Pgen)){
	gt_Pgen_count = sum(final_DF$mean_log10_Pgen > query_log10_Pgen, na.rm=TRUE)
	echo(gt_Pgen_count)
	ge_Pgen_count = sum(final_DF$mean_log10_Pgen >= query_log10_Pgen, na.rm=TRUE)
	echo(ge_Pgen_count)
	output_rowidx = which(final_DF$mean_log10_Pgen >= query_log10_Pgen - 1)
	ge_PgenDiv10_count = length(output_rowidx)
	echo(ge_PgenDiv10_count)
	output_rowidx = which(final_DF$mean_log10_Pgen >= query_log10_Pgen - 2)
	ge_PgenDiv100_count = length(output_rowidx)
	echo(ge_PgenDiv100_count)
}

pdf(output_prefix %.% ".pdf", width=5.5, height=5.5)
par(mar=c(3,3,3,1)+.1, mgp=c(2,0.8,0))

hist_result = hist(final_DF$mean_log10_Pgen, breaks=seq(-20.5, -4.5, by=1), plot=FALSE)
y_max = max(hist_result$density[-1])
plot(hist_result, freq=FALSE, xlab="mean log10(Pgen)", main=title %.% " back-translated CDR3 sequences", ylim=c(0,y_max))
rug(query_log10_Pgen)
#mtext("original CDR3 seq_index = " %.%  query_seq_idx %.% " in part back_" %.% query_part)
#my_text = "P(Pgen==NaN)\n= " %.% nan_Pgen_count %.% "/" %.% nrow(final_DF) %.% " = " %.% format(nan_Pgen_count / nrow(final_DF), digits=3)
if(!is.nan(query_log10_Pgen)){
my_text = "P(mean log10(Pgen) > " %.% format(query_log10_Pgen, digits=3) %.% ")\n"
my_text = my_text %.% "= " %.% gt_Pgen_count %.% "/" %.% nrow(final_DF) %.% " = " %.% format(gt_Pgen_count / nrow(final_DF), digits=3)
my_text = my_text %.% "\nP(mean log10(Pgen) >= " %.% format(query_log10_Pgen, digits=3) %.% ")\n"
my_text = my_text %.% "= " %.% ge_Pgen_count %.% "/" %.% nrow(final_DF) %.% " = " %.% format(ge_Pgen_count / nrow(final_DF), digits=3)
my_text = my_text %.% "\nP(mean log10(Pgen) >= " %.% format(query_log10_Pgen-1, digits=3) %.% ")\n"
my_text = my_text %.% "= " %.% ge_PgenDiv10_count %.% "/" %.% nrow(final_DF) %.% " = " %.% format(ge_PgenDiv10_count / nrow(final_DF), digits=3)
my_text = my_text %.% "\nP(mean log10(Pgen) >= " %.% format(query_log10_Pgen-2, digits=3) %.% ")\n"
my_text = my_text %.% "= " %.% ge_PgenDiv100_count %.% "/" %.% nrow(final_DF) %.% " = " %.% format(ge_PgenDiv100_count / nrow(final_DF), digits=3)
text(-4.5, y_max, adj=c(1,1), my_text, cex=0.8)
}
#text(-4.5, y_max, adj=c(1,1), my_text, cex=0.8)

dev.off()

if(!is.nan(query_log10_Pgen)){
output_DF = final_DF[output_rowidx, ]
output_DF = output_DF[order(-output_DF$mean_log10_Pgen, output_DF$seq_index),]

if(nrow(output_DF) > 600){
	output_DF = output_DF[1:600,]
}

write.table(output_DF, file=output_prefix %.% ".tsv", sep="\t", quote=FALSE, row.names=FALSE)
}


#' Perform Decision Curve Analysis
#'
#' Diagnostic and prognostic models are typically evaluated with measures of
#' accuracy that do not address clinical consequences.
#' Decision-analytic techniques allow assessment of clinical outcomes but often
#' require collection of additional information may be cumbersome to apply to
#' models that yield a continuous result. Decision curve analysis is a method
#' for evaluating and comparing prediction models that incorporates clinical
#' consequences, requires only the data set on which the models are tested,
#' and can be applied to models that have either continuous or dichotomous
#' results.
#' The dca function performs decision curve analysis for binary outcomes.
#' Review the
#' [DCA Vignette](http://www.danieldsjoberg.com/dcurves/articles/dca.html)
#' for a detailed walk-through of various applications.
#' Also, see [www.decisioncurveanalysis.org](https://www.mskcc.org/departments/epidemiology-biostatistics/biostatistics/decision-curve-analysis) for more information.
#'
#' @author Daniel D Sjoberg
#'
#' @param formula a formula with the outcome on the LHS and a sum of
#' markers/covariates to test on the RHS
#' @param data a data frame containing the variables in `formula=`.
#' @param thresholds vector of threshold probabilities between 0 and 1.
#' Default is `seq(0, 0.99, by = 0.01)`. Thresholds at zero are replaced
#' with 10e-10.
#' @param label named list of variable labels, e.g. `list(age = "Age, years)`
#' @param harm named list of harms associated with a test. Default is `NULL`
#' @param as_probability character vector including names of variables
#' that will be converted to a probability. Details below.
#' @param time if outcome is survival, `time=` specifies the time the
#' assessment is made
#' @param prevalence When `NULL`, the prevalence is estimated from `data=`.
#' If the data passed is a case-control set, the population prevalence
#' may be set with this argument.
#'
#' @section as_probability argument:
#' While the `as_probability=` argument can be used to convert a marker to the
#' probability scale, use the argument only when the consequences are fully
#' understood. For example, when the outcome is binary, logistic regression
#' is used to convert the marker to a probability. The logistic regression
#' model assumes linearity on the log-odds scale and can induce
#' miscalibration when this assumption is not true. Miscalibration in a
#' model will adversely affect performance on decision curve
#' analysis. Similarly, when the outcome is time-to-event, Cox Proportional
#' Hazards regression is used to convert the marker to a probability.
#' The Cox model also has a linearity assumption and additionally assumes
#' proportional hazards over the follow-up period. When these assumptions
#' are violated, important miscalibration may occur.
#'
#' Instead of using the `as_probability=` argument, it is suggested to perform
#' the regression modeling outside of the `dca()` function utilizing methods,
#' such as non-linear modeling, as appropriate.
#'
#' @return List including net benefit of each variable
#' @seealso [`net_intervention_avoided()`], [`standardized_net_benefit()`], [`plot.dca()`],
#' [`as_tibble.dca()`]
#' @export
#'
#' @examples
#' # calculate DCA with binary endpoint
#' dca(cancer ~ cancerpredmarker + marker,
#'     data = df_binary,
#'     as_probability = "marker",
#'     label = list(cancerpredmarker = "Prediction Model", marker = "Biomarker")) %>%
#'   # plot DCA curves with ggplot
#'   plot(smooth = TRUE) +
#'   # add ggplot formatting
#'   ggplot2::labs(x = "Treatment Threshold Probability")
#'
#' # calculate DCA with time to event endpoint
#' dca(Surv(ttcancer, cancer) ~ cancerpredmarker, data = df_surv, time = 1)
dca <- function(formula, data, thresholds = seq(0, 0.99, by = 0.01),
                label = NULL, harm = NULL, as_probability = character(),
                time = NULL, prevalence = NULL) {
  # checking inputs ------------------------------------------------------------
  if (!is.data.frame(data))
    stop("`data=` must be a data frame", call. = FALSE)
  if (!inherits(formula, "formula"))
    stop("`formula=` must be a formula", call. = FALSE)
  if (!is.null(label) && (!rlang::is_list(label) || !rlang::is_named(label)))
    stop("`label=` must be a named list or NULL.", call. = FALSE)
  if (!is.null(harm) && (!rlang::is_list(harm) || !rlang::is_named(harm)))
    stop("`harm=` must be a named list or NULL.", call. = FALSE)
  if (!is.character(as_probability))
    stop("`as_probability=` must be character.", call. = FALSE)

  # prepping data --------------------------------------------------------------
  thresholds <- thresholds[thresholds >= 0 & thresholds < 1]
  thresholds[thresholds == 0] <- 10e-10

  label <-
    list(all = "Treat All", none = "Treat None") %>%
    purrr::list_modify(!!!label)
  model_frame <- stats::model.frame(formula, data)
  outcome_name <- names(model_frame)[1]
  if (any(c("all", "none") %in% names(model_frame))) {
    stop("Variables cannot be named 'all' or 'none': they are reserved.",
         call. = FALSE)
  }

  outcome_type <-
    dplyr::case_when(
      inherits(model_frame[[outcome_name]], "Surv") ~ "survival",
      length(unique(model_frame[[outcome_name]])) == 2L ~ "binary",
      length(unique(model_frame[[outcome_name]])) == 1L &&
        inherits(model_frame[[outcome_name]], "factor") &&
        length(attr(model_frame[[outcome_name]], "level")) == 2L ~ "binary",
      length(unique(model_frame[[outcome_name]])) == 1L &&
        inherits(model_frame[[outcome_name]], "logical") ~ "binary"
    )
  if (is.na(outcome_type)) {
    paste(
      "Outcome type not supported. Expecting a binary endpoint",
      "or an object of class 'Surv'."
    ) %>%
      stop(call. = FALSE)
  }
  if (outcome_type == "survival" && is.null(time)) {
    stop("`time=` must be specified for survival endpoints.")
  }

  # for binary outcomes, make the outcome a factor
  # so both levels always appear in `table()` results
  if (outcome_type == "binary") {
    model_frame[[outcome_name]] <-
      .convert_to_binary_fct(model_frame[[outcome_name]], quiet = FALSE)
  }

  # convert to probability if requested ----------------------------------------
  as_probability <-
    model_frame %>%
    dplyr::select(-dplyr::all_of(outcome_name)) %>%
    dplyr::select(dplyr::all_of(as_probability))
  for (v in names(as_probability)) {
    model_frame[[v]] <- .convert_to_risk(model_frame[[outcome_name]],
      model_frame[[v]],
      outcome_type = outcome_type,
      time = time
    )
  }
  for (v in names(model_frame) %>% setdiff(outcome_name)) {
    if (any(!dplyr::between(model_frame[[v]], 0L, 1L))) {
      glue::glue("Error in {v}. All covariates/risks must be between 0 and 1.") %>%
        stop(call. = FALSE)
    }
  }

  # add treat all and treat none -----------------------------------------------
  model_frame <-
    model_frame %>%
    dplyr::mutate(
      all = 1L,
      none = 0L,
      .after = .data[[outcome_name]]
    )

  # calculate net benefit ------------------------------------------------------
  dca_result <-
    names(model_frame) %>%
    setdiff(outcome_name) %>%
    lapply(
      function(x) {
        .calculate_test_consequences(model_frame[[outcome_name]],
          model_frame[[x]],
          thresholds = thresholds,
          outcome_type = outcome_type,
          prevalence = prevalence,
          time = time
        ) %>%
          dplyr::mutate(
            variable = x,
            label = .env$label[[x]] %||% attr(model_frame[[x]], "label") %||% x,
            harm = .env$harm[[x]] %||% 0,
            .before = .data$threshold
          )
      }
    ) %>%
    dplyr::bind_rows() %>%
    dplyr::mutate(
      label = factor(.data$label, levels = unique(.data$label)),
      harm = dplyr::coalesce(harm, 0),
      net_benefit =
        .data$tp_rate - .data$threshold /
          (1 - .data$threshold) * .data$fp_rate - .data$harm
    ) %>%
    tibble::as_tibble()

  # return results -------------------------------------------------------------
  lst_result <-
    list(
      call = match.call(),
      y = outcome_name,
      n = dca_result$n[1],
      prevalence = dca_result$prevalence[1],
      time = time,
      dca = dca_result
    ) %>%
    purrr::compact()
  class(lst_result) <- "dca"
  lst_result
}

#' Calculate a test's consequences
#'
#' @param outcome outcome vector
#' @param risk vector of risks
#' @param thresholds threshold probs vector
#' @param outcome_type type of outcome
#' @param time time to calculate risk if Surv() outcome
#' @param prevalence specifed prevleance (if cannot be estimated from data)
#'
#' @noRd
#' @keywords internal
.calculate_test_consequences <- function(outcome, risk, thresholds, outcome_type,
                                         prevalence, time) {
  df <-
    tibble::tibble(
      threshold = thresholds,
      n = length(outcome)
    )
  # case-control population prev
  if (!is.null(prevalence)) {
    df$prevalence <- prevalence
  } # survival endpoint prev
  else if (outcome_type == "survival") {
    outcome_prev <- .surv_to_risk(outcome ~ 1, time = time, quiet = TRUE) # TODO: print the multistate model note only once
    if (is.na(outcome_prev)) {
      paste(
        "Cannot calculate outcome prevalence at specified time,",
        "likely due to no observed data beyond selected time."
      ) %>%
        stop(call. = FALSE)
    }
    df$prevalence <- outcome_prev
  }
  # typical binary prev
  else {
    df$prevalence <- table(outcome)[2] / length(outcome)
  }

  if (outcome_type == "binary") {
    df <-
      df %>%
      dplyr::rowwise() %>%
      dplyr::mutate(
        test_pos_rate =
          .convert_to_binary_fct(risk >= .data$threshold) %>%
            table() %>%
            purrr::pluck(2) %>% {
              . / .data$n
            },
        tp_rate =
          mean(risk[outcome == "TRUE"] >= .data$threshold) * .data$prevalence %>%
          unname(),
        fp_rate =
          mean(risk[outcome == "FALSE"] >= .data$threshold) * (1 - .data$prevalence) %>%
          unname(),
      )
  }
  else if (outcome_type == "survival") {
    df <-
      df %>%
      dplyr::rowwise() %>%
      dplyr::mutate(
        test_pos_rate =
          .convert_to_binary_fct(risk >= .data$threshold) %>%
            table() %>%
            purrr::pluck(2) %>%
            {. / .data$n},
        risk_rate_among_test_pos =
          tryCatch(
            .surv_to_risk(outcome[risk >= .data$threshold] ~ 1, time = time),
            error = function(e) {
              if (length(outcome[risk >= .data$threshold]) == 0L) {
                return(0)
              }
              NA_real_
            }
          ),
        tp_rate = .data$risk_rate_among_test_pos * .data$test_pos_rate %>%
          unname(),
        fp_rate = (1 - .data$risk_rate_among_test_pos) * .data$test_pos_rate %>%
          unname(),
      )
  }

  df %>%
    dplyr::ungroup() %>%
    dplyr::select(dplyr::any_of(c(
      "threshold", "prevalence",
      "n", "tp_rate", "fp_rate"
    )))
}

#' Convert binary outcome to factor
#'
#' @param x a vector
#' @param quiet logical. default is TRUE
#'
#' @noRd
#' @keywords internal
.convert_to_binary_fct <- function(x, quiet = TRUE) {
  # if not logical, convert to lgl
  if (!inherits(x, "logical")) {
    outcome_levels_sorted <- unique(x) %>% sort()
    if (!quiet) {
      glue::glue(
        "Assuming '{outcome_levels_sorted[2]}' is [Event] ",
        "and '{outcome_levels_sorted[1]}' is [non-Event]"
      ) %>%
        message()
    }
    x <-
      dplyr::case_when(
        x %in% outcome_levels_sorted[1] ~ FALSE,
        x %in% outcome_levels_sorted[2] ~ TRUE
      )
  }
  # convert lgl to fct
  factor(x, levels = c(FALSE, TRUE))
}

#' Calculate risks
#'
#' @param outcome outcome object
#' @param variable variable
#' @param outcome_type type of outcome
#' @param time time to calculate risk if Surv() outcome
#' @param prevalence specifed prevleance (if cannot be estimated from data)
#'
#' @noRd
#' @keywords internal
.convert_to_risk <- function(outcome, variable, outcome_type,
                             time = NULL, prevalence = NULL) {
  if (outcome_type == "binary" && !is.null(prevalence)) {
    stop("Cannot convert to risks in case-control setting.")
  }

  if (outcome_type == "binary") {
    risk <-
      stats::glm(outcome ~ variable, family = stats::binomial) %>%
      stats::predict(type = "response")
  } else if (outcome_type == "survival") {
    # construct data frame
    df <- data.frame(outcome = outcome, variable = variable)
    new_df <- data.frame(outcome = outcome, variable = variable)
    new_df$outcome[, 1] <- time
    # build model, and get predictions for time point of interest
    risk <-
      survival::coxph(outcome ~ variable, data = df) %>%
      stats::predict(newdata = new_df, type = "expected") %>%
      {
        exp(-.)
      }
  }

  risk
}

#' Convert a `Surv()` object to a n-time risk estimate
#'
#' @param outcome `Surv()` object
#' @param time numeric time
#' @param quiet logical, default is TRUE
#'
#' @noRd
#' @keywords internal
.surv_to_risk <- function(outcome, time, quiet = TRUE) {
  df_tidy <-
    survival::survfit(outcome) %>%
    broom::tidy()

  # if multistate (i.e. competing risks) delete states not of interest
  if ("state" %in% names(df_tidy)) {
    state <- unique(df_tidy$state) %>%
      setdiff("(s0)") %>%
      purrr::pluck(1)
    df_tidy <- df_tidy %>% dplyr::filter(.data$state %in% .env$state)
    if (!isTRUE(quiet)) {
      glue::glue(
        "Multi-state model detected. Showing probabilities into state '{state}'") %>%
        message()
    }
  }
  # if regular survfit() model, convert survival to risk
  else {
    df_tidy <- dplyr::mutate(df_tidy, estimate = 1 - .data$estimate)
  }

  # if no observed times after specified time, return NA
  if (max(df_tidy$time) < time) {
    return(NA_real_)
  }

  df_tidy <-
    df_tidy %>%
    dplyr::filter(.data$time <= .env$time)

  # if no observed times after time point, return NA
  if (nrow(df_tidy) == 0L) {
    return(NA_real_)
  }

  df_tidy %>%
    dplyr::slice_tail() %>%
    dplyr::pull(.data$estimate)
}


# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

#' Perform GWAS using FarmCPU method
#'
#' Date build: Febuary 24, 2013
#' Last update: May 25, 2017
#' Requirement: Y, GD, and CV should have same taxa order. GD and GM should have the same order on SNPs
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param phe phenotype, n by t matrix, n is sample size, t is number of phenotypes
#' @param geno genotype, m by n matrix, m is marker size, n is sample size. This is Pure Genotype Data Matrix(GD). THERE IS NO COLUMN FOR TAXA.
#' @param map SNP map information, m by 3 matrix, m is marker size, the three columns are SNP_ID, Chr, and Pos
#' @param CV covariates, n by c matrix, n is sample size, c is number of covariates
#' @param P start p values for all SNPs
#' @param method.sub method used in substitution process, five options: 'penalty', 'reward', 'mean', 'median', or 'onsite'
#' @param method.sub.final method used in substitution process, five options: 'penalty', 'reward', 'mean', 'median', or 'onsite'
#' @param method.bin method for selecting the most appropriate bins, three options: 'static', 'EMMA' or 'FaST-LMM'
#' @param bin.size bin sizes for all iterations, a vector, the bin size is always from large to small
#' @param bin.selection number of selected bins in each iteration, a vector
#' @param memo a marker on output file name
#' @param Prior prior information, four columns, which are SNP_ID, Chr, Pos, P-value
#' @param ncpus number of threads used for parallele computation
#' @param maxLoop maximum number of iterations
#' @param threshold.output only the GWAS results with p-values lower than threshold.output will be output
#' @param converge a number, 0 to 1, if selected pseudo QTNs in the last and the second last iterations have a certain probality (the probability is converge) of overlap, the loop will stop
#' @param iteration.output whether to output results of all iterations
#' @param p.threshold if all p values generated in the first iteration are bigger than p.threshold, FarmCPU stops
#' @param QTN.threshold in second and later iterations, only SNPs with lower p-values than QTN.threshold have chances to be selected as pseudo QTNs
#' @param bound maximum number of SNPs selected as pseudo QTNs in each iteration
#' @param verbose whether to print detail.
#'
#' @return a m by 4 results matrix, m is marker size, the four columns are SNP_ID, Chr, Pos, and p-value
#' @export
#'
#' @examples
#' phePath <- system.file("extdata", "07_other", "mvp.phe", package = "rMVP")
#' phenotype <- read.table(phePath, header=TRUE)
#' idx <- !is.na(phenotype[, 2])
#' phenotype <- phenotype[idx, ]
#' print(dim(phenotype))
#' genoPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.desc", package = "rMVP")
#' genotype <- attach.big.matrix(genoPath)
#' genotype <- deepcopy(genotype, cols=idx)
#' print(dim(genotype))
#' mapPath <- system.file("extdata", "06_mvp-impute", "mvp.imp.geno.map", package = "rMVP")
#' map <- read.table(mapPath , head = TRUE)
#'
#' farmcpu <- MVP.FarmCPU(phe=phenotype,geno=genotype,map=map,maxLoop=2,method.bin="static")
#' str(farmcpu)
#'
`MVP.FarmCPU` <- function(phe, geno, map, CV=NULL, P=NULL, method.sub="reward", method.sub.final="reward",
                          method.bin=c("EMMA", "static", "FaST-LMM"), bin.size=c(5e5,5e6,5e7), bin.selection=seq(10,100,10),
                          memo="MVP.FarmCPU", Prior=NULL, ncpus=2, maxLoop=10,
                          threshold.output=.01, converge=1, iteration.output=FALSE, p.threshold=NA,
                          QTN.threshold=0.01, bound=NULL, verbose=TRUE){
    #print("--------------------- Welcome to FarmCPU ----------------------------")

    if(!is.big.matrix(geno))    stop("genotype should be in 'big.matrix' format.")
    if(sum(is.na(phe[, 2])) != 0) stop("NAs are not allowed in phenotype.")
    if(nrow(phe) != ncol(geno)) stop("number of individuals not match in phenotype and genotype.")

    echo=TRUE
    nm=nrow(map)
    if(!is.null(CV)){
        CV=as.matrix(CV)
        CV.index <- apply(CV, 2, function(x) length(table(x)) > 1)
	    CV <- CV[, CV.index, drop=FALSE]
        npc=ncol(CV)
    }else{
        npc=0
    }
    method.bin=match.arg(method.bin)

	map <- as.matrix(map)
	suppressWarnings(max.chr <- max(as.numeric(map[, 2]), na.rm=TRUE))
	if(is.infinite(max.chr))	max.chr <- 0
	map.xy.index <- which(!as.numeric(map[, 2]) %in% c(0 : max.chr))
	if(length(map.xy.index) != 0){
		chr.xy <- unique(map[map.xy.index, 2])
		for(i in 1:length(chr.xy)){
			map[map[, 2] == chr.xy[i], 2] <- max.chr + i
		}
	}
    map[, 1] = 1:nrow(map)
	suppressWarnings(map <- matrix(as.numeric(map), nrow(map)))
    if(sum(is.na(map[,3]) != 0)) stop("Non-digital characters or NAs are not allowed in map for FarmCPU")

    if(!is.na(p.threshold)) QTN.threshold = max(p.threshold, QTN.threshold)

    name.of.trait=colnames(phe)[2]
    if(!is.null(memo)) name.of.trait=paste(memo,".",name.of.trait,sep="")
    theLoop=0
    theConverge=0
    seqQTN.save=c(0)
    seqQTN.pre=c(-1)
    isDone=FALSE
    name.of.trait2=name.of.trait

    while(!isDone) {
        theLoop=theLoop+1
        logging.log(paste("Current loop: ",theLoop," out of maximum of ", maxLoop, sep=""), "\n", verbose = verbose)

        spacer="0"
        if(theLoop>9){
            spacer=""
        }
        if(iteration.output){
            name.of.trait2=paste("Iteration_",spacer,theLoop,".",name.of.trait,sep="")
        }

        #Step 2a: Set prior
        myPrior=FarmCPU.Prior(GM=map,P=P,Prior=Prior)

        #Step 2b: Set bins
        if(theLoop<=2){
            myBin=FarmCPU.BIN(Y=phe[,c(1,2)],GDP=geno,GM=map,CV=CV,P=myPrior,method=method.bin,b=bin.size,s=bin.selection,theLoop=theLoop,bound=bound,ncpus=ncpus, verbose = verbose)
        }else{
            myBin=FarmCPU.BIN(Y=phe[,c(1,2)],GDP=geno,GM=map,CV=theCV,P=myPrior,method=method.bin,b=bin.size,s=bin.selection,theLoop=theLoop,ncpus=ncpus, verbose = verbose)
        }

        #Step 2c: Remove bin dependency
        #Remove QTNs in LD
        seqQTN=myBin$seqQTN

        if(theLoop==2){
            if(!is.na(p.threshold)){
                if(min(myPrior,na.rm=TRUE)>p.threshold){
                    seqQTN=NULL
                    logging.log("Top snps have little effect, set seqQTN to NULL!", "\n", verbose = verbose)
                    }
                }else{
                    if(min(myPrior,na.rm=TRUE)>0.01/nm){
                        seqQTN=NULL
                        logging.log("Top snps have little effect, set seqQTN to NULL!", "\n", verbose = verbose)
                    }
                }
            }

            #when FarmCPU can not work, make a new QQ plot and manhatthan plot
            if(theLoop==2&&is.null(seqQTN)){
                #Report
                P=myGLM$P[,ncol(myGLM$P)]
                P[P==0] <- min(P[P!=0],na.rm=TRUE)*0.01
                results = cbind(myGLM$B, myGLM$S, P)
                colnames(results) = c("effect", "se", "p")
                break
            }#force to exit for GLM model while seqQTN=NULL and h2=0

            if (!any(is.null(seqQTN.save)) && theLoop > 1) {
                if (!(0 %in% seqQTN.save || -1 %in% seqQTN.save) && !is.null(seqQTN)) {
                    #Force previous QTNs in the model
                    seqQTN <- union(seqQTN,seqQTN.save)
                }
            }
            if(theLoop!=1){
                seqQTN.p=myPrior[seqQTN]
                if(theLoop==2){
                    index.p=seqQTN.p<QTN.threshold
                    #if(!is.na(p.threshold)){
                    #index.p=seqQTN.p<p.threshold
                    #}
                    seqQTN.p=seqQTN.p[index.p]
                    seqQTN=seqQTN[index.p]
                    seqQTN.p=seqQTN.p[!is.na(seqQTN)]
                    seqQTN=seqQTN[!is.na(seqQTN)]
                }else{
                    index.p=seqQTN.p<QTN.threshold
                    #if(!is.na(p.threshold)){
                    #index.p=seqQTN.p<p.threshold
                    #}
                    index.p[seqQTN%in%seqQTN.save]=TRUE
                    seqQTN.p=seqQTN.p[index.p]
                    seqQTN=seqQTN[index.p]
                    seqQTN.p=seqQTN.p[!is.na(seqQTN)]
                    seqQTN=seqQTN[!is.na(seqQTN)]
                }
            }

            myRemove=FarmCPU.Remove(GDP=geno,GM=map,seqQTN=seqQTN,seqQTN.p=seqQTN.p,threshold=.7)

            #Recoding QTNs history
            seqQTN=myRemove$seqQTN
            theConverge=length(intersect(seqQTN,seqQTN.save))/length(union(seqQTN,seqQTN.save))
            circle=(length(union(seqQTN,seqQTN.pre))==length(intersect(seqQTN,seqQTN.pre)))

            #handler of initial status
            if(is.null(seqQTN.pre)){circle=FALSE
            }else{
                if(seqQTN.pre[1]==0) circle=FALSE
                if(seqQTN.pre[1]==-1) circle=FALSE
            }

            logging.log("seqQTN:", "\n", verbose = verbose)
            if(is.null(seqQTN)){
                logging.log("NULL", "\n", verbose = verbose)
            }else{
                logging.log(seqQTN, "\n", verbose = verbose)
            }

            if(theLoop==maxLoop){
                logging.log(paste("Total number of possible QTNs in the model is: ", length(seqQTN),sep=""), "\n", verbose = verbose)
            }

            isDone=((theLoop>=maxLoop) | (theConverge>=converge) | circle )

            seqQTN.pre=seqQTN.save
            seqQTN.save=seqQTN

            #Step 3: Screen with bins
            rm(myBin)
            gc()

            theCV=CV

            if(!is.null(myRemove$bin)){
                if(length(myRemove$seqQTN) == 1){
                    #myRemove$bin = as.matrix(myRemove$bin)
                    myRemove$bin = t(myRemove$bin)
                }
                theCV=cbind(CV,myRemove$bin)
            }

            myGLM=FarmCPU.LM(y=phe[,2],GDP=geno,w=theCV,ncpus=ncpus,npc=npc, verbose=verbose)
            if(!is.null(seqQTN)){
                if(ncol(myGLM$P) != (npc + length(seqQTN) + 1))    stop("wrong dimensions.")
            }

            #Step 4: Background unit substitution
            if(!isDone){
                myGLM=FarmCPU.SUB(GM=map,GLM=myGLM,QTN=map[myRemove$seqQTN, , drop=FALSE],method=method.sub)
            }else{
                myGLM=FarmCPU.SUB(GM=map,GLM=myGLM,QTN=map[myRemove$seqQTN, , drop=FALSE],method=method.sub.final)
            }
            P=myGLM$P[,ncol(myGLM$P)]
            P[P==0] <- min(P[P!=0], na.rm=TRUE)*0.01
            results = cbind(myGLM$B, myGLM$S, P)
            colnames(results) = c("effect", "se", "p")
        } #end of while loop
        #print("****************FarmCPU ACCOMPLISHED****************")
        return(results)
}#The MVP.FarmCPU function ends here

#' FarmCPU.FaSTLMM.LL
#' Evaluation of the maximum likelihood using FaST-LMM method
#'
#' Last update: January 11, 2017
#' Requirement: pheno, snp.pool, and X0 must have same taxa order.
#' Requirement: No missing data
#'
#' @author Xiaolei Liu (modified)
#'
#' @param pheno a two-column phenotype matrix
#' @param snp.pool matrix for pseudo QTNs
#' @param X0 covariates matrix
#' @param ncpus number of threads used for parallel computation
#'
#' @return
#' Output: beta - beta effect
#' Output: delta - delta value
#' Output: LL - log-likelihood
#' Output: vg - genetic variance
#' Output: ve - residual variance
#'
`FarmCPU.FaSTLMM.LL` <- function(pheno, snp.pool, X0=NULL, ncpus=2){
    y=pheno
    p=0
    deltaExpStart = -5
    deltaExpEnd = 5
    snp.pool=snp.pool[,]

    if(!is.null(snp.pool)&&var(snp.pool)==0){
        deltaExpStart = 100
        deltaExpEnd = deltaExpStart
    }
    if(is.null(X0)) {
        X0 = matrix(1, nrow(snp.pool), 1)
    }
    X=X0
    #########SVD of X
    K.X.svd <- svd(snp.pool)
    d=K.X.svd$d
    d=d[d>1e-08]
    d=d^2
    U1=K.X.svd$u
    U1=U1[,1:length(d)]
    #handler of single snp
    if(is.null(dim(U1))) U1=matrix(U1,ncol=1)
    n=nrow(U1)
    U1TX=crossprod(U1,X)
    U1TY=crossprod(U1,y)
    yU1TY <- y-U1%*%U1TY
    XU1TX<- X-U1%*%U1TX
    IU = -tcrossprod(U1)
    diag(IU) = rep(1,n) + diag(IU)
    IUX=crossprod(IU,X)
    IUY=crossprod(IU,y)
    #Iteration on the range of delta (-5 to 5 in glog scale)
    delta.range <- seq(deltaExpStart,deltaExpEnd,by=0.1)
    m <- length(delta.range)
    #for (m in seq(deltaExpStart,deltaExpEnd,by=0.1)){
    beta.optimize.parallel <- function(ii){
        #p=p+1
        delta <- exp(delta.range[ii])
        #----------------------------calculate beta-------------------------------------
        #######get beta1
        beta1=0
        for(i in 1:length(d)){
            one=matrix(U1TX[i,], nrow=1)
            beta=crossprod(one,(one/(d[i]+delta)))  #This is not real beta, confusing
            beta1= beta1+beta
        }

        #######get beta2
        beta2=0
        for(i in 1:nrow(U1)){
            one=matrix(IUX[i,], nrow=1)
            beta = crossprod(one)
            beta2= beta2+beta
        }
        beta2<-beta2/delta

        #######get beta3
        beta3=0
        for(i in 1:length(d)){
            one1=matrix(U1TX[i,], nrow=1)
            one2=matrix(U1TY[i,], nrow=1)
            beta=crossprod(one1,(one2/(d[i]+delta)))
            beta3= beta3+beta
        }

        ###########get beta4
        beta4=0
        for(i in 1:nrow(U1)){
            one1=matrix(IUX[i,], nrow=1)
            one2=matrix(IUY[i,], nrow=1)
            beta=crossprod(one1,one2)
            beta4= beta4+beta
        }
        beta4<-beta4/delta

        #######get final beta
        zw1 <- ginv(beta1+beta2)
        #zw1 <- try(solve(beta1+beta2))
        #if(inherits(zw1, "try-error")){
        #zw1 <- ginv(beta1+beta2)
        #}

        zw2=(beta3+beta4)
        beta=crossprod(zw1,zw2)

        #----------------------------calculate LL---------------------------------------
        ####part 1
        part11<-n*log(2*3.14)
        part12<-0
        for(i in 1:length(d)){
            part12_pre=log(d[i]+delta)
            part12= part12+part12_pre
        }
        part13<- (nrow(U1)-length(d))*log(delta)
        part1<- -1/2*(part11+part12+part13)

        ######  part2
        part21<-nrow(U1)
        ######part221

        part221=0
        for(i in 1:length(d)){
            one1=U1TX[i,]
            one2=U1TY[i,]
            part221_pre=(one2-one1%*%beta)^2/(d[i]+delta)
            part221 = part221+part221_pre
        }

        part222=0
        for(i in 1:n){
            one1=XU1TX[i,]
            one2=yU1TY[i,]
            part222_pre=((one2-one1%*%beta)^2)/delta
            part222= part222+part222_pre
        }
        part22<-n*log((1/n)*(part221+part222))
        part2<- -1/2*(part21+part22)

        ################# likihood
        LL<-part1+part2
        part1<-0
        part2<-0

        return(list(beta=beta,delta=delta,LL=LL))
    }
    llresults <- lapply(1:m, beta.optimize.parallel)
    for(i in 1:m){
        if(i == 1){
            beta.save = llresults[[i]]$beta
            delta.save = llresults[[i]]$delta
            LL.save = llresults[[i]]$LL
        }else{
            if(llresults[[i]]$LL > LL.save){
                beta.save = llresults[[i]]$beta
                delta.save = llresults[[i]]$delta
                LL.save = llresults[[i]]$LL
            }
        }
    }
    #--------------------update with the optimum------------------------------------
    beta=beta.save
    delta=delta.save
    LL=LL.save

    #--------------------calculating Va and Vem-------------------------------------
    #sigma_a1
    sigma_a1=0
    for(i in 1:length(d)){
        one1=matrix(U1TX[i,], ncol=1)
        one2=matrix(U1TY[i,], nrow=1)
        #sigma_a1_pre=(one2-one1%*%beta)^2/(d[i]+delta)
        sigma_a1_pre=(one2-crossprod(one1,beta))^2/(d[i]+delta)
        sigma_a1= sigma_a1+sigma_a1_pre
    }

    ### sigma_a2
    sigma_a2=0

    for(i in 1:nrow(U1)){
        one1=matrix(IUX[i,], ncol=1)
        one2=matrix(IUY[i,], nrow=1)
        #sigma_a2_pre<-(one2-one1%*%beta)^2
        sigma_a2_pre<-(one2-crossprod(one1,beta))^2
        sigma_a2= sigma_a2+sigma_a2_pre
    }

    sigma_a2<-sigma_a2/delta
    sigma_a<- 1/n*(sigma_a1+sigma_a2)
    sigma_e<-delta*sigma_a

    return(list(beta=beta, delta=delta, LL=LL, vg=sigma_a, ve=sigma_e))
}

#' FarmCPU.BIN
#'
#' Last update: March 28, 2017
#' Requirement: Y, GDP, and CV must have same taxa order. GDP and GM must have the same order on SNP
#' Requirement: P and GM are in the same order
#' Requirement: No missing data
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param Y a n by 2 matrix, the fist column is taxa id and the second is trait
#' @param GDP genotype, m by n matrix, m is marker size, n is sample size. This is Pure Genotype Data Matrix(GD). THERE IS NO COLUMN FOR TAXA
#' @param GM SNP map information, m by 3 matrix, m is marker size, the three columns are SNP_ID, Chr, and Pos
#' @param CV covariates, n by c matrix, n is sample size, c is number of covariates
#' @param P start p values for all SNPs
#' @param method two options, 'static' or 'FaST-LMM'
#' @param b bin sizes for all iterations, a vector, the bin size is always from large to small
#' @param s number of selected bins in each iteration, a vector
#' @param theLoop iteration number
#' @param bound maximum number of SNPs selected as pseudo QTNs in each iteration
#' @param ncpus number of threads used for parallele computation
#' @param verbose whether to print detail.
#'
#' @return
#' Output: seqQTN - an s by 1 vecter for index of QTNs on GM file
#'
#' @keywords internal
FarmCPU.BIN <-
    function(Y=NULL, GDP=NULL, GM=NULL, CV=NULL, P=NULL, method="EMMA", b=c(5e5,5e6,5e7), s=seq(10,100,10), theLoop=NULL, bound=NULL, ncpus=2, verbose=TRUE){
        #print("FarmCPU.BIN Started")

        if(is.null(P)) return(list(bin=NULL,binmap=NULL,seqQTN=NULL))

        #Set upper bound for bin selection to squareroot of sample size
        n=nrow(Y)
        #bound=round(sqrt(n)/log10(n))
        if(is.null(bound)){
            bound=round(sqrt(n)/sqrt(log10(n)))
        }

        s[s>bound]=bound
        s=unique(s[s<=bound]) #keep the within bound

        optimumable=(length(b)*length(s)>1)
        if(!optimumable & method!="optimum"){
            method="static"
        }

        if(optimumable){
            s[s>bound]=bound
            #print("optimizing possible QTNs...")
            #GP=cbind(GM,P,NA,NA,NA)
            #mySpecify=FarmCPU.Specify(GI=GM, GP=GP, bin.size=b, inclosure.size=s)
            #seqQTN=which(mySpecify$index==TRUE)
        }

        #Method of static
        if(method=="static"&optimumable){
            #print("Via static")
            if(theLoop==2){
                b=b[3]
            }else if(theLoop==3){
                b=b[2]
            }else{
                b=b[1]
            }
            s=bound
            s[s>bound]=bound
            logging.log("Optimizing Pseudo QTNs...", "\n", verbose = verbose)
            GP=cbind(GM,P,NA,NA,NA)
            mySpecify=FarmCPU.Specify(GI=GM,GP=GP,bin.size=b,inclosure.size=s)
            seqQTN.save=which(mySpecify$index==TRUE)
        }

        #Method of optimum: FaST-LMM
        #============================Optimize by FaST-LMM============================================
        if(method=="FaST-LMM"&optimumable){
            #print("c(bin.size, bin.selection, -2LL, VG, VE)")
            logging.log("Optimizing Pseudo QTNs...", "\n", verbose = verbose)
            count=0
            for (bin in b){
                for (inc in s){
                    count=count+1
                    GP=cbind(GM,P,NA,NA,NA)
                    mySpecify=FarmCPU.Specify(GI=GM,GP=GP,bin.size=bin,inclosure.size=inc)
                    seqQTN=which(mySpecify$index==TRUE)
                    GK=t(GDP[seqQTN,])
                    myBurger=FarmCPU.Burger(Y=Y[,1:2], CV=CV, GK=GK, ncpus=ncpus, method=method)
                    myREML=myBurger$REMLs
                    myVG=myBurger$vg #it is unused
                    myVE=myBurger$ve #it is unused
                    logging.log(c(bin,inc,myREML,myVG,myVE), "\n", verbose = verbose)
                    #Recoding the optimum GK
                    if(count==1){
                        seqQTN.save=seqQTN
                        LL.save=myREML
                        bin.save=bin
                        inc.save=inc
                        vg.save=myVG  # for genetic variance
                        ve.save=myVE  # for residual variance
                    }else{
                        if(myREML<LL.save){
                            seqQTN.save=seqQTN
                            LL.save=myREML
                            bin.save=bin
                            inc.save=inc
                            vg.save=myVG  # for genetic variance
                            ve.save=myVE  # for residual variance
                        }
                    } #end of if(count==1)
                }#loop on bin number
            }#loop on bin size
            #seqQTN=seqQTN.save
        }

        #Method of optimum: EMMA
        #============================Optimize by EMMA============================================
        if(method=="EMMA"&optimumable){
            #print("c(bin.size, bin.selection, -2LL, VG, VE)")
            logging.log("Optimizing Pseudo QTNs...", "\n", verbose = verbose)
            m <- length(b)*length(s)
            inc.index = rep(c(1:length(s)), length(b))

            seqQTN.optimize.parallel <- function(ii){
                bin.index = floor((ii-0.1)/length(s)) + 1
                bin = b[bin.index]
                inc = s[inc.index[ii]]
                GP=cbind(GM,P,NA,NA,NA)
                mySpecify=FarmCPU.Specify(GI=GM,GP=GP,bin.size=bin,inclosure.size=inc)
                seqQTN=which(mySpecify$index==TRUE)
                GK=t(GDP[seqQTN,])
                myBurger=FarmCPU.Burger(Y=Y[,1:2], CV=CV, GK=GK, ncpus=ncpus, method=method)
                myREML=myBurger$REMLs
                myVG=myBurger$vg #it is unused
                myVE=myBurger$ve #it is unused
                logging.log(c(bin,inc,myREML,myVG,myVE), "\n", verbose = verbose)
                return(list(seqQTN=seqQTN,myREML=myREML))
            }
            llresults <- lapply(1:m, seqQTN.optimize.parallel)

            for(i in 1:m){
                if(i == 1){
                    seqQTN.save = llresults[[i]]$seqQTN
                    myREML.save = llresults[[i]]$myREML
                }else{
                    if(llresults[[i]]$myREML < myREML.save){
                        seqQTN.save = llresults[[i]]$seqQTN
                        myREML.save = llresults[[i]]$myREML
                    }
                }
            }
        }

        #Method of optimum: GEMMA
        #can not be used to provide REML
        #============================Optimize by GEMMA============================================
        if(method=="GEMMA"&optimumable){
            #print("c(bin.size, bin.selection, -2LL, VG, VE)")
            logging.log("Optimizing Pseudo QTNs...\n", verbose = verbose)
            m <- length(b)*length(s)

            seqQTN.optimize.parallel <- function(ii){
                bin = floor((ii-0.1)/length(s)) + 1
                inc = rep(c(1:length(s)), length(b))
                GP=cbind(GM,P,NA,NA,NA)
                mySpecify=FarmCPU.Specify(GI=GM,GP=GP,bin.size=bin[ii],inclosure.size=inc[ii])
                seqQTN=which(mySpecify$index==TRUE)
                GK=t(GDP[seqQTN,])
                myBurger=FarmCPU.Burger(Y=Y[,1:2], CV=CV, GK=GK, ncpus=ncpus, method=method)
                myREML=myBurger$REMLs
                myVG=myBurger$vg #it is unused
                myVE=myBurger$ve #it is unused
                logging.log(c(bin,inc,myREML,myVG,myVE), "\n", verbose = verbose)
                return(list(seqQTN=seqQTN,myREML=myREML))
            }
            llresults <- lapply(1:m, seqQTN.optimize.parallel)

            for(i in 1:m){
                if(i == 1){
                    seqQTN.save = llresults[[i]]$seqQTN
                    myREML.save = llresults[[i]]$myREML
                }else{
                    if(llresults[[i]]$myREML < myREML.save){
                        seqQTN.save = llresults[[i]]$seqQTN
                        myREML.save = llresults[[i]]$myREML
                    }
                }
            }
        }

        return(list(seqQTN=seqQTN.save))
    }#The function FarmCPU.BIN ends here

#' To get indicator (TURE or FALSE) for GI based on GP
#'
#' Last update: January 26, 2017
#' Strategy
#' 1.set bins for all snps in GP
#' 2.keep the snp with smallest P value in each bin, record SNP ID
#' 3.Search GI for SNP with SNP ID from above
#' 4.return the position for SNP selected
#'
#' @author Zhiwu Zhang
#'
#' @param GI Data frame with three columns (SNP name, chr and base position)
#' @param GP Data frame with seven columns (SNP name, chr and base position, P, MAF, N, effect)
#' @param bin.size a value of @param b in 'FarmCPU.bin' function
#' @param inclosure.size a value of @param s in 'FarmCPU.bin' function
#' @param MaxBP maximum base pairs for each chromosome
#'
#' @return theIndex: a vector indicating if the SNPs in GI belong to QTN or not
FarmCPU.Specify <-
    function(GI=NULL, GP=NULL, bin.size=10000000, inclosure.size=NULL, MaxBP=1e10){
        #print("Specification in process...")
        if(is.null(GP))return (list(index=NULL,BP=NULL))

        #set inclosure bin in GP
        #Create SNP ID: position+CHR*MaxBP
        ID.GP=as.numeric(as.vector(GP[, 3]))+as.numeric(as.vector(GP[, 2]))*MaxBP

        #Creat bin ID
        bin.GP=floor(ID.GP/bin.size )

        #Create a table with bin ID, SNP ID and p value (set 2nd and 3rd NA temporately)
        binP=as.matrix(cbind(bin.GP,NA,NA,ID.GP,as.numeric(as.vector(GP[,4])))  )
        n=nrow(binP)

        #Sort the table by p value and then bin ID (e.g. sort p within bin ID)
        binP=binP[order(as.numeric(as.vector(binP[,5]))),]  #sort on P alue
        binP=binP[order(as.numeric(as.vector(binP[,1]))),]  #sort on bin

        #set indicator (use 2nd 3rd columns)
        binP[2:n,2]=binP[1:(n-1),1]
        binP[1,2]=0 #set the first
        binP[,3]= binP[, 1]-binP[, 2]

        #Se representives of bins
        ID.GP=binP[binP[, 3]>0,]

        #Choose the most influencial bins as estimated QTNs
        #Handler of single row
        if(is.null(dim(ID.GP))) ID.GP=matrix(ID.GP,1,length(ID.GP))
        ID.GP=ID.GP[order(as.numeric(as.vector(ID.GP[, 5]))),]  #sort on P alue

        #Handler of single row (again after reshape)
        if(is.null(dim(ID.GP))) ID.GP=matrix(ID.GP,1,length(ID.GP))

        index=!is.na(ID.GP[, 4])
        ID.GP=ID.GP[index,4] #must have chr and bp information, keep SNP ID only

        if(!is.null(inclosure.size)   ) {
            if(!any(is.na(inclosure.size))){
                avaiable=min(inclosure.size,length(ID.GP))
                if(avaiable==0){
                    ID.GP=-1
                }else{
                    ID.GP=ID.GP[1:avaiable] #keep the top ones selected
                }
            }
        }

        #create index in GI
        theIndex=NULL
        if(!is.null(GI)){
            ID.GI=as.numeric(as.vector(GI[, 3]))+as.numeric(as.vector(GI[, 2]))*MaxBP
            theIndex=ID.GI %in% ID.GP
        }

        myList=list(index=theIndex,CB=ID.GP)
        return (list(index=theIndex,CB=ID.GP))
    } #end of FarmCPU.Specify

#' To quickly sovel LM with one variable substitute multiple times
#'
#' Start  date: March 1, 2013
#' Last update: March 6, 2013
#' Strategy:
#' 1. Separate constant covariates (w) and dynamic coveriates (x)
#' 2. Build non-x related only once
#' 3. Use apply to iterate x
#' 4. Derive dominance indicate d from additive indicate (x) mathmaticaly
#' 5. When d is not estimable, continue to test x
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param y one column matrix, dependent variable
#' @param w covariates, n by c matrix, n is sample size, c is number of covariates
#' @param GDP genotype, m by n matrix, m is marker size, n is sample size. This is Pure Genotype Data Matrix(GD). THERE IS NO COLUMN FOR TAXA.
#' @param ncpus number of threads used for parallele computation
#' @param npc number of covariates without pseudo QTNs
#' @param verbose whether to print detail.
#'
#' @return
#' Output: P - p-value of each SNP
#' Output: betapred - effects of pseudo QTNs
#' Output: B - effect of each SNP
#'
#' @keywords internal
FarmCPU.LM <-
    function(y, w=NULL, GDP, ncpus=2, npc=0, verbose=TRUE){
        #print("FarmCPU.LM started")
        if(is.null(y)) return(NULL)
        if(is.null(GDP)) return(NULL)
        #Constant section (non individual marker specific)
        #---------------------------------------------------------
        #Configration
        nd=20 #number of markes for checking A and D dependency
        N=length(y) #Total number of taxa, including missing ones

        if(!is.null(w)){
            w=as.matrix(w,nrow = N)
            nf=ncol(w)
            w=cbind(rep(1,N),w)
            q0=ncol(w)
        }else{
            w=rep(1,N)
            nf=0
            q0=1
        }
        w = as.matrix(w)

        logging.log("number of covariates in current loop is:", "\n", verbose = verbose)
        logging.log(nf, "\n", verbose = verbose)

        n=N
        if(nd>n)nd=n #handler of samples less than nd
        k=1 #number of genetic effect: 1 and 2 for A and AD respectively

        q1=(q0+1) # vecter index for the posistion of genetic effect (a)
        q2=(q0+1):(q0+2) # vecter index for the posistion of genetic effect (a and d)
        df=n-q0-k #residual df (this should be varied based on validating d)

        iXX=matrix(0,q0+k,q0+k) #Reserve the maximum size of inverse of LHS

        # ww=crossprodcpp(w)
        ww = crossprod(w)

        wy = crossprod(w,y)
        # yy=crossprodcpp(y)
        yy = crossprod(y)
        wwi = ginv(ww)

        #Statistics on the reduced model without marker
        rhs=wy
        beta <- crossprod(wwi,rhs)
        ve <- (yy - crossprod(beta, rhs)) / df
        se <- sqrt(diag(wwi) * ve[1])

        if(npc!=0){
            betapc = beta[2:(npc+1)]
            betapred = beta[-c(1:(npc+1))]
            sepred = se[-c(1:(npc+1))]
        }else{
            betapc = NULL
            betapred = beta[-1]
            sepred = se[-1]
        }

        #print(ncpus)
        logging.log("scanning...", "\n", verbose = verbose)

        # P <- NULL
        # B <- NULL
        # S <- NULL

        # setMKLthreads(10)
        # for(i in 1:nrow(GDP)){
        #     xx <- summary(lm(y~cbind(w,GDP[i, ])))$coeff
        #     P <- rbind(P, xx[-1,4,drop=TRUE])
        #     B <- c(B, xx[nrow(xx), 1])
        #     S <- c(S, xx[nrow(xx), 2])
        # }
        # if(ncol(w) == 50)  write.csv(P, "P.csv")

        mkl_env({
            results <- glm_c(y=y, X=w, iXX = wwi, GDP@address, verbose=verbose, threads=ncpus)
        })
        return(list(P=results[ ,-c(1:3), drop=FALSE], betapred=betapred, sepred=sepred, B=results[ , 1, drop=FALSE], S=results[ , 2, drop=FALSE]))
        # return(list(P=P, betapred=betapred, B=as.matrix(B), S=S))
    } #end of FarmCPU.LM function

#' FarmCPU.Burger
#'
#' Last update: Dec 21, 2016
#' To calculate likelihood, variances and ratio, revised by Xiaolei based on GAPIT.Burger function from GAPIT package
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param Y phenotype, n by t matrix, n is sample size, t is number of phenotypes
#' @param CV covariates, n by c matrix, n is sample size, c is number of covariates
#' @param GK Genotype data in numerical format, taxa goes to row and snp go to columns
#' @param ncpus number of threads used for parallele computation
#' @param method two options for estimating variance components, 'FaST-LMM' or 'EMMA'
#'
#' @return
#' Output: REMLs - maximum log likelihood
#' Output: vg - genetic variance
#' Output: ve - residual variance
#' Output: delta - exp(root)
#'
#' @keywords internal
FarmCPU.Burger <-
    function(Y=NULL,CV=NULL,GK=NULL,ncpus=2, method="FaST-LMM"){
        if(!is.null(CV)){
            CV=as.matrix(CV)#change CV to a matrix when it is a vector
            theCV=as.matrix(cbind(matrix(1,nrow(CV),1),CV))
        }else{
            theCV=matrix(1,nrow(Y),1)
        }

        #handler of single column GK
        n=nrow(GK)
        m=ncol(GK)
		if(!is.null(GK)){
			n=nrow(GK)
			m=ncol(GK)
			if(m > 2){
				theGK = as.matrix(GK)#GK is pure genotype matrix
			}else if(m==0){
				theGK = NULL
			}else{
				theGK = matrix(GK,n,1)
			}
		}else{
			theGK=GK
		}
        if(method=="FaST-LMM"){
            myFaSTREML=FarmCPU.FaSTLMM.LL(pheno=matrix(Y[,-1],nrow(Y),1), snp.pool=theGK, X0=theCV, ncpus=ncpus)
            REMLs=-2*myFaSTREML$LL
            delta=myFaSTREML$delta
            vg=myFaSTREML$vg
            ve=myFaSTREML$ve
        }

        if(method=="EMMA"){
            K <- MVP.K.VanRaden(M=as.big.matrix(t(theGK)), priority="speed",verbose=FALSE)
            myEMMAREML <- MVP.EMMA.Vg.Ve(y=matrix(Y[,-1],nrow(Y),1), X=theCV, K=K)
            REMLs=-2*myEMMAREML$REML
            delta=myEMMAREML$delta
            vg=myEMMAREML$vg
            ve=myEMMAREML$ve
        }

        #print("FarmCPU.Burger succeed!")
        return (list(REMLs=REMLs, vg=vg, ve=ve, delta=delta))
    } #end of FarmCPU.Burger

#' FarmCPU.SUB
#'
#' Last update: Febuary 26, 2013
#' Requirement: P has row name of SNP. s<=t. covariates of QTNs are next to SNP
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param GM SNP map information, m by 3 matrix, m is marker size, the three columns are SNP_ID, Chr, and Pos
#' @param GLM FarmCPU.GLM object
#' @param QTN s by 3  matrix for SNP name, chromosome and BP
#' @param method options are "penalty", "reward","mean","median",and "onsite"
#'
#' @return
#' Output: GLM$P - Updated p-values by substitution process
#' Output: GLM$B - Updated effects by substitution process
FarmCPU.SUB <-
    function(GM=NULL,GLM=NULL,QTN=NULL,method="mean"){
        if(is.null(GLM$P)) return(NULL)  #P is required
        if(is.null(QTN)) return(NULL)  #QTN is required
        #print("FarmCPU.SUB Started")
        #print(length(QTN))
        #if(length(QTN)==3){
            #QTN=QTN[1]
        #}else{
        QTN=QTN[ , 1, drop=FALSE]
        #}
        position=match(QTN, GM[, 1, drop=FALSE], nomatch = 0)
        nqtn=length(position)
        if(is.numeric(GLM$P)){
            GLM$P = as.matrix(GLM$P)
        }
        GLM$B = as.matrix(GLM$B)
        index=(ncol(GLM$P)-nqtn):(ncol(GLM$P)-1)
        spot=ncol(GLM$P)

        if(ncol(GLM$P)!=1){
            if(length(index)>1){
                if(method=="penalty") P.QTN=apply(GLM$P[,index],2,max,na.rm=TRUE)
                if(method=="reward") P.QTN=apply(GLM$P[,index],2,min,na.rm=TRUE)
                if(method=="mean") P.QTN=apply(GLM$P[,index],2,mean,na.rm=TRUE)
                if(method=="median") P.QTN=apply(GLM$P[,index],2,median,na.rm=TRUE)
                if(method=="onsite") P.QTN=GLM$P0[(length(GLM$P0)-nqtn+1):length(GLM$P0)]
            }else{
                if(method=="penalty") P.QTN=max(GLM$P[,index, drop=FALSE],na.rm=TRUE)
                if(method=="reward") P.QTN=min(GLM$P[,index, drop=FALSE],na.rm=TRUE)
                if(method=="mean") P.QTN=mean(GLM$P[,index, drop=FALSE],na.rm=TRUE)
                if(method=="median") P.QTN=median(GLM$P[,index, drop=FALSE],median,na.rm=TRUE)
                if(method=="onsite") P.QTN=GLM$P0[(length(GLM$P0)-nqtn+1):length(GLM$P0)]
            }
            #replace SNP pvalues with QTN pvalue
            GLM$P[position, spot] = P.QTN
            GLM$B[position, ] = GLM$betapred
            GLM$S[position, ] = GLM$sepred
        }
        return(GLM)
    }#The function FarmCPU.SUB ends here

#' Remove bins that are highly correlated
#'
#' Last update: March 4, 2013
#' Requirement: GDP and GM have the same order on SNP
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param GDP genotype, m by n matrix, m is marker size, n is sample size. This is Pure Genotype Data Matrix(GD). THERE IS NO COLUMN FOR TAXA
#' @param GM SNP map information, m by 3 matrix, m is marker size, the three columns are SNP_ID, Chr, and Pos
#' @param seqQTN s by 1 vecter for index of QTN on GM
#' @param seqQTN.p p value of each @param seqQTN
#' @param threshold pearson correlation threshold for remove correlated markers
#'
#' @return
#' Output: bin - n by s0 matrix of genotype
#' Output: binmap - s0 by 3 matrix for map of bin
#' Output: seqQTN - s0 by 1 vecter for index of QTN on GM
#' Relationship: bin=GDP[,c(seqQTN)], binmap=GM[seqQTN,], s0<=s
#' @keywords internal
FarmCPU.Remove <-
    function(GDP=NULL, GM=NULL, seqQTN=NULL, seqQTN.p=NULL, threshold=.99){
        if(is.null(seqQTN))return(list(bin=NULL,binmap=NULL,seqQTN=NULL))
        seqQTN=seqQTN[order(seqQTN.p)]

        hugeNum=10e10
        n=length(seqQTN)
        #fielter bins by physical location

        binmap=GM[seqQTN, , drop=FALSE]

        cb=as.numeric(binmap[, 2, drop=FALSE])*hugeNum+as.numeric(binmap[, 3, drop=FALSE])#create ID for chromosome and bp
        cb.unique=unique(cb)

        #print("debuge")
        #print(cb)
        #print(cb.unique)

        index=match(cb.unique,cb,nomatch = 0)
        seqQTN=seqQTN[index]

        #print("Number of bins after chr and bp fillter")
        n=length(seqQTN) #update n

        #Set sample
        ratio=.1
        maxNum=100000
        m=nrow(GDP) #sample size
        s=ncol(GDP) #number of markers

        sampled=s
        if(sampled>maxNum)sampled=maxNum

        #index=sample(s,sampled)
        index=1:sampled

        #This section has problem of turning big.matrix to R matrix
        #It is OK as x is small
        if(is.big.matrix(GDP)){
            x=t(as.matrix(deepcopy(GDP,rows=seqQTN,cols=index) ))
        }else{
            x=t(GDP[seqQTN,index] )
        }

        r=cor(as.matrix(x))
        index=abs(r)>threshold

        b=r*0
        b[index]=1
        c=1-b

        #The above are replaced by following
        c[lower.tri(c)]=1
        diag(c)=1
        bd <- apply(c,2,prod)

        position=(bd==1)
        seqQTN=seqQTN[position]
        #============================end of optimum============================================
        seqQTN=seqQTN[!is.na(seqQTN)]

        #This section has problem of turning big.matrix to R matrix
        if(is.big.matrix(GDP)){
            bin=t(as.matrix(deepcopy(GDP,rows=seqQTN,) ))
        }else{
            bin=t(GDP[seqQTN, , drop=FALSE] )
        }

        binmap=GM[seqQTN, , drop=FALSE]

        return(list(bin=bin, binmap=binmap, seqQTN=seqQTN))
    }#The function FarmCPU.Remove ends here

#' Set prior on existing p value
#'
#' Last update: March 10, 2013
#' Requirement: P and GM are in the same order, Prior is part of GM except P value
#'
#' @author Xiaolei Liu and Zhiwu Zhang
#'
#' @param GM an m by 3  matrix for SNP name, chromosome and BP
#' @param P an m by 1 matrix containing probability
#' @param Prior an s by 4  matrix for SNP name, chromosome, BP and p-value
#'
#' @return
#' Output: P - updated P value by prior information
#'
#' @keywords internal
FarmCPU.Prior <-
    function(GM, P=NULL, Prior=NULL){
        #print("FarmCPU.Prior Started")

        if(is.null(Prior)& is.null(P))return(P)

        #get prior position
        if(!is.null(Prior)) index=match(Prior[, 1, drop=FALSE],GM[, 1, drop=FALSE],nomatch = 0)

        #if(is.null(P)) P=runif(nrow(GM)) #set random p value if not provided (This is not helpful)
        #print("debug set prior  a")

        #Get product with prior if provided
        if(!is.null(Prior) & !is.null(P) )P[index]=P[index]*Prior[, 4, drop=FALSE]

        return(P)
    }#The function FarmCPU.Prior ends here


temperature_map = function( p=NULL, DS="all", yr=NULL, do.seasonal=FALSE ) {

  if (is.null(yr)) yr = p$yrs

  loc =  bathymetry_db( p=bathymetry_parameters( spatial_domain=p$spatial_domain, project_class="stmv"  ), DS="baseline")

  if ( DS=="all" ) {
    # run everything below
    p$yrs = yr # in case yr was specified
    allgrids = unique(c( p$spatial_domain_subareas, p$spatial_domain) )
    for ( gr in allgrids ) {
      print (gr)
      p1 = spatial_parameters(  p=p, spatial_domain=gr )
      temperature_map( p=p1, DS="stmv.stats" ) # no parallel option .. just a few
      temperature_map( p=p1, DS="climatology" ) # no parallel option .. just a few
      if (do.seasonal) temperature_map( p=p1, DS="seasonal" ) # all seasonal predicted means
      temperature_map( p=p1, DS="annual" ) # bottom.statistics.annual
    }
  }

  # -----------------------

  if ( DS=="seasonal" ) {

    if (exists( "libs", p)) RLibrary( p$libs )

    bottomdir.maps = project.datadirectory("aegis", "temperature", "maps", p$spatial_domain, "bottom.predictions", "seasonal" )
    dir.create( bottomdir.maps, recursive=T, showWarnings=F )

    datarange = seq(-1, 12, length.out=100)
    cols = color.code( "blue.black", datarange )
    annot.cex=2

    for ( y in yr ) {
      H = temperature_db( p=p, DS="predictions", yr=y, ret="mean"  )
      if (is.null(H)) next ()
      for (w in 1:p$nw ) {
        wchar = paste( "0", w, sep="" )
        wchar = substr( wchar, nchar(wchar)-1, nchar(wchar) )
        outfn = paste( "temperatures.bottom", y, wchar, sep=".")
        annot = paste("Temperature\n", y, " - ", w, sep="")
        dir.create (bottomdir.maps, showWarnings=FALSE, recursive =TRUE)
        fn = file.path( bottomdir.maps, paste(outfn, "png", sep="." ) )
        png( filename=fn, width=3072, height=2304, pointsize=40, res=300 )
        lp = aegis_map( xyz=cbind(loc, H[,w]), depthcontours=TRUE, pts=NULL,
          annot=annot, annot.cex=annot.cex,
          at=datarange, col.regions=cols, corners=p$corners, spatial_domain=p$spatial_domain )
        print(lp)
        dev.off()
      }
    }
    return( "Completed maps")
  }

  # ---------------------------

  if ( DS %in% c("annual" ) ) {

    if (exists( "libs", p)) RLibrary( p$libs )
    bottomdir.maps = project.datadirectory( "aegis", "temperature", "maps", p$spatial_domain, "bottom.predictions", "annual" )
    dir.create( bottomdir.maps, recursive=T, showWarnings=F )

    annot.cex=3

    for ( vname in p$bstats ) {
      H = temperature_db( p=p, DS="bottom.statistics.annual", ret=vname )
      if (is.null(H)) next ()

      for ( iy in 1:length(yr) ) {
        y = yr[iy]

        if (vname %in% c("tmean") ) {
          datarange = seq(-0.5, 10, length.out=100)
          cols = color.code( "blue.black", datarange )
          outfn = paste( "temperatures.bottom", y, sep=".")
          annot = y
        }

        if (vname %in% c("tsd") ) {
          datarange = seq(0.001, 2, length.out=100)
          cols = color.code( "blue.black", datarange )
          outfn = paste( "temperatures.bottom.sd", y, sep=".")
          annot = y
        }

        if (vname %in% c("tmin") ) {
          datarange = seq(-0.5, 10, length.out=100)
          cols = color.code( "blue.black", datarange )
          outfn = paste( "temperatures.bottom.min", y, sep=".")
          annot = y
        }

        if (vname %in% c("tmax") ) {
          datarange = seq(-0.5, 10, length.out=100)
          cols = color.code( "blue.black", datarange )
          outfn = paste( "temperatures.bottom.max", y, sep=".")
          annot = y
        }

        if (vname %in% c("tamplitude") ) {
          datarange = seq(0, 10, length.out=100)
          cols = color.code( "blue.black", datarange )
          outfn = paste( "temperatures.bottom.amplitude", y, sep=".")
          annot = y
        }

        if (vname %in% c("degreedays") ) {
          datarange = seq(-400, 6000, length.out=100)
          cols = color.code( "blue.black", datarange )
          outfn = paste( "temperatures.bottom.degreedays", y, sep=".")
          annot = y
        }

        dir.create (bottomdir.maps, showWarnings=FALSE, recursive =TRUE)
        fn = file.path( bottomdir.maps, paste(outfn, "png", sep="." ) )
        png( filename=fn, width=3072, height=2304, pointsize=40, res=300 )
        lp = aegis_map( xyz=cbind(loc, H[,iy]), depthcontours=TRUE, pts=NULL,
          annot=annot, annot.cex=annot.cex,
          at=datarange ,col.regions=cols, corners=p$corners, spatial_domain=p$spatial_domain )
        print(lp)
        dev.off()
        print(fn)
      }
    }
    return( "Completed maps")
  }

  # ------------------------------

  if ( DS %in% c("climatology" ) ) {

    if (exists( "libs", p)) RLibrary( p$libs )

    bottomdir.maps = file.path( project.datadirectory("aegis", "temperature"), "maps", p$spatial_domain, "bottom.predictions", "climatology" )
    dir.create( bottomdir.maps, recursive=T, showWarnings=F )
    H = temperature_db( p=p, DS="bottom.statistics.climatology" )

    annot.cex=0.9

    for (vname in p$bstats) {

      if (vname %in% c("tmean") ) {
        # datacols = c("plon", "plat", "tmean")
        datarange = seq(-0.5, 10, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "temperatures.bottom", sep=".")
        annot = paste("Temperature bottom climatology\n", sep="")
      }

      if (vname %in% c("tsd") ) {
        # datacols = c("plon", "plat", "tmean")
        datarange = seq(0.001, 2, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "temperatures.bottom.sd", sep=".")
        annot = paste("Temperature bottom SD climatology\n", sep="")
      }

      if (vname %in% c("tmin") ) {
        datarange = seq(-0.5, 10, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "temperatures.bottom.min", sep=".")
        annot = paste("Temperature bottom minimum climatology\n",  sep="")
      }

      if (vname %in% c("tmax") ) {
        datarange = seq(-0.5, 10, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "temperatures.bottom.max", sep=".")
        annot = paste("Temperature bottom maximum climatology\n",  sep="")
     }

      if (vname %in% c("tamplitude") ) {
        datarange = seq(0, 10, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "temperatures.bottom.amplitude", sep=".")
        annot = paste("Temperature bottom amplitude climatology\n",  sep="")
      }

      fn = file.path( bottomdir.maps, paste(outfn, "png", sep="." ) )
      png( filename=fn, width=3072, height=2304, pointsize=40, res=300 )
      lp = aegis_map( xyz=cbind(loc, H[,which( p$bstats==vname)]), depthcontours=TRUE, pts=NULL, annot=annot, annot.cex=annot.cex,
        at=datarange , col.regions=cols,
        corners=p$corners, spatial_domain=p$spatial_domain )
      print(lp)
      dev.off()

    }

  }

  # ------------------------------

  if ( DS %in% c("stmv.stats" ) ) {

    if (exists( "libs", p)) RLibrary( p$libs )

    H = temperature_db( p=p, DS="stmv.stats" )
    namesH = colnames(H)

    bottomdir.maps = file.path( project.datadirectory("aegis", "temperature"), "maps", p$spatial_domain, "bottom.predictions", "stmv.stats" )
    dir.create( bottomdir.maps, recursive=T, showWarnings=F )

    annot.cex=0.9

    for (vname in namesH) {

      if (vname %in% c("sdTotal") ) {
        datarange = seq(0.01, 5, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "sdTotal", sep=".")
        annot = paste("Temperature bottom sdTotal\n", sep="")
        xyz=cbind(loc, H[,vname])
      }

      if (vname %in% c("rsquared") ) {
        datarange = seq(0.1, 0.99, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "rsquared", sep=".")
        annot = paste("Temperature bottom rsquared\n", sep="")
        xyz=cbind(loc, H[,vname])
      }

      if (vname %in% c("ndata") ) {
        datarange = seq(5, 8000, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "ndata", sep=".")
        annot = paste("Temperature bottom ndata\n",  sep="")
        xyz=cbind(loc, H[,vname])
      }

      if (vname %in% c("sdSpatial") ) {
        datarange = seq(0.01, 5, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "sdSpatial", sep=".")
        annot = paste("Temperature bottom sdSpatial\n",  sep="")
        xyz=cbind(loc, H[,vname])
     }

      if (vname %in% c("sdObs") ) {
        datarange = seq(0.01, 5, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "sdObs", sep=".")
        annot = paste("Temperature bottom sdObs\n",  sep="")
        xyz=cbind(loc, (H[,vname]))
      }

      if (vname %in% c("localrange") ) {
        datarange = seq( log(0.5), log(median(p$stmv_distance_scale)*3), length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "localrange", sep=".")
        annot = paste("Temperature bottom local range\n",  sep="")
        xyz=cbind(loc, log(H[,vname]))
        xyz = xyz[which( is.finite(rowSums(xyz))),]
      }

      if (vname %in% c("phi") ) {
        datarange = seq(log(0.15), log(median(p$stmv_distance_scale)*2), length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "phi", sep=".")
        annot = paste("Temperature bottom phi\n",  sep="")
        xyz=cbind(loc, log(H[,vname]))
        xyz = xyz[which( is.finite(rowSums(xyz))),]
      }

      if (vname %in% c("nu") ) {
        datarange = seq(0.1, 4, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "nu", sep=".")
        annot = paste("Temperature bottom nu\n",  sep="")
        xyz=cbind(loc, (H[,vname]))
      }

      if (vname %in% c("ar_timerange") ) {
        datarange = seq(0, 6, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "ar_timerange", sep=".")
        annot = paste("Temperature bottom ar_timerange\n",  sep="")
        xyz=cbind(loc, (H[,vname]))
      }

      if (vname %in% c("ar_1") ) {
        datarange = seq(0, 1, length.out=100)
        cols = color.code( "blue.black", datarange )
        outfn = paste( "ar_1", sep=".")
        annot = paste("Temperature bottom ar_1\n",  sep="")
        xyz=cbind(loc, H[,vname])
      }

      dir.create (bottomdir.maps, showWarnings=FALSE, recursive =TRUE)
      fn = file.path( bottomdir.maps, paste(outfn, "png", sep="." ) )
      png( filename=fn, width=3072, height=2304, pointsize=40, res=300 )
      lp = aegis_map( xyz=xyz, depthcontours=TRUE, pts=NULL,
        annot=annot, annot.cex=annot.cex,
        at=datarange, col.regions=cols,
        corners=p$corners, spatial_domain=p$spatial_domain )
      print(lp)
      dev.off()
    }
    return (NULL)
  }

}


#' ngram Babbler
#'
#' A markov chain babbler.
#'
#' @description
#' The babbler uses its own internal PRNG (i.e., not R's), so seeds cannot be
#' managed as with R's seeds.  The generator is an implementation of MT19937.
#'
#' At this time, we note that the seed may not guarantee the same results
#' across machines. Currently only Solaris produces different values from
#' mainstream platforms (Windows, Mac, Linux, FreeBSD), but potentially others
#' could as well.
#'
#' @param ng
#' An ngram object.
#' @param genlen
#' Generated length, i.e., the number of words to babble.
#' @param seed
#' Seed for the random number generator.
#'
#'
#' @examples
#' library(ngram)
#'
#' str = "A B A C A B B"
#' ng = ngram(str)
#' babble(ng, genlen=5, seed=1234)
#'
#' @useDynLib ngram R_ngram_gen
#' @seealso \code{\link{ngram}}, \code{\link{getseed}}
#' @keywords Amusement
#' @name babble
#' @rdname babble
NULL

#' @rdname babble
#' @export
setGeneric(name="babble",
  function(ng, genlen=150, seed=getseed())
    standardGeneric("babble"),
  package="ngram"
)

#' @rdname babble
#' @export
setMethod("babble", signature(ng="ngram"),
  function(ng, genlen=150, seed=getseed())
  {
    check.is.natnum(genlen)
    check.is.int(seed)

    if (genlen >= 2^31)
      stop(paste("genlen=", genlen, " is too large", sep=""))

    genlen = as.integer(genlen)

    if (ng@n > genlen)
      warning("n > genlen; selecting a random n-gram instead")

    seed = as.integer(seed)

    .Call(R_ngram_gen, ng@ngl_ptr, genlen, seed)
  }
)


#source("https://bioconductor.org/biocLite.R")
#biocLite("GO.db")
library("GO.db")
library("reshape2")
library("data.table")
library("scales")
library("ggplot2")

#in_file = pred_file
#Read data into R
plot_cats <- function(in_file,ont_plot,gene_plot) {
    #print(in_file)
    #print(ont_plot)
    #print(gene_plot)
    data <-
        read.table(
            in_file,as.is = T,sep = "\t",quote = "",header = T
        )

    if(dim(data)[1]>2){
        data <- data[,1:2]
    }
    colnames(data) <- c("gene_id","go_id")

    #Figure out the Gene ontology
    ont_list <- Ontology(as.character(data$go_id))
    #ont_list <- unlist(lapply(data$go_id,function(x) {
    #    c(Ontology(x))
    #}))

    data_filt <- data[!is.na(ont_list),]
    ont_list <- ont_list[!is.na(ont_list)]
    data_dt <- data.table(cbind(data_filt,ont = ont_list))
    data_dt

    plot_dt <-
        data_dt[,list(
            annotations = .N,genes = length(unique(gene_id)),go_terms = length(unique(go_id))
        ),by = ont]
    plot_data <- melt(plot_dt,"ont")
    plot_data[plot_data$variable!="annotations"]

    #Plot simple bar graph
    svg(
        ont_plot,width = 4,height = 2.8
    )
    p <- ggplot(data_dt,aes(x = ont,fill = ont))
    p <- p +  geom_bar(stat = "count")
    p <- p + scale_y_continuous(labels = comma)
    #p <- p + coord_polar(theta="y",start=0)
    #p <- p + scale_y_continuous(breaks=ont_pie$breaks,labels=ont_pie$label) + scale_fill_brewer(type = "qual",palette = 1)
    #p <- p + theme(axis.text.x=element_text(size = 6,angle=30),panel.background=element_rect(fill = "#FFFFFF"))
    p <-
        p + geom_text(stat = "count",aes(label = ..count..,y = (..count..*0 + 100),vjust=0),size = 4)
    p <- p + labs(title = "",x = "",y = "# of Unique Annotations")
    p <- p + scale_fill_discrete(guide=guide_legend(title="Ontology"))
    print(p)
    dev.off()

    #Plot simple bar graph
    svg(
        gene_plot,width = 4,height = 2.8
    )
    p <- ggplot(plot_data[plot_data$variable!="annotations"],aes(ont,value,fill = variable))
    p <- p +  geom_bar(stat="identity",position="dodge")
    #p <- p + scale_y_discrete(labels = comma)
    #p <- p + coord_polar(theta="y",start=0)
    #p <- p + scale_y_continuous(breaks=ont_pie$breaks,labels=ont_pie$label) + scale_fill_brewer(type = "qual",palette = 1)
    #p <- p + theme(axis.text.x=element_text(size = 6,angle=30),panel.background=element_rect(fill = "#FFFFFF"))
    p <- p + geom_text(aes(label=value,y=value+250),position=position_dodge(width=1),size = 2)
    #p <- p + facet_grid(.~ont)
    p <- p + labs(title = "",x = "Ontology",y = "Count")
    #p <- p + theme(axis.text.x=element_text(angle=45,vjust = 1,hjust = 0))
    p <- p + theme_linedraw()
    p <- p + scale_fill_discrete(guide=guide_legend(title=NULL),labels=c("Genes","GO Terms"))
    p
    print(p)
    dev.off()
}


install.packages("RcppCCTZ") #for parseDatetime
install.packages("ggplot2")
install.packages("spatstat")
install.packages("RColorBrewer")
library(RcppCCTZ)
library(ggplot2)
library(spatstat)
library(RColorBrewer)

setwd("~/Schreibtisch/hacktrain/git/stay-safe/timeTable/")

dataPlatform <- read.csv('../heatmap-creation/data.csv', header = F)
dataTrains <- read.csv('../train-filling/timeTable.csv', header = F)

timeTag <- dataPlatform$V2
length(timeTag)
limitCount <- 200

ACrowded <- FALSE
BCrowded <- (dataPlatform$V3 > limitCount)
CCrowded <- (dataPlatform$V4 > limitCount | dataPlatform$V5 > limitCount)
DCrowded <- (dataPlatform$V6 > limitCount | dataPlatform$V7 > limitCount)
ECrowded <- (dataPlatform$V8 > limitCount | dataPlatform$V8 == "NA")
FCrowded <- FALSE

ECrowded[21] <- FALSE
for (k in 1:length(BCrowded)) {
  if (is.na(BCrowded[k])) {
    BCrowded[k] <- FALSE
  }
}
BCrowded

timePoint <- 1
for (currentHour in 8:8) {
  for (currentMinute in 0:59) {
    currentTime <- paste(toString(currentHour), ":", toString(currentMinute), sep="")
    toString(currentHour)
    if (currentHour < 10) {
      currentTime <- paste("0", toString(currentHour), ":", toString(currentMinute), sep="")
      if (currentMinute < 10) {
        currentTime <- paste("0", toString(currentHour), ":0", toString(currentMinute), sep="")
      }
    }

S3 <- NULL
S3$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 3, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S3$waitingTime <- ttw[1]
S3$platform <- ttw[3]
S3$sector <- 0
if (as.integer(S3$platform) == 2 | as.integer(S3$platform) == 3) S3$sector <- ttw[2]
write.table(S3, file = "displayS3.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S5 <- NULL
S5$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 5, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S5$waitingTime <- ttw[1]
S5$platform <- ttw[3]
S5$sector <- 0
if (as.integer(S5$platform) == 2 | as.integer(S5$platform) == 3) S5$sector <- ttw[2]
write.table(S5, file = "displayS5.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S6 <- NULL
S6$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 6, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S6$waitingTime <- ttw[1]
S6$platform <- ttw[3]
S6$sector <- 0
if (as.integer(S6$platform) == 2 | as.integer(S6$platform) == 3) S6$sector <- ttw[2]
write.table(S6, file = "displayS6.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S7 <- NULL
S7$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 7, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S7$waitingTime <- ttw[1]
S7$platform <- ttw[3]
S7$sector <- 0
if (as.integer(S7$platform) == 2 | as.integer(S7$platform) == 3) S7$sector <- ttw[2]
write.table(S7, file = "displayS7.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S9 <- NULL
S9$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 9, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S9$waitingTime <- ttw[1]
S9$platform <- ttw[3]
S9$sector <- 0
if (as.integer(S9$platform) == 2 | as.integer(S9$platform) == 3) S9$sector <- ttw[2]
write.table(S9, file = "displayS9.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S11 <- NULL
S11$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 11, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S11$waitingTime <- ttw[1]
S11$platform <- ttw[3]
S11$sector <- 0
if (as.integer(S11$platform) == 2 | as.integer(S11$platform) == 3) S11$sector <- ttw[2]
write.table(S11, file = "displayS11.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S12 <- NULL
S12$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 12, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S12$waitingTime <- ttw[1]
S12$platform <- ttw[3]
S12$sector <- 0
if (as.integer(S12$platform) == 2 | as.integer(S12$platform) == 3) S12$sector <- ttw[2]
write.table(S12, file = "displayS12.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S15 <- NULL
S15$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 15, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S15$waitingTime <- ttw[1]
S15$platform <- ttw[3]
S15$sector <- 0
if (as.integer(S15$platform) == 2 | as.integer(S15$platform) == 3) S15$sector <- ttw[2]
write.table(S15, file = "displayS15.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S16 <- NULL
S16$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 16, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S16$waitingTime <- ttw[1]
S16$platform <- ttw[3]
S16$sector <- 0
if (as.integer(S16$platform) == 2 | as.integer(S16$platform) == 3) S16$sector <- ttw[2]
write.table(S16, file = "displayS16.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

S21 <- NULL
S21$timeStamp <- currentTime
ttw <- timeToWait(currentHour, currentMinute, 21, ACrowded, BCrowded[timePoint], CCrowded[timePoint], DCrowded[timePoint], ECrowded[timePoint], FCrowded)
S21$waitingTime <- ttw[1]
S21$platform <- ttw[3]
S21$sector <- 0
if (as.integer(S21$platform) == 2 | as.integer(S21$platform) == 3) S21$sector <- ttw[2]
write.table(S21, file = "displayS21.csv", sep = ",", quote = FALSE, append = TRUE, col.names = FALSE)

timePoint <- timePoint + 1
}
}

timeToWait <- function(hour, minute, line, aC, bC, cC, dC, eC, fC) {
  stringLine <- toString(line)
  depTime <- 0
  hoursToWait <- 0
  minutesToWait <- 0
  #print(length(dataTrains$V1))
    for (i in 1:length(dataTrains$V1)) {
      #print(i)
      #print(dataTrains$V3)
      if (grepl(stringLine, dataTrains$V3[i], fixed=TRUE) == TRUE) {
        depTime <- substring(dataTrains$V2[i], 12, 16)
        #print(i)
        if (hour < as.integer(substr(dataTrains$V2[i], 12, 13))) {
          hoursToWait <- as.integer(substr(dataTrains$V2[i], 12, 13)) - hour
          minutesToWait <- as.integer(substr(dataTrains$V2[i], 15, 16)) - minute + hoursToWait*60
          break
        }
        if (hour == as.integer(substr(dataTrains$V2[i], 12, 13))) {
          if (minute < as.integer(substr(dataTrains$V2[i], 15, 16))) {
            minutesToWait <- as.integer(substr(dataTrains$V2[i], 15, 16)) - minute
            break
          }
        }
        if (as.integer(substr(dataTrains$V2[i], 12, 13)) == 0) {
          minutesToWait <- 60 - minute + as.integer(substr(dataTrains$V2[i], 15, 16))
          break
        }
    }
    }
  minVal <- 10000
  minInd <- 0
    if (dataTrains$V4[i] < minVal & !aC) {
      minInd <- 1
      minVal <- dataTrains$V4[i]
    }
    if (dataTrains$V5[i] < minVal & !bC) {
      minInd <- 2
      minVal <- dataTrains$V5[i]
    }
    if (dataTrains$V6[i] < minVal & !cC) {
      minInd <- 3
      minVal <- dataTrains$V6[i]
    }
    if (dataTrains$V7[i] < minVal & !dC) {
      minInd <- 4
      minVal <- dataTrains$V7[i]
    }
    if (dataTrains$V8[i] < minVal & !eC) {
      minInd <- 5
      minVal <- dataTrains$V8[i]
    }
    if (dataTrains$V9[i] < minVal & !fC) {
      minInd <- 6
      minVal <- dataTrains$V9[i]
    }
return(list(minutesToWait, minInd, dataTrains$V10[i]))
}

timeToWait(7, 59, 3, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE)