####################################### FUNCOES PARA LEITURA #######################################

#' Le Planilha de Curva Colina
#'
#' Funcoes para leitura de arquivos xlsx e extracao da curva colina em formato padronizado
#'
#' \code{learqcolina} deve ser utilizada para leitura de arquivos especificos de curva colina, nos
#' quais existe apenas uma aba contendo a informacao das curvas. \code{learqprocit} e especifica
#' para uso com planilhas de processo iterativo, nas quais pode haver mais de uma curva colina.
#'
#' Para \code{learqcolina}, \code{g} e \code{rho} permitem que sejam passados por fora a densidade e
#' gravidade no local. \code{learqprocit} ja busca esses valores por padrao na planilha de processo
#' iterativo, nao sendo necessario passa-los.
#'
#' @param arq caminho da planilha
#' @param aba aba a ser lida. Por padrao igual a \code{1}, geralmente nao deve ser informado pelo
#'     usuario
#' @param g,rho parametros opcionais contendo gravidade e densidade da agua no local. Ver Detalhes
#'
#' @examples
#'
#' # arquivo de colina simples
#' arq <- system.file(package = "curvacolina", "extdata/colina.xlsx")
#' colina <- learqcolina(arq)
#'
#' \dontrun{
#' plot(colina)
#' }
#'
#' @return objetos \code{curvacolina}: lista de um elemento \code{data.table} contendo as colunas
#'
#' \describe{
#' \item{\code{hl}}{queda liquida}
#' \item{\code{pot}}{potencia gerada}
#' \item{\code{vaz}}{vazao turbinada}
#' \item{\code{rend}}{rendimento correspondente}
#' }
#'
#' Adicionalmente tem os atributos:
#'
#' \describe{
#' \item{\code{ncurvas}}{numero de curvas na colina}
#' \item{\code{rends}}{vetor de rendimentos contidos na curva colina}
#' \item{\code{max}}{rendimento no "olho" da colina}
#' \item{\code{rho}}{densidade da agua associada}
#' \item{\code{g}}{gravidade associada}
#' }
#'
#' \code{leaqrcolina} retorna apenas um objeto, enquanto \code{learqprocit} retornara uma lista de
#' tantos elementos quanto abas de curva colina existem na planilha \code{arq}
#'
#' @rdname leexcel
#'
#' @family curvacolina
#'
#' @export

learqcolina <- function(arq, aba = 1, g, rho) {

    plan <- as.data.frame(readxl::read_xlsx(arq, aba, col_names = FALSE, .name_repair = "minimal"))

    if(nrow(plan) == 0) return(NULL)

    ncurvas <- (ncol(plan) + 1) / 3
    curvas  <- lapply(seq(ncurvas), function(i) {
        col1 <- 1 + (i - 1) * 3
        col2 <- col1 + 1

        rend <- plan[1, col1]
        rend <- regmatches(rend, regexpr("[[:digit:]]+(\\.[[:digit:]]+)?", rend))
        rend <- as.numeric(rend)

        curva <- plan[, col1:col2]
        curva <- curva[complete.cases(curva), ]
        curva[] <- lapply(curva, as.numeric)
        colnames(curva) <- c("hl", "pot")

        cbind(rend = rend, curva)
    })
    curvas <- do.call(rbind, curvas)

    new_curvacolina(curvas, g, rho)
}

#' @rdname leexcel
#'
#' @export

learqprocit <- function(arq) {

    hl <- pot <- vaz <- rend <- NULL

    abas <- readxl::excel_sheets(arq)
    abas_colina   <- abas[grep("Colina", abas)]
    abas_abertura <- abas[grep("Abertura", abas)]

    alterada <- grepl("Alterada", abas_colina)
    if(any(alterada)) abas_colina <- abas_colina[alterada]

    rho_g <- lapply(abas_abertura, function(a) {
        plan <- as.data.table(readxl::read_xlsx(arq, a, col_names = FALSE, .name_repair = "minimal"))
        plan <- as.numeric(plan[14:18, 7][[1]])
        if(all(is.na(plan[4:5]))) return(plan[1:2]) else return(plan[4:5])
    })

    colinas <- mapply(abas_colina, rho_g, FUN = function(a, r_g) {
        learqcolina(arq, a, r_g[1], r_g[2])
    }, SIMPLIFY = FALSE)

    # pode ser que alguma planilha tenha sido montada errado, com abas 'Alterada' vazias
    # nesse caso refaz a leitura das abas 'Original' mesmo, emitindo um aviso
    all_null <- all(sapply(colinas, is.null))
    if(all_null) {
        abas_colina <- abas[grepl("Colina Original", abas)]
        colinas <- mapply(abas_colina, rho_g, FUN = function(a, r_g) {
            learqcolina(arq, a, r_g[1], r_g[2])
        }, SIMPLIFY = FALSE)

        warning("Abas 'Alterada' em '", arq, "' foram encontradas vazias -- leitura realizada das 'Original'")
    }

    colinas <- colinas[!sapply(colinas, is.null)]

    if(length(colinas) > 1) names(colinas) <- paste0("colina_", seq(abas_colina)) else colinas <- colinas[[1]]

    return(colinas)
}

#' @import data.table

new_curvacolina <- function(curvas, g, rho) {

    hl <- pot <- vaz <- rend <- NULL

    if(missing(rho)) rho <- NA
    if(missing(g)) g <- NA

    setDT(curvas)

    rends <- curvas[, unique(rend)]

    curvas[, vaz := pot / (hl * rend / 100 * rho * g) * 1e6]
    setcolorder(curvas, c("hl", "pot", "vaz", "rend"))

    colina <- list(CC = curvas)

    temmax <- colina$CC[rend == max(rend), .N == 1]

    class(colina) <- c("curvacolina")
    attr(colina, "rends") <- rends
    attr(colina, "max") <- ifelse(temmax, colina$CC[which.max(rend), rend], NA)
    attr(colina, "ncurvas") <- length(rends)
    attr(colina, "rho") <- rho
    attr(colina, "g")   <- g

    return(colina)
}

# METODOS ------------------------------------------------------------------------------------------

#' @export

print.curvacolina <- function(x, ...) summary(x)

#' Sumario De \code{curvacolina}
#'
#' Produz um breve sumario da curva colina
#'
#' @param object objeto \code{curvacolina}
#' @param ... existe somente para consistencia de metodos. Nao possui utilidade
#'
#' @return imprime um sumario da curva colina, sem retornar nada
#'
#' @family curvacolina
#'
#' @import data.table
#'
#' @export

summary.curvacolina <- function(object, ...) {
    hl <- pot <- rend <- NULL
    cat("Numero de curvas:     ", attr(object, "ncurvas"), "\n")
    cat("Faixa de queda:       ", object$CC[, range(hl)], "\n")
    cat("Faixa de potencia:    ", object$CC[, range(pot)], "\n")
    cat("Faixa de rendimentos: ", range(attr(object, "rends")), "\n")
}

#' @export

`[.curvacolina` <- function(x, i, ...) {

    i <- substitute(i)
    i <- eval(i, envir = x$CC, enclos = parent.frame())
    CC <- x$CC[i]

    new_curvacolina(CC, attr(x, "g"), attr(x, "rho"))
}

#' @export

rbind.curvacolina <- function(...) {

    colinas <- list(...)

    comb <- lapply(colinas, "[[", "CC")
    comb <- rbindlist(comb)
    comb <- comb[!duplicated(comb)] # a curva associada a quebra existe nas duas colinas

    new_curvacolina(comb, attr(colinas[[1]], "g"), attr(colinas[[1]], "rho"))
}

#' Escrita De \code{curvacolina}
#'
#' Metodo para facilitacao de escrita de \code{curvacolina} lida pelas funcoes do pacote
#'
#' @param x objeto \code{curvacolina} a ser escrito
#' @param file caminho para escrita. Deve possuir extensao -- caso nao possua, sera adicionada
#'
#' @return Escreve \code{x} no caminho especificado como um csv de quatro colunas
#'
#' @family curvacolina
#'
#' @import data.table
#'
#' @export

write.curvacolina <- function(x, file) fwrite(x$CC, file, quote = FALSE, sep = ";")

# HELPERS ------------------------------------------------------------------------------------------

#' Parser De Dados Para \code{as.curvacolina}
#'
#' Funcao interna, nao deve ser chamada pelo usuario
#'
#' Esta funcao executa todos os checks e coercoes necessarias para execucao da transformacao
#' \code{as.curvacolina}
#'
#' @param x \code{data.frame}-like a ser convertido
#' @param force booleano indicando se o objeto deve ser forcado ao formato padrao. Pode gerar
#'     resultados inconsistentes. Ver Detalhes
#'
#' @return dado parsed para transformacao

parsedadocolina <- function(x, force) {

    if(!("data.frame" %in% class(x))) stop("Argumento deve ser um data.frame ou data.table")

    x <- as.data.frame(x)

    cols <- c("hl", "pot", "rend")

    ncolsx <- ncol(x)
    temcolnames <- all(cols %in% colnames(x))

    if(force) {
        if(!temcolnames) {
            if(ncolsx >= 3) {
                x <- x[, 1:3]
                warning("'x' nao possui todas as colunas 'hl', 'pot' e 'rend' -- tomando as tres primeiras")
                colnames(x) <- cols
            } else if(ncolsx < 3) {
                stop("'x' possui menos de tres colunas -- abortando operacao")
            }
        } else {
            x <- x[, cols]
        }

        classes <- lapply(x, class)
        numerica <- sapply(classes, function(x) (x == "numeric") | (x == "integer"))

        if(!all(numerica)) {
            for(i in which(!numerica)) {
                v <- x[[i]]
                match <- regexpr("[[:digit:]]+(\\.[[:digit:]]+)?", v)
                match <- regmatches(v, match)

                if(length(match) == 0) stop("Nao foi possivel converter rendimentos para numerico")

                x[[i]] <- as.numeric(match)
            }

            warning("Transformando colunas para numerico")
        }

        if(!all(x$rend >= 1)) {
            x$rend <- x$rend * 100
            warning("Coluna de rendimento em formato decimal -- multiplicando por 100")
        }

    } else {
        if(!temcolnames) {
            stop("Verifique se as colunas 'hl', 'pot', 'rend' constam no dado")
        }

        x <- x[, cols]

        classes <- lapply(x, class)
        numerica <- sapply(classes, function(x) (x == "numeric") | (x == "integer"))

        if(!all(numerica)) stop("Alguma coluna de 'x' nao e numerica")

        if(!all(x$rend >= 1)) stop("Rendimentos estao em formato decimal -- multiplique por 100")
    }

    return(x)
}

#' Conversor Para \code{curvacolina}
#'
#' Forca um objeto tipo \code{data.frame} para classe \code{curvacolina}
#'
#' Por padrao a conversao de \code{x} so sera executada caso tres criterios sejam atendidos
#'
#' \itemize{
#' \item{contenha as colunas \code{hl}, \code{pot} e \code{rend}}
#' \item{alguma das colunas nao esteja em formato numerico (ex: rendimento como "91%" ou "0.9%")}
#' \item{rendimentos nao estejam em formato decimal (ex: 0.91)}
#' }
#'
#' Caso um ou mais destes requisitos nao seja atendido, por padrao a conversao sera abotada. Nestes
#' casos, o argumento \code{force} permite forcar a transformacao do dado para \code{curvacolina}. A
#' seguir sao detalhados os comportamentos caso \code{force = TRUE} e algum criterio e violado.
#'
#' Na falta \bold{de todas as tres colunas nomeadas}, o programa considera as tres primeiras colunas
#' do dado como \code{hl}, \code{pot} e \code{rend}, caso haja pelo menos tres colunas. Do contrario
#' aborta com um erro.
#'
#' Se alguma coluna nao e numerica, sera tentada uma extracao de valores a partir do texto contido
#' na coluna. Isto e feito buscando um padrao \code{"[[:digit:]]+(\\.[[:digit:]]+)?"} em cada
#' elemento da coluna nao numerica. Desta forma, contanto que exista um numero dentro do texto (ex:
#' "91.5%" ou "rend_91.1"), sera possivel converter. Caso a conversao falhe, a funcao sera aborta.
#'
#' Finalmente, se os rendimentos forem detectados como formato decimal, serao multiplicados por
#' 100. A identificacao e baseada em \bold{todos} os elementos da coluna serem menores do que 1.
#'
#' E possivel que em algum momento desta coacao para o formato padrao ocorra algum erro, pois o
#' programa nao esta preparado para lidar com todas as possibilidades de dado de entrada. Pelo mesmo
#' motivo, e possivel que a execucao termine sem erro, porem com resultados incoerentes. Desta forma
#' o uso da opcao \code{force = TRUE} e pouco recomendado, exceto em casos especificos.
#'
#' @param x \code{data.frame}-like a ser convertido. Ver Detalhes
#' @param g,rho aceleracao da gravidade e densidade da agua
#' @param force booleano indicando se o objeto deve ser forcado ao formato padrao. Pode gerar
#'     resultados inconsistentes. Ver Detalhes
#'
#' @examples
#'
#' # gerando um dado totalmente aleatorio (nao condiz com uma colina de fato)
#' dd <- data.frame(hl = runif(100), pot = runif(100), rend = rep(1:10, each = 10))
#' cc <- as.curvacolina(dd, g = 9.81, rho = 1000)
#'
#' @return objeto da classe \code{curvacolina}
#'
#' @family curvacolina
#'
#' @import data.table
#'
#' @export

as.curvacolina <- function(x, g = NA, rho = NA, force = FALSE) {

    hl <- pot <- rend <- NULL

    x <- parsedadocolina(x, force)
    x <- as.data.table(x)

    new_curvacolina(x, g, rho)
}

#' Redutor De \code{curvacolina}
#'
#' Retorna o objeto \code{curvacolina} com um numero reduzido de observacoes
#'
#' O argumento \code{taxa} e utilizado da seguinte maneira: seja \code{n} o numero de observacoes em
#' \code{colina}, sera amostrado um subset dessas tomando uma a cada \code{taxa} observacoes. Por
#' exemplo, se \code{taxa = 3}, sao selecionadas as observacoes 1, 4, 7, e assim por diante.
#'
#' O processo de selecao descrito acima e realizado \bold{por curva de rendimento}, dado que a curva
#' tenha pelo menos \code{5 * taxa} observacoes. Este limite e algo essencialmente arbitrario.
#'
#' @param colina objeto \code{curvacolina} retornado pelas funcoes de leitura
#' @param taxa inteiro indicando reducao do tamanho do historico em \code{taxa_reducao} vezes. Ver
#'     Detalhes
#'
#' @return \code{colina} passada com observacoes selecionadas
#'
#' @export

reduzcolina <- function(colina, taxa) {

    vec_reduz <- rep(FALSE, taxa)
    vec_reduz[1] <- TRUE

    colreduzida <- copy(colina$CC)
    colreduzida <- split(colreduzida, colreduzida$rend)
    colreduzida <- lapply(colreduzida, function(d) {
        if(nrow(d) > (5 * taxa)) {
            d <- d[rep(vec_reduz, length.out = .N)]
        }
        d
    })
    colreduzida <- as.curvacolina(rbindlist(colreduzida))

    return(colreduzida)
}

#' Atribui \code{g} E \code{rho} A Objeto \code{curvacolina}
#'
#' Adiciona os atributos e calcula vazao turbinada na transformacao de curva colina
#'
#' @param x objeto da classe \code{curvacolina}
#' @param g,rho aceleracao da gravidade e densidade da agua
#'
#' @examples
#'
#' \dontrun{
#' # o dado padrao do pacote nao possui g e rho
#' is.na(attr(colinadummy, "g"))
#' is.na(attr(colinadummy, "rho"))
#' }
#'
#' # adicionando os valores de literatura
#' cc <- set_grho(colinadummy, 9.81, 1000)
#'
#' \dontrun{
#' # atributos adicionados
#' attr(cc, "g")
#' attr(cc, "rho")
#'
#' # vazao calculada
#' cc$CC$vaz
#' }
#'
#' @return objeto \code{curvacolina} passado com atributos \code{g} e \code{rho}, assim como vazao
#'     turbinada caclulada
#'
#' @export

set_grho <- function(x, g, rho) {

    if(class(x) != "curvacolina") stop("'x' nao e um objeto 'curvacolina'")

    out <- x

    # aqui nao e usado a mod inplace do data.table para evitar efeitos colaterais em x no ambiente
    # global
    out$CC$vaz <- out$CC$pot / (out$CC$hl * out$CC$rend / 100 * rho * g) * 1e6

    attr(out, "g")   <- g
    attr(out, "rho") <- rho

    return(out)
}


##############################################################################
# Defines function for aggregating singleton data and obtaining genome-wide
# and per-bin summaries
##############################################################################

aggData <- function(datfile, adj){

	summfile <- datfile$summ
	binfile <- datfile$bin
	mct <- datfile$mct
	nbp <- adj*2+1

	# Get dataframe of observed and predicted counts
	{
		# aggseq <- count(summfile, c("Sequence", "Category2", "COUNT")) #<-plyr
		cat("Generating motif relative rates...\n")
		aggseq <- summfile %>%
			group_by(Sequence, Category2, BIN) %>%
			summarise(n=n()) %>%
			summarise(num=sum(n), mean=mean(n), sd=sd(n))
		aggseq <- merge(aggseq, mct, by="Sequence")
		# aggseq2 <- count(summfile, Sequence, Category2, COUNT) #<-dplyr
		aggseq$rel_prop <- aggseq$num/aggseq$COUNT

		# NEW VERSION -- need to update so nmotifs is consistent for all 3 categories
		# currently, motifs without a present singleton in a given bin are not
		# accounted for
		cat("Counting mutations per motif per bin...\n")
		summagg <- summfile %>%
				dplyr::select(CHR, POS, BIN, Sequence, Category2) %>%
				group_by(CHR, BIN, Sequence, Category2) %>%
				summarise(obs=n())

		# Count observed singletons per bin per basic category
		spbc <- summagg %>%
			group_by(CHR, BIN, Category2) %>%
			summarise(obs=sum(obs, na.rm=T))

		datalist<- list("agg"=aggseq, "oe"=spbc, "summagg2"=summagg)
		return(datalist)
	}
}


# GetShockLowData_2yr_span1.r
#                                       RBLandau 20171213
# where to run?
# setwd("C:/cygwin64/home/landau/working/PreservationSimulation/shocks/low/span1/2yr")

# Trickier now because shocks have varying duration, too.

source("./DataUtil.r")
source("./PlotUtil.r")

# G E T   D A T A
if (exists("results")) {rm(results)}
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.shockallcopies <- as.data.frame(fndfGetShockData(results))
dat.shockall <- dat.shockallcopies[dat.shockallcopies$copies>=3
                & dat.shockallcopies$copies<=5,]

# S U B S E T S

# First, half-year durations.
dat.shock <- dat.shockall[dat.shockall$lifem<=100 & dat.shockall$shockmaxlife==5000,]
dat.shock50 <- dat.shock[dat.shock$shockimpact==50,]
dat.shock90 <- dat.shock[dat.shock$shockimpact==90,]
dat.shock100 <- dat.shock[dat.shock$shockimpact==100,]

# P L O T   D A T A
library(ggplot2)
source("./ShockLowPlots.r")
gp <- fnPlotShock1(dat.shock90, 2, 6, 1, 90)
fnPlotMakeFile(gp, "Shock_freq2dur5kspan1impact90.png")
gp <- fnPlotShock1(dat.shock50, 2, 6, 1, 50)
fnPlotMakeFile(gp, "Shock_freq2dur5kspan1impact50.png")
gp <- fnPlotShock1(dat.shock100, 2, 6, 1, 100)
fnPlotMakeFile(gp, "Shock_freq2dur5kspan1impact100.png")

# S U M M A R Y   T A B L E S
source("ShockLowTables.r")
fnSaveSmallLossTable(dat.shock50, "ShockLow2yrdur5kspan1impact50.txt",
    "Percent Permanent Losses, Shock Low 2yr dur5k span1 impact 50% "
    %+% "\n(percent loss by copies vs sector half-life in megahours)")
fnSaveSmallLossTable(dat.shock90, "ShockLow2yrdur5kspan1impact90.txt",
    "Percent Permanent Losses, Shock Low 2yr dur5k span1 impact 90% "
    %+% "\n(percent loss by copies vs sector half-life in megahours)")
fnSaveSmallLossTable(dat.shock100, "ShockLow2yrdur5kspan1impact100.txt",
    "Percent Permanent Losses, Shock Low 2yr dur5k span1 impact 100% "
    %+% "\n(percent loss by copies vs sector half-life in megahours)")

# Then, full year durations.
dat.shock <- dat.shockall[dat.shockall$lifem<=100 & dat.shockall$shockmaxlife==10000,]
dat.shock50 <- dat.shock[dat.shock$shockimpact==50,]
dat.shock90 <- dat.shock[dat.shock$shockimpact==90,]
dat.shock100 <- dat.shock[dat.shock$shockimpact==100,]

# P L O T   D A T A
library(ggplot2)
#source("./ShockLowPlots.r")
gp <- fnPlotShock1(dat.shock90, 2, 12, 1, 90)
fnPlotMakeFile(gp, "Shock_freq2dur10kspan1impact90.png")
gp <- fnPlotShock1(dat.shock50, 2, 12, 1, 50)
fnPlotMakeFile(gp, "Shock_freq2dur10kspan1impact50.png")
gp <- fnPlotShock1(dat.shock100, 2, 12, 1, 100)
fnPlotMakeFile(gp, "Shock_freq2dur10kspan1impact100.png")

# S U M M A R Y   T A B L E S
# Print small summary tables.
#source("ShockLowTables.r")
fnSaveSmallLossTable(dat.shock50, "ShockLow2yrdur10kspan1impact50.txt",
    "Percent Permanent Losses, Shock Low 2yr dur10k span1 impact 50% "
    %+% "\n(percent loss by copies vs sector half-life in megahours)")
fnSaveSmallLossTable(dat.shock90, "ShockLow2yrdur10kspan1impact90.txt",
    "Percent Permanent Losses, Shock Low 2yr dur10k span1 impact 90% "
    %+% "\n(percent loss by copies vs sector half-life in megahours)")
fnSaveSmallLossTable(dat.shock100, "ShockLow2yrdur10kspan1impact100.txt",
    "Percent Permanent Losses, Shock Low 2yr dur10k span1 impact 100% "
    %+% "\n(percent loss by copies vs sector half-life in megahours)")

if(0){

source("./ShockTables.r")

# T A B U L A T E   D A T A  A S   T E X T

# M O N T H L Y
sOutputFilename <- "./Data_AuditRandom_Monthly.txt"
sTitle <- "Document losses with multiple copies and MONTHLY random auditing"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by number of copies and sector half-lifetime"
dat.tmp <- dat.auditrandom.monthly
tbl.tmp <- fnPrintTableRandom(dat.tmp, sOutputFilename, sTitle, sSubtitle
)

# IF THAT WORKS, DO SOME MORE.

# Re-form the data into a table for printing.
foo<-(with(dat.auditrandom,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))
# Pretty-print this to a file with explanatory headings.
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

}#endif0

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


#Code to create a qc table from the fastp output. Table contains the following information for each fastq:
#	--total reads
#	--total bases
#	--q20/q30 bases
#	--q20/q30 rate
#	--mean length of read 1
#	--mean length of read 2
#	--gc_content
#	--duplication rate
#-----------------------------------------------------

library(ggplot2)
library(odbc)
library(DBI)
library(rjson)

rm(list=ls())

con <- DBI::dbConnect(odbc::odbc(), "GLASSv3")

myDir1 <- "/projects/varnf/GLASS-III/GLASS-III/results/kallisto/fastp"
myinf1 <- paste(myDir1,dir(myDir1),sep="/")
myinf1 <- unlist(sapply(myinf1,function(x)paste(x,"/",dir(x)[grep(".json",dir(x))],sep="")))
names(myinf1) <- gsub("/projects/varnf/GLASS-III/GLASS-III/results/kallisto/fastp/","",names(myinf1))

beforelist <- afterlist <- list()
duplication_rate <- rep(0,length(myinf1))
for(i in 1:length(myinf1))
{
	result <- fromJSON(file = myinf1[i])
	mysummary <- result$summary
	before <- mysummary$before_filtering
	after <- mysummary$after_filtering

	mycommand <- result$command
	before$file_path_R1 <- after$file_path_R1 <- sapply(strsplit(mycommand," "),function(x)x[3])
	before$file_path_R2 <- after$file_path_R2 <- sapply(strsplit(mycommand," "),function(x)x[5])

	beforelist[[i]] <- before
	afterlist[[i]] <- after

	result <- fromJSON(file = myinf1[i])
	duplication_rate[i] <- result$duplication$rate

}
names(beforelist) <- names(afterlist) <- names(myinf1)

before_table <- do.call(rbind,beforelist)
after_table <- do.call(rbind,afterlist)

before_table <- as.data.frame(apply(before_table,2,unlist))
before_table[,1:(ncol(before_table)-2)] <- apply(before_table[,1:(ncol(before_table)-2)],2,as.numeric)
before_table[,"aliquot_barcode"] <- substr(rownames(before_table),1,30)
rownames(before_table) <- NULL
before_table <- before_table[,c(ncol(before_table),1:(ncol(before_table)-1))]
before_table <- cbind(before_table,duplication_rate)

after_table <- as.data.frame(apply(after_table,2,unlist))
after_table[,1:(ncol(after_table)-2)] <- apply(after_table[,1:(ncol(after_table)-2)],2,as.numeric)
after_table[,"aliquot_barcode"] <- substr(rownames(after_table),1,30)
rownames(after_table) <- NULL
after_table <- after_table[,c(ncol(after_table),1:(ncol(after_table)-1))]
after_table <- cbind(after_table,duplication_rate)

fastp_applied <- as.factor(c(rep(0,nrow(before_table)),rep(1,nrow(after_table))))
final_table <- rbind(before_table,after_table)
final_table <- data.frame(final_table,fastp_applied)
final_table <- final_table[,c(1:10,13,11,12,14)]
final_table[,"fastp_applied"] <- as.numeric(as.character(final_table[,"fastp_applied"]))

pdf("/projects/varnf/GLASS-III/GLASS-III/figures/qc/read_count.pdf")
ggplot(final_table, aes(x=total_reads,colour=fastp_applied)) +
geom_density()
dev.off()

dbWriteTable(con, Id(schema="analysis", table="fastp_metrics"), final_table, overwrite=TRUE)


MRHCA_IM_compute_full_pub_new<-function(data_CORS_cancer,list_c,IM_id_list,immune_cell_uni_table=marker_stats20_uni,step_size0=20)
{
        MR_M<-list_c[[1]]
        cor_c<-list_c[[2]]
        down_lim<-list_c[[3]]
        print("Compute MR IM genes")
        MR_IM_result_c<-list()
        print(nrow(MR_M))
        step_size<-step_size0
        IM_id_list0<-IM_id_list
        MR_IM_result_c<-c()
      for(ii in 1:nrow(list_c[[1]]))
      {
                tg_gene<-rownames(MR_M)[ii]
                x0<-sqrt(sort(MR_M[tg_gene,]))
                tg_growth_rate<-calculate_growth_rate2(x0,step=step_size)
                tg_ccc1<-which(tg_growth_rate<down_lim)
                aaa<-sqrt(sort(MR_M[tg_gene,]))
                bbb3<-aaa/(1:length(aaa))
                bbb4<-cor_c[tg_gene,names(sort(MR_M[tg_gene,]))]

                ddd<-cbind(1:length(tg_growth_rate),tg_growth_rate,bbb3,bbb4)
                colnames(ddd)[1:4]<-c("MR_order_ID","growth_rate","sorted_MR","Corr")
                tg_ccc3<-intersect(tg_ccc1,which(bbb4>0.7))

                fff<-""
                if(length(tg_ccc3)>1)
                {
                        fff<-as.matrix(ddd[1:max(tg_ccc3),])
                }
                if(ii%%500==1)
                {
                        print(ii)
                }
                MR_IM_result_c[[ii]]<-list(fff,tg_ccc3)
      }
      names(MR_IM_result_c)<-rownames(MR_M)[1:length(MR_IM_result_c)]
      return(MR_IM_result_c)
}

clean_rank1_module_new<-function(data_c,module_info,module_rank,st0=8,RR=50)
{
        N<-0
        nc<-c()
        module_new<-list()
        for(i in 1:length(module_info))
        {
                if(module_rank[i]==1)
                {
                        N<-N+1
                        nc<-c(nc,names(module_info)[i])
                        module_new[[N]]<-module_info[[i]]
                }
                if(module_rank[i]>1)
                {
                        ccc<-module_info[[i]]
                        st<-st0
                        rr<-1
                        while((rr==1)&(st<=length(ccc)))
                        {
                                tg_genes<-c(ccc[1:st])
                                pp<-BCV_ttest2(data_c[tg_genes,],rounds=RR,maxrank0=5)
                                rr<-sum(pp<0.001)
                                st<-st+1
                        }
                        tg_genes<-tg_genes[-length(tg_genes)]
                        if(length(tg_genes)>st0)
                        {
                                N<-N+1
                                nc<-c(nc,names(module_info)[i])
                                module_new[[N]]<-tg_genes
                        }
                }
        }
        names(module_new)<-nc
        return(module_new)
}

R1_list_filtering_step1_new<-function(list_c2,data_CORS_cancer,max_cut=20,cutn0=20,cut10=0.8,IM_id_list,immune_cell_uni_table=immune_cell_uni_table0_GPL570)
{
tg_1_rank_markers0<-list_c2[[1]]
tg_m_names0<-list_c2[[2]]
RMSE_on_CORS_cancer_c<-RMSE_row(data_CORS_cancer)
tg_marker_lists<-list()
for(i in 1:length(list_c2[[1]]))
{
        ccc<-c(names(list_c2[[1]])[i],rownames(list_c2[[1]][[i]]))
        tg_marker_lists[[i]]<-ccc
}
names(tg_marker_lists)<-names(list_c2[[1]])

pp_all<-c()
for(i in 1:length(tg_marker_lists))
{
        pp<-sum(BCV_ttest2(data_CORS_cancer[tg_marker_lists[[i]],],maxrank0=20)<0.001, na.rm=T)
        pp_all<-c(pp_all,pp)
}
pp_R1_marker_list_f1<-clean_rank1_module_new(data_CORS_cancer,tg_marker_lists,pp_all,st0=6)
pp_R1_marker_list_f1.5<-cut_modules(pp_R1_marker_list_f1,cutn=cutn0)

stat_p1<-list()
for(i in 1:length(pp_R1_marker_list_f1.5))
{
	tg_gene_c<-pp_R1_marker_list_f1.5[[i]][-1]
	stat_p1[[i]]<-tg_1_rank_markers0[[names(pp_R1_marker_list_f1.5)[i]]][tg_gene_c,]
}

names(tg_marker_lists)<-names(pp_R1_marker_list_f1.5)
tg_genes_all<-c()
for(i in 1:length(pp_R1_marker_list_f1.5))
{
        tg_genes_all<-c(tg_genes_all,pp_R1_marker_list_f1.5[[i]])
}
tg_genes_all<-unique(sort(tg_genes_all))

print("filter 1 and stat done!")
#ccc<-MAP_GPL570_genes2(R1_markers_f1)
#names(ccc)<-names(Top_cell_proportion)
#table(names(Top_cell_proportion))
R1_markers_f1<-pp_R1_marker_list_f1.5

cut1<-cut10
ccc<-compute_min_jaccard(R1_markers_f1)
ccc0<-ccc>cut1

stat_cc<-c(1:nrow(ccc0))
names(stat_cc)<-1:nrow(ccc0)
for(i in 1:nrow(ccc0))
{
        for(j in 1:ncol(ccc0))
        {
                if((i<j)&(ccc0[i,j]>0))
                {
                        nn<-max(i,j)
                        stat_cc[which(stat_cc==i)]<-nn
                        stat_cc[which(stat_cc==j)]<-nn
                }
        }
}
table(stat_cc)
tg_ccc<-unique(stat_cc)
R1_marker_list_f2<-list()
N<-0
for(i in 1:length(tg_ccc))
{
        N<-N+1
        tg_ids<-as.numeric(names(stat_cc)[which(stat_cc==tg_ccc[i])])
        ccc<-c()
        for(j in 1:length(tg_ids))
        {
                ccc<-c(ccc,R1_markers_f1[[tg_ids[j]]])
        }
        ccc<-unique(ccc)
        R1_marker_list_f2[[N]]<-ccc
}

R1_marker_list_f2.5_stat<-rank_based_module_sorting(data_CORS_cancer,R1_marker_list_f2,IM_id_list,immune_cell_uni_table=immune_cell_uni_table)
R1_marker_list_f2.5<-R1_marker_list_f2.5_stat[[1]]

pp_all<-c()
for(i in 1:length(R1_marker_list_f2.5))
{
        pp<-sum(BCV_ttest(data_CORS_cancer[R1_marker_list_f2.5[[i]],],maxrank0=20)<0.001, na.rm=T)
        pp_all<-c(pp_all,pp)
}
pp_R1_marker_list_f3<-clean_rank1_module(data_CORS_cancer,R1_marker_list_f2.5,pp_all,st0=6)
pp_R1_marker_list_f3.5<-cut_modules(pp_R1_marker_list_f3,cutn=cutn0)
R1_marker_list_f3.5_stat<-rank_based_module_sorting(data_CORS_cancer,pp_R1_marker_list_f3.5,IM_id_list,immune_cell_uni_table=immune_cell_uni_table)

print("filter 2 done!")
ccc<-c()
nn<-c()
for(i in 1:length(pp_R1_marker_list_f3.5))
{
	ccc0<-c()
	for(j in 1:length(IM_id_list))
	{
      if(length(IM_id_list[[j]])>1)
      {
            cc0<-apply(immune_cell_uni_table[pp_R1_marker_list_f3.5[[i]],IM_id_list[[j]]],1,sum)/sum((1/(1:length(IM_id_list[[j]]))))
      }
      else
      {
           cc0<-immune_cell_uni_table[pp_R1_marker_list_f3.5[[i]],IM_id_list[[j]]]
      }
		ccc0<-cbind(ccc0,cc0)
	}
	colnames(ccc0)<-names(IM_id_list)
      ddd<-apply(ccc0,2,mean)
      ccc<-rbind(ccc,ddd)
      nn<-c(nn,colnames(ccc0)[which(ddd==max(ddd))[1]])
}
rownames(ccc)<-nn
cell_enrich_stat<-ccc
names(pp_R1_marker_list_f3.5)<-nn
rrr<-rep(1,length(pp_R1_marker_list_f3.5))
Filter_1_result_list<-list(pp_R1_marker_list_f1,R1_marker_list_f2,R1_marker_list_f3.5_stat,pp_R1_marker_list_f3.5,rrr,cell_enrich_stat)
names(Filter_1_result_list)<-c("R1_marker_list_f1","R1_marker_list_f2","R1_marker_list_f3.5_stat","R1_marker_list_f3.5","R1_marker_list_rank","R1_marker_list_f3.5_cell_enrich_stat")
return(Filter_1_result_list)
}

rank_based_module_sorting<-function(data_c,tg_list,IM_id_list,immune_cell_uni_table=marker_stats20_uni)
{
	tg_list_new<-list()
	tg_list_stat<-list()
	for(i in 1:length(tg_list))
	{
		rr<-svd(data_c[tg_list[[i]],])$v[,1]
		if(mean(cor(t(data_c[tg_list[[i]],]),rr))<0)
		{
			rr<--rr
		}
		tg_genes_cc<-tg_list[[i]][order(-cor(t(data_c[tg_list[[i]],]),rr))]

		ccc<-immune_cell_uni_table[tg_genes_cc,]^(1/2)
		ccc0<-c()
		for(j in 1:length(IM_id_list))
		{
                       			 if(length(IM_id_list[[j]])>1)
                       			 {
                               		 xx<-sum((1/(1:length(IM_id_list[[j]])))^(1/2))
                               		 cc0<-(cumsum(apply(ccc[,IM_id_list[[j]]],1,sum))/xx/c(1:nrow(ccc)))
                       			 }
                        		else
                        		{
                                		cc0<-(cumsum(ccc[,IM_id_list[[j]]])/c(1:nrow(ccc)))
                        		}
                       			 ccc0<-cbind(ccc0,cc0)
		}
		colnames(ccc0)<-names(IM_id_list)
		tg_list_new[[i]]<-tg_genes_cc
		tg_list_stat[[i]]<-ccc0
	}
	return(list(tg_list_new,tg_list_stat))
}

Process_MR_IM_result_new<-function(MR_IM_result_c=MR_IM_result_c,tg_key_c=tg_key_c,cor_cut0=0.7,cell_type_enrich_cut=0.5,num_cut=5,num_cut2=5,IM_id_list,immune_cell_uni_table=immune_cell_uni_table0_GPL570)
{
tg_1_rank_markers<-list()
tg_m_names<-c()
N<-0
print("Select Marker!")
for(i in 1:length(MR_IM_result_c))
{
        if(length(MR_IM_result_c[[i]][[2]])>=num_cut)
        {
                ss<-scoring_MR_order(MR_IM_result_c[[i]][[2]])
                if(ss>=num_cut)
                {
                        ccc<-MR_IM_result_c[[i]][[1]][1:ss,]
                        if(sum(ccc[,4]>cor_cut0)>=num_cut)
                        {
                                tg_ccc<-names(which(ccc[,4]>cor_cut0))
                                if(length(tg_ccc)>=num_cut)
                                {
						    ccc1<-ccc[order(-ccc[,4]),]
						    tg_gene<-rownames(ccc1)
						   ccc<-immune_cell_uni_table[tg_gene,]^(1/2)
                					ccc0<-c()
               				 for(j in 1:length(IM_id_list))
                				{
                       			 if(length(IM_id_list[[j]])>1)
                       			 {
                               		 xx<-sum((1/(1:length(IM_id_list[[j]])))^(1/2))
                               		 cc0<-(cumsum(apply(ccc[,IM_id_list[[j]]],1,sum))/xx/c(1:nrow(ccc)))
                       			 }
                        		else
                        		{
                                		cc0<-(cumsum(ccc[,IM_id_list[[j]]])/c(1:nrow(ccc)))
                        		}
                       			 ccc0<-cbind(ccc0,cc0)
                				}
               				 colnames(ccc0)<-names(IM_id_list)
						ccc3<-cbind(ccc1,ccc0)
                                        ddd<-apply(ccc0,2,mean)
                                        if(max(ddd)>cell_type_enrich_cut)
						    {
								tg_c_ids<-names(which(ddd==max(ddd)))[1]
								tg_c_id0<-IM_id_list[[tg_c_ids]]
								eee<-ccc[,tg_c_id0]
								if(length(tg_c_id0)>1)
								{
									eee<-apply(ccc[,tg_c_id0],1,mean)
								}

                                        	if(sum(eee>0.5)>=num_cut2)
                                        	{
                                                N<-N+1
                                                tg_1_rank_markers[[N]]<-ccc3[which(ccc3[,4]>cor_cut0),]
                                                tg_m_names<-c(tg_m_names,names(MR_IM_result_c)[i])
                                      	  }
                                        }
                                }
                        }
                }
        }
}
print("Select Marker Done!")
#tg_RF2<-paste(tg_key_c,"_1rankmarker_cell_type_consistency.pdf",sep="")
##library(gplots)
#colors = c(0:100)/100
#my_palette <- grDevices::colorRampPalette(c("white","white", "blue"))(n =100)
#pdf(tg_RF2)
#for(i in 1:length(tg_1_rank_markers))
#{
#       aaa<-tg_1_rank_markers[[i]][,-c(1:4)]
#       heatmap.2(aaa,Rowv=F,Colv =F,scale="none",main=tg_m_names[i],
#       col=my_palette,breaks=colors,density.info="none",dendrogram="both",
#       trace="none",margin=c(10,10),cexRow=0.5,cexCol=1)
#}
#dev.off()
names(tg_1_rank_markers)<-tg_m_names
list_cc<-list(tg_1_rank_markers,tg_m_names)
return(list_cc)
}

Process_MR_IM_result_GPL570_new<-function(MR_IM_result_c=MR_IM_result_c,tg_key_c=tg_key_c,cor_cut0=0.7,cell_type_enrich_cut=0.5,num_cut=5,num_cut2=5,IM_id_list,immune_cell_uni_table=immune_cell_uni_table0_GPL570)
{
tg_1_rank_markers<-list()
tg_m_names<-c()
N<-0
print("Select Marker!")
for(i in 1:length(MR_IM_result_c))
{
        if(length(MR_IM_result_c[[i]][[2]])>=num_cut)
        {
                ss<-scoring_MR_order(MR_IM_result_c[[i]][[2]])
                if(ss>=num_cut)
                {
                        ccc<-MR_IM_result_c[[i]][[1]][1:ss,]
                        if(sum(ccc[,4]>cor_cut0)>=num_cut)
                        {
                                tg_ccc<-names(which(ccc[,4]>cor_cut0))
			              tg_ccc2<-unique(GPL570_id_symbol0[intersect(GPL570_id_symbol[,1],c(names(MR_IM_result_c)[i],tg_ccc)),2])
                                if(length(tg_ccc2)>=num_cut)
                                {
						    ccc1<-ccc[order(-ccc[,4]),]
						    tg_gene<-rownames(ccc1)
						   ccc<-immune_cell_uni_table[tg_gene,]^(1/2)
                					ccc0<-c()
               				 for(j in 1:length(IM_id_list))
                				{
                       			 if(length(IM_id_list[[j]])>1)
                       			 {
                               		 xx<-sum((1/(1:length(IM_id_list[[j]])))^(1/2))
                               		 cc0<-(cumsum(apply(ccc[,IM_id_list[[j]]],1,sum))/xx/c(1:nrow(ccc)))
                       			 }
                        		else
                        		{
                                		cc0<-(cumsum(ccc[,IM_id_list[[j]]])/c(1:nrow(ccc)))
                        		}
                       			 ccc0<-cbind(ccc0,cc0)
                				}
               				 colnames(ccc0)<-names(IM_id_list)
						ccc3<-cbind(ccc1,ccc0)
                                        ddd<-apply(ccc0,2,mean)
                                        if(max(ddd)>cell_type_enrich_cut)
						    {
								tg_c_ids<-names(which(ddd==max(ddd)))[1]
								tg_c_id0<-IM_id_list[[tg_c_ids]]
								eee<-ccc[,tg_c_id0]
								if(length(tg_c_id0)>1)
								{
									eee<-apply(ccc[,tg_c_id0],1,mean)
								}
                                        }
                                        if(sum(eee>0.5)>=num_cut2)
                                        {
                                                N<-N+1
                                                tg_1_rank_markers[[N]]<-ccc3[which(ccc3[,4]>cor_cut0),]
                                                tg_m_names<-c(tg_m_names,names(MR_IM_result_c)[i])
                                        }
                                }
                        }
                }
        }
}
print("Select Marker Done!")
#tg_RF2<-paste(tg_key_c,"_1rankmarker_cell_type_consistency.pdf",sep="")
##library(gplots)
#colors = c(0:100)/100
#my_palette <- grDevices::colorRampPalette(c("white","white", "blue"))(n =100)
#pdf(tg_RF2)
#for(i in 1:length(tg_1_rank_markers))
#{
#       aaa<-tg_1_rank_markers[[i]][,-c(1:4)]
#       heatmap.2(aaa,Rowv=F,Colv =F,scale="none",main=tg_m_names[i],
#       col=my_palette,breaks=colors,density.info="none",dendrogram="both",
#       trace="none",margin=c(10,10),cexRow=0.5,cexCol=1)
#}
#dev.off()
names(tg_1_rank_markers)<-tg_m_names
list_cc<-list(tg_1_rank_markers,tg_m_names)
return(list_cc)
}


#' NA
#'
#' NA utilities.
#'
#' @param x,object
#' A float vector/matrix.
#' @param ...
#' Ignored.
#'
#' @examples
#' library(float)
#'
#' s = flrunif(10, 3)
#' is.na(s)
#'
#' @useDynLib float R_isna_spm R_naomit_spm R_anyNA_spm
#' @name na
#' @rdname na
NULL

is.na_float32 = function(x)
{
  .Call(R_isna_spm, DATA(x))
}

na.omit_float32 = function(object, ...)
{
  ret = .Call(R_naomit_spm, DATA(object))
  float32(ret)
}

#' @rdname na
#' @export
setMethod("is.na", signature(x="float32"), is.na_float32)

#' @rdname na
#' @export
setMethod("na.omit", signature(object="float32"), na.omit_float32)

#' @rdname na
#' @export
setMethod("na.exclude", signature(object="float32"), na.omit_float32)

# -----------------------------------------------------------------------------
# internal only
# -----------------------------------------------------------------------------

anyNA = function(x)
{
  .Call(R_anyNA_spm, DATA(x))
}


# R script for plotting ROC curve for different tableau search methods
# Alex Stivala
# July 2008
# Reduced version to make clearer in grayscale (showing only those that
# don't overlap too much).
# $Id: plotsearchroc_betagrasp_reduced.r 1946 2008-10-04 05:14:43Z astivala $

#
# globals
#

colorvec=c('black','black','black','black','black','black')
ltyvec=c(1,2,4,5,6)
namevec=c('QP numeric ordering SSE type',  'QP discrete SSE type', 'QP discrete ordering SSE type')

#
# main
#

qp_numeric <- read.table('betagrasp.tsrchn.ff.rtab',header=TRUE)
qp_numeric_ordering_penalizessetype <- read.table('betagrasp.tsrchn.tt.rtab',header=TRUE)

qp_discrete <- read.table('betagrasp.tsrchd.ff.rtab',header=TRUE)
qp_discrete_penalizessetype <- read.table('betagrasp.tsrchd.tf.rtab', header=TRUE)
qp_discrete_ordering_penalizessetype <- read.table('betagrasp.tsrchd.tt.rtab', header=TRUE)

# EPS suitable for inserting into LaTeX
postscript('searchroc_betagrasp_reduced.eps',onefile=FALSE,paper="special",horizontal=FALSE,
           width = 9, height = 6)

plot(c(0,1),c(0,1),type='l',xlim=c(0,1),ylim=c(0,1),xlab="False Positive Rate",ylab="True Positive Rate",lty=3,main='ROC curves for query d1ubia_ against ASTRAL 95% seq id ProSMoS dataset as truth')

lines(qp_numeric_ordering_penalizessetype$fpr, qp_numeric_ordering_penalizessetype$tpr, col=colorvec[1], lty=ltyvec[1])
lines(qp_discrete_penalizessetype$fpr, qp_discrete_penalizessetype$tpr, col=colorvec[2], lty=ltyvec[2])
lines(qp_discrete_ordering_penalizessetype$fpr, qp_discrete_ordering_penalizessetype$tpr, col=colorvec[3], lty=ltyvec[3])

legend('bottomright', col=colorvec, lty=ltyvec, legend=namevec)

dev.off()


#Script to create contact maps from PDB structures or from predicted structures for example files in package.
#Required file type: ".pdb" and ".txt"
#Input: cmexample("desired-distance-constraint", a pdb file and a react2 file)

map.example=function(cadistance,exampleinput) {
	if(is.numeric(cadistance)==FALSE){
		return("Error: Contact map distances must be numeric.")
	}else if(is.character(exampleinput)==FALSE){
		return("Error: Protein input must be character, add quote marks around protein name/accession.")
	}else{
			#scripttime=proc.time()		#to test runtime
			#Nullify
			x=NULL
			pdbfile.initial=NULL
			pdbfile=NULL
			xatoms=NULL
			xmolecule=NULL
			xchaina=NULL
			xalpha=NULL
			aamin=NULL
			xlstart=NULL
			xlend=NULL
			xdistmatrix=NULL
			distcon=NULL
			colfunc1=NULL
			colfunc2=NULL
			hmcols=NULL
			xlcontactfile=NULL
			uniprotsitetable=NULL
			upaccs1=NULL
			upaccs2=NULL
			upinputselect1=NULL
			upinputselect2=NULL
			reciprocalust=NULL
			crosslinkmap=NULL
			#libraries
				#library(zoo)
				#library(Rpdb)
				#library(lattice)
				#library(latticeExtra)
				#library(tcltk)
			#data
			#data(cmdata)
			#data(xlmapdata)

			recname=chainid=elename=NULL

			#import pdb from example file
			pdbfile.initial=paste("p.",exampleinput,sep="")
			pdbfile=get(pdbfile.initial)

			yes.pdb=c('oxa23','tbpa','ppib')
			no.pdb=c('ab57.2983','ppib.decoy')

			##if pdb file imported, find contacts within x angstroms and plot them to data matrix
			#first identify atoms
			xatoms=pdbfile$atoms

			#as.data.frame important for maintaining values in eleid and resid columns
			xmolecule=subset(as.data.frame(xatoms),recname=="ATOM")

			#then identify alpha-carbons in chain A
			if(any(exampleinput==yes.pdb)==TRUE) {
				xchaina=subset(xmolecule,chainid=="A")
				xalpha=subset(xchaina,elename=="CA")
			}else if(any(exampleinput==no.pdb)==TRUE){
				xalpha=subset(xmolecule,elename=="CA")
			}else {
			return("No example files with that name")
			}

			aamin=1
			xlstart=min(xalpha[c("resid")])
			xlend=max(xalpha[c("resid")])
			#aamax=

			#create matrix including any crystal structure offset in amino acid sequence
			xfill=as.data.frame(matrix(1000,nrow=(xlstart-1),ncol=ncol(xalpha)))
			colnames(xfill)=colnames(xalpha)
			xalphafilled=rbind(xfill,xalpha)

			#determine distance between alpha carbons (this will create the matrix of interactions)
			xdistmatrix=as.matrix(dist(xalphafilled[c("x1","x2","x3")]))
			xdistmax=max(as.matrix(dist(xalpha[c("x1","x2","x3")])))
			if(cadistance>max(xdistmax)){
				cadistance=max(xdistmax)
				#print(cadistance)				#to ensure distance input is being read correctly
				#print(max(xdistmax))			#to ensure distance max is being read correctly
			}else{
				cadistance=cadistance
				#print(cadistance)				#to ensure distance input is being read correctly
				#print(max(xdistmax))			#to ensure distance max is being read correctly
			}
			xdistmatadj=xdistmatrix[xdistmatrix>cadistance]=50

			###
			###
			###
			#Make crosslink contact map from example files which are
			###
			###
			###

			crosslinktable=get(gsub('.decoy',"",exampleinput))
			#print(head(crosslinktable))
			crosslinkmap=as.matrix(crosslinktable[c(3,4)])

			###
			###
			###
			#PLOTTING contact values
			##
			##
			##

			colfunc1=colorRampPalette(c("lightgrey","black","darkgreen", "lightgreen"))
				colfunc2=colorRampPalette(c("white"))
				hmcols=c(colfunc1(10000*(cadistance/max(xdistmatrix))),
					colfunc2(10000*((max(xdistmatrix)-cadistance)/max(xdistmatrix)))
				)

			#save plot or just show it?
			question.save.plot = winDialog(type = c("yesno"),"Do you want to save the output file to PDF?")
			if(question.save.plot=="YES") {
				pdf(paste(cadistance,"angstrom_",exampleinput,".pdf",sep=""))
				print(
					levelplot(
						xdistmatrix,
						main=paste(exampleinput," Cross-link and Contact Map (",cadistance,"Angstroms)",sep=""),
						at=seq(min(xdistmatrix),max(xdistmatrix),length.out=5000),
						colorkey=list(space="right"),
						col.regions=hmcols,
						cuts=dim(array(hmcols))-1,
						ylab=paste(exampleinput," Residue Number",sep=""),
						xlab=paste(exampleinput," Residue Number",sep=""),
						#make axes legible
						scales=list(
							y=list(
								limits=c(1,xlend),
								at=pretty(seq_len(ncol(xdistmatrix)))
							),
							x=list(
								limits=c(1,xlend),
								at=pretty(seq_len(ncol(xdistmatrix)))
							)
						)
						#Use ContactMapMaker to overlay crosslinked sites with PDB contact map

					) + xyplot(mod_pos1~mod_pos2|as.character(prot1),data=crosslinktable,
								col="black",
								pch=21,
								cex=1.5,
								lty=2,
								fill='magenta',
							)
				)
				dev.off()

			} else{
				print(levelplot(
						xdistmatrix,
						main=paste(exampleinput," Cross-link and Contact Map (",cadistance,"Angstroms)",sep=""),
						at=seq(min(xdistmatrix),max(xdistmatrix),length.out=5000),
						colorkey=list(space="right"),
						col.regions=hmcols,
						cuts=dim(array(hmcols))-1,
						ylab=paste(exampleinput," Residue Number",sep=""),
						xlab=paste(exampleinput," Residue Number",sep=""),
						#make axes legible
						scales=list(
							y=list(

								limits=c(1,xlend),
								at=pretty(seq_len(ncol(xdistmatrix)))
							),
							x=list(
								limits=c(1,xlend),
								at=pretty(seq_len(ncol(xdistmatrix)))
							)
						)
						#Use ContactMapMaker to overlay crosslinked sites with PDB contact map

					) + xyplot(mod_pos1~mod_pos2|as.character(prot1),data=crosslinktable,
								col="black",
								pch=21,
								cex=1.5,
								lty=2,
								fill='magenta',
						)
				)
			}

			#print(proc.time()-scripttime)		#to test time for running each mapping
			print("NICE MAP!")
	}
}

#cmexample(18,'oxa23')


# Test script localy

wdpaid <- '-8.02_51.76_-2.63_55.79'
#wdpaid <- 'minlon_minlat_maxlon_maxlat'

wdpaidsplit <- unlist(strsplit(wdpaid, "[_]"))
xmin <- as.numeric(wdpaidsplit[1])
ymin <- as.numeric(wdpaidsplit[2])
xmax <- as.numeric(wdpaidsplit[3])
ymax <- as.numeric(wdpaidsplit[4])

library(rgdal)
library(downloader)
library(ggplot2)
library(mapdata)
library(geojsonio)
library(ggmap)
library(ggrepel)

# EMIS-R Libraries

library("rasterVis")
library("XML")
library("RCurl")
library("bitops")
library("lattice")
library("latticeExtra")
#library("RColorBrewer")
library("maps")
library("maptools")
library("wq")
#library("xtable")
library("zoo")
#library("jsonlite")
#require(xtable)

# Script for Wekeo environment
sr=SpatialPolygons(list(Polygons(list(Polygon(cbind(c(xmin, xmin, xmax, xmax),c(ymax, ymin, ymin, ymax)))),"1")))
mpa=SpatialPolygonsDataFrame(sr, data.frame(cbind(1:1), row.names=c("1")))
proj4string(mpa)<-CRS("+proj=longlat +datum=WGS84")

bbox<-paste(xmin,ymin,xmax,ymax,sep=",")

#FUNCTION DATA EXTRACTION
#=========================================================================

mpaextract<-function (name = "EMIS_A_CHLA", resolution = "4km", gmis_wcst_url = gmis_wcst_url, startdate = "2005-09", enddate = "2005-10", xmin = 15, xmax = 20.5, ymin = 30, ymax = 32.5)
{

        xmin <- extent(mpa)@xmin - 0.1
        xmax <- extent(mpa)@xmax + 0.1
        ymin <- extent(mpa)@ymin - 0.1
        ymax <- extent(mpa)@ymax + 0.1
        imgs <- NA

        imgs <- getgmisdataseries(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url,
                startdate = startdate, enddate = enddate, xmin, xmax, ymin, ymax)

        return(imgs)
}

#FUNCTION getGMISdataseries
#=========================================================================

getgmisdataseries<-function (name = "GMIS_A_CHLA", resolution = "4km", gmis_wcst_url = gmis_wcst_url, startdate = "2005-09", enddate = "2005-10", xmin = 15, xmax = 20.5, ymin = 30, ymax = 32.5)
{
    checkparameter <- data.frame(name = FALSE, resolution = FALSE,
        startdate = FALSE, enddate = FALSE, bbox = FALSE)

        checkparameter$resolution <- TRUE

	data_gmis<-read_gmis_wcst_data(resolution, gmis_wcst_url)

        idvar <- grep(name, data_gmis$shortname)
        if (length(idvar) == 0) {
            checkparameter$name <- FALSE
            print("Variable name do not exist on GMIS")
        }
        else {
            checkparameter$name <- TRUE
        }

    n0 <- nchar(startdate) == 7
    n1 <- substr(startdate, 1, 1) %in% 1:2
    n2 <- substr(startdate, 2, 2) %in% c(9, 0)
    n3 <- substr(startdate, 3, 3) %in% 0:9
    n4 <- substr(startdate, 4, 4) %in% 0:9
    n5 <- substr(startdate, 5, 5) == "-"
    n6 <- substr(startdate, 6, 6) %in% c(0, 1)
    n7 <- substr(startdate, 7, 7) %in% 0:9
    if (!(n0 & n1 & n2 & n3 & n4 & n5 & n6 & n7)) {
        checkparameter$startdate <- FALSE
        print("Start date format is not correct (YYYY-MM)")
    }
    else {
        checkparameter$startdate <- TRUE
    }
    n0 <- nchar(enddate) == 7
    n1 <- substr(enddate, 1, 1) %in% 1:2
    n2 <- substr(enddate, 2, 2) %in% c(9, 0)
    n3 <- substr(enddate, 3, 3) %in% 0:9
    n4 <- substr(enddate, 4, 4) %in% 0:9
    n5 <- substr(enddate, 5, 5) == "-"
    n6 <- substr(enddate, 6, 6) %in% c(0, 1)
    n7 <- substr(enddate, 7, 7) %in% 0:9
    if (!(n0 & n1 & n2 & n3 & n4 & n5 & n6 & n7)) {
        checkparameter$enddate <- FALSE
        print("End date format is not correct (YYYY-MM)")
    }
    else {
        checkparameter$enddate <- TRUE
    }
    n1 <- is.numeric(xmin)
    n2 <- length(xmin) == 1
    n3 <- is.numeric(xmax)
    n4 <- length(xmax) == 1
    n5 <- is.numeric(ymin)
    n6 <- length(ymin) == 1
    n7 <- is.numeric(ymax)
    n8 <- length(ymax) == 1
    n9 <- xmin < xmax
    n10 <- ymin < ymax
    if (!(n1 & n2 & n3 & n4 & n5 & n6 & n7 & n8)) {
        checkparameter$bbox <- FALSE
        print("Spatial limits are not correct (1 numeric vector for xmin, xmax, ymin and ymax)")
    }
    else {
        checkparameter$bbox <- TRUE
    }
    if (!(n9 & n10)) {
        checkparameter$bbox <- FALSE
        print("Spatial limits are not ordered correctly (xmin<xmax AND ymin<ymax)")
    }
    if (apply(checkparameter, 1, sum) == 5) {
        mindate <- strptime(paste(data_gmis$startdate[idvar],
            "15", sep = "-"), "%Y-%m-%d")
        maxdate <- strptime(paste(data_gmis$enddate[idvar], "15",
            sep = "-"), "%Y-%m-%d")
        askedstartdate <- strptime(paste(startdate, "15", sep = "-"),
            "%Y-%m-%d")
        if ((mindate <= askedstartdate) & (askedstartdate <=
            maxdate)) {
            checkparameter$startdate <- TRUE
        }
        else {
            checkparameter$startdate <- FALSE
            print(paste(name, "is not available on GMIS for the",
                askedstartdate))
        }
        askedenddate <- strptime(paste(enddate, "15", sep = "-"),
            "%Y-%m-%d")
        if ((mindate <= askedenddate) & (askedenddate <= maxdate)) {
            checkparameter$enddate <- TRUE
        }
        else {
            checkparameter$enddate <- FALSE
            print(paste(name, "is not available on GMIS for the",
                askedenddate))
        }
        if ((askedenddate >= askedstartdate)) {
            checkparameter$enddate <- TRUE
        }
        else {
            checkparameter$enddate <- FALSE
            print(paste(startdate, "is older than", enddate))
        }
        bboxgmis <- unlist(strsplit(data_gmis$bbox[idvar], " "))
        xmingmis <- as.numeric(bboxgmis[1])
        xmaxgmis <- as.numeric(bboxgmis[3])
        ymingmis <- as.numeric(bboxgmis[2])
        ymaxgmis <- as.numeric(bboxgmis[4])
        n1 <- xmingmis <= xmin
        n2 <- xmax <= xmaxgmis
        n3 <- ymingmis <= ymin
        n4 <- ymax <= ymaxgmis
        if (n1 & n2 & n3 & n4) {
            checkparameter$bbox <- TRUE
        }
        else {
            checkparameter$bbox <- FALSE
            print(paste("The selected area is not strickly inside the spatial extent of",
                name, "in gmis"))
        }
    }
    if (apply(checkparameter, 1, sum) == 5) {
        startyear <- as.numeric(substr(startdate, 1, 4))
        startmonth <- as.numeric(substr(startdate, 6, 7))
        endyear <- as.numeric(substr(enddate, 1, 4))
        endmonth <- as.numeric(substr(enddate, 6, 7))
        if (startyear < endyear) {
            timeindex1 <- paste(startyear, sprintf("%02d", startmonth:12),
                sep = "-")
            timelist <- expand.grid(1:12, (startyear + 1):(endyear -
                1))
            timeindex2 <- paste(timelist[, 2], sprintf("%02d",
                timelist[, 1]), sep = "-")
            timeindex3 <- paste(endyear, sprintf("%02d", 1:endmonth),
                sep = "-")
            if ((endyear - startyear) == 1) {
                timeindex <- c(timeindex1, timeindex3)
            }
            else {
                timeindex <- c(timeindex1, timeindex2, timeindex3)
            }
        }
        else {
            timeindex <- paste(startyear, sprintf("%02d", startmonth:endmonth),
                sep = "-")
        }
        pb <- txtProgressBar(min = 0, max = length(timeindex))
        for (i in 1:length(timeindex)) {
            if (i <= 1) {
                imgs <- getgmisdata(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url,
                  date = timeindex[i], xmin = xmin, xmax = xmax,
                  ymin = ymin, ymax = ymax)
                names(imgs) <- timeindex[i]
            }
            else {
                img <- getgmisdata(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url,
                  date = timeindex[i], xmin = xmin, xmax = xmax,
                  ymin = ymin, ymax = ymax)
                names(img) <- timeindex[i]
                imgs <- stack(imgs, img)
            }
            setTxtProgressBar(pb, i)
        }
        close(pb)
        return(imgs)
    }
}

#FUNCTION getGMISdataseries
#=========================================================================

getgmisdataseries<-function (name = "GMIS_A_CHLA", resolution = "4km", gmis_wcst_url = gmis_wcst_url, startdate = "2005-09", enddate = "2005-10", xmin = 15, xmax = 20.5, ymin = 30, ymax = 32.5)
{
    checkparameter <- data.frame(name = FALSE, resolution = FALSE,
        startdate = FALSE, enddate = FALSE, bbox = FALSE)

        checkparameter$resolution <- TRUE

	data_gmis<-read_gmis_wcst_data(resolution, gmis_wcst_url)

        idvar <- grep(name, data_gmis$shortname)
        if (length(idvar) == 0) {
            checkparameter$name <- FALSE
            print("Variable name do not exist on GMIS")
        }
        else {
            checkparameter$name <- TRUE
        }

    n0 <- nchar(startdate) == 7
    n1 <- substr(startdate, 1, 1) %in% 1:2
    n2 <- substr(startdate, 2, 2) %in% c(9, 0)
    n3 <- substr(startdate, 3, 3) %in% 0:9
    n4 <- substr(startdate, 4, 4) %in% 0:9
    n5 <- substr(startdate, 5, 5) == "-"
    n6 <- substr(startdate, 6, 6) %in% c(0, 1)
    n7 <- substr(startdate, 7, 7) %in% 0:9
    if (!(n0 & n1 & n2 & n3 & n4 & n5 & n6 & n7)) {
        checkparameter$startdate <- FALSE
        print("Start date format is not correct (YYYY-MM)")
    }
    else {
        checkparameter$startdate <- TRUE
    }
    n0 <- nchar(enddate) == 7
    n1 <- substr(enddate, 1, 1) %in% 1:2
    n2 <- substr(enddate, 2, 2) %in% c(9, 0)
    n3 <- substr(enddate, 3, 3) %in% 0:9
    n4 <- substr(enddate, 4, 4) %in% 0:9
    n5 <- substr(enddate, 5, 5) == "-"
    n6 <- substr(enddate, 6, 6) %in% c(0, 1)
    n7 <- substr(enddate, 7, 7) %in% 0:9
    if (!(n0 & n1 & n2 & n3 & n4 & n5 & n6 & n7)) {
        checkparameter$enddate <- FALSE
        print("End date format is not correct (YYYY-MM)")
    }
    else {
        checkparameter$enddate <- TRUE
    }
    n1 <- is.numeric(xmin)
    n2 <- length(xmin) == 1
    n3 <- is.numeric(xmax)
    n4 <- length(xmax) == 1
    n5 <- is.numeric(ymin)
    n6 <- length(ymin) == 1
    n7 <- is.numeric(ymax)
    n8 <- length(ymax) == 1
    n9 <- xmin < xmax
    n10 <- ymin < ymax
    if (!(n1 & n2 & n3 & n4 & n5 & n6 & n7 & n8)) {
        checkparameter$bbox <- FALSE
        print("Spatial limits are not correct (1 numeric vector for xmin, xmax, ymin and ymax)")
    }
    else {
        checkparameter$bbox <- TRUE
    }
    if (!(n9 & n10)) {
        checkparameter$bbox <- FALSE
        print("Spatial limits are not ordered correctly (xmin<xmax AND ymin<ymax)")
    }
    if (apply(checkparameter, 1, sum) == 5) {
        mindate <- strptime(paste(data_gmis$startdate[idvar],
            "15", sep = "-"), "%Y-%m-%d")
        maxdate <- strptime(paste(data_gmis$enddate[idvar], "15",
            sep = "-"), "%Y-%m-%d")
        askedstartdate <- strptime(paste(startdate, "15", sep = "-"),
            "%Y-%m-%d")
        if ((mindate <= askedstartdate) & (askedstartdate <=
            maxdate)) {
            checkparameter$startdate <- TRUE
        }
        else {
            checkparameter$startdate <- FALSE
            print(paste(name, "is not available on GMIS for the",
                askedstartdate))
        }
        askedenddate <- strptime(paste(enddate, "15", sep = "-"),
            "%Y-%m-%d")
        if ((mindate <= askedenddate) & (askedenddate <= maxdate)) {
            checkparameter$enddate <- TRUE
        }
        else {
            checkparameter$enddate <- FALSE
            print(paste(name, "is not available on GMIS for the",
                askedenddate))
        }
        if ((askedenddate >= askedstartdate)) {
            checkparameter$enddate <- TRUE
        }
        else {
            checkparameter$enddate <- FALSE
            print(paste(startdate, "is older than", enddate))
        }
        bboxgmis <- unlist(strsplit(data_gmis$bbox[idvar], " "))
        xmingmis <- as.numeric(bboxgmis[1])
        xmaxgmis <- as.numeric(bboxgmis[3])
        ymingmis <- as.numeric(bboxgmis[2])
        ymaxgmis <- as.numeric(bboxgmis[4])
        n1 <- xmingmis <= xmin
        n2 <- xmax <= xmaxgmis
        n3 <- ymingmis <= ymin
        n4 <- ymax <= ymaxgmis
        if (n1 & n2 & n3 & n4) {
            checkparameter$bbox <- TRUE
        }
        else {
            checkparameter$bbox <- FALSE
            print(paste("The selected area is not strickly inside the spatial extent of",
                name, "in gmis"))
        }
    }
    if (apply(checkparameter, 1, sum) == 5) {
        startyear <- as.numeric(substr(startdate, 1, 4))
        startmonth <- as.numeric(substr(startdate, 6, 7))
        endyear <- as.numeric(substr(enddate, 1, 4))
        endmonth <- as.numeric(substr(enddate, 6, 7))
        if (startyear < endyear) {
            timeindex1 <- paste(startyear, sprintf("%02d", startmonth:12),
                sep = "-")
            timelist <- expand.grid(1:12, (startyear + 1):(endyear -
                1))
            timeindex2 <- paste(timelist[, 2], sprintf("%02d",
                timelist[, 1]), sep = "-")
            timeindex3 <- paste(endyear, sprintf("%02d", 1:endmonth),
                sep = "-")
            if ((endyear - startyear) == 1) {
                timeindex <- c(timeindex1, timeindex3)
            }
            else {
                timeindex <- c(timeindex1, timeindex2, timeindex3)
            }
        }
        else {
            timeindex <- paste(startyear, sprintf("%02d", startmonth:endmonth),
                sep = "-")
        }
        pb <- txtProgressBar(min = 0, max = length(timeindex))
        for (i in 1:length(timeindex)) {
            if (i <= 1) {
                imgs <- getgmisdata(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url,
                  date = timeindex[i], xmin = xmin, xmax = xmax,
                  ymin = ymin, ymax = ymax)
                names(imgs) <- timeindex[i]
            }
            else {
                img <- getgmisdata(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url,
                  date = timeindex[i], xmin = xmin, xmax = xmax,
                  ymin = ymin, ymax = ymax)
                names(img) <- timeindex[i]
                imgs <- stack(imgs, img)
            }
            setTxtProgressBar(pb, i)
        }
        close(pb)
        return(imgs)
    }
}

#FUNCTION getGMISdata
#====================================================================

getgmisdata<-function (name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, date = startdate, xmin = 15, xmax = 20.5, ymin = 30, ymax = 32.5)
{
    checkparameter <- data.frame(name = FALSE, resolution = FALSE,
        date = FALSE, bbox = FALSE)

        checkparameter$resolution <- TRUE

        data_gmis<-read_gmis_wcst_data(resolution, gmis_wcst_url)

        idvar <- grep(name, data_gmis$shortname)
        if (length(idvar) == 0) {
            checkparameter$name <- FALSE
            print("Variable name do not exist on GMIS")
        }
        else {
            checkparameter$name <- TRUE
        }

    n0 <- nchar(date) == 7
    n1 <- substr(date, 1, 1) %in% 1:2
    n2 <- substr(date, 2, 2) %in% c(9, 0)
    n3 <- substr(date, 3, 3) %in% 0:9
    n4 <- substr(date, 4, 4) %in% 0:9
    n5 <- substr(date, 5, 5) == "-"
    n6 <- substr(date, 6, 6) %in% c(0, 1)
    n7 <- substr(date, 7, 7) %in% 0:9
    if (!(n0 & n1 & n2 & n3 & n4 & n5 & n6 & n7)) {
        checkparameter$date <- FALSE
        print("Date format is not correct (YYYY-MM)")
    }
   else {
        checkparameter$date <- TRUE
    }
    n1 <- is.numeric(xmin)
    n2 <- length(xmin) == 1
    n3 <- is.numeric(xmax)
    n4 <- length(xmax) == 1
    n5 <- is.numeric(ymin)
    n6 <- length(ymin) == 1
    n7 <- is.numeric(ymax)
    n8 <- length(ymax) == 1
    n9 <- xmin < xmax
    n10 <- ymin < ymax
    if (!(n1 & n2 & n3 & n4 & n5 & n6 & n7 & n8)) {
        checkparameter$bbox <- FALSE
        print("Spatial limits are not correct (1 numeric vector for xmin, xmax, ymin and ymax)")
    }
    else {
        checkparameter$bbox <- TRUE
    }
    if (!(n9 & n10)) {
        checkparameter$bbox <- FALSE
        print("Spatial limits are not ordered correctly (xmin<xmax AND ymin<ymax)")
    }
    if (apply(checkparameter, 1, sum) == 4) {
        mindate <- strptime(paste(data_gmis$startdate[idvar],
            "15", sep = "-"), "%Y-%m-%d")
        maxdate <- strptime(paste(data_gmis$enddate[idvar], "15",
            sep = "-"), "%Y-%m-%d")
        askeddate <- strptime(paste(date, "15", sep = "-"), "%Y-%m-%d")
        if ((mindate <= askeddate) & (askeddate <= maxdate)) {
            checkparameter$date <- TRUE
        }
        else {
            checkparameter$date <- FALSE
            print(paste(name, "is not available on GMIS for the",
                date))
        }
        bboxgmis <- unlist(strsplit(data_gmis$bbox[idvar], " "))
        xmingmis <- as.numeric(bboxgmis[1])
        xmaxgmis <- as.numeric(bboxgmis[3])
        ymingmis <- as.numeric(bboxgmis[2])
        ymaxgmis <- as.numeric(bboxgmis[4])
        n1 <- xmingmis <= xmin
        n2 <- xmax <= xmaxgmis
        n3 <- ymingmis <= ymin
        n4 <- ymax <= ymaxgmis
        if (n1 & n2 & n3 & n4) {
            checkparameter$bbox <- TRUE
        }
        else {
            checkparameter$bbox <- FALSE
            print(paste("The selected area is not strickly inside the spatial extent of",
                name, "in GMIS"))
        }
    }
    if (apply(checkparameter, 1, sum) == 4) {
        bbox <- paste(xmin, ymin, xmax, ymax, sep = ",")
        con <- paste(gmis_wcst_url, "?TIME=", date, "&service=wcs&version=1.0.0&request=getcoverage&coverage=", name, "&crs=EPSG:4326&BBOX=", bbox, "&format=image/tiff&interpolation=nearest",  sep = "")
        nomfich <- paste(name, date, "img.tiff", sep = "_")
        nomfich <- tempfile(nomfich)
        download(con, nomfich, quiet = TRUE, mode = "wb")
        img <- raster(nomfich)
        img[img == 0] <- NA
        if (length(grep("log", data_gmis$unit[idvar], ignore.case = TRUE)) >
            0) {
            img <- 10^img
        }
        names(img) <- paste(name, date)
		print(con)
        return(img)
    }
}

#FUNCTION read_GMIS_wcst_data
#=========================================================================

read_gmis_wcst_data<-function (resolution = resolution, gmis_wcst_url = gmis_wcst_url)
{
    if (url.exists(gmis_wcst_url)) {
        doc <- xmlTreeParse(gmis_wcst_url, isURL = TRUE, encoding = "latin1")
        r <- xmlRoot(doc)
        nbvar <- xmlSize(r[[3]])
        carac <- data.frame(source = rep(unlist(r[[1]][[2]])[3],
            nbvar), resolution, name = NA, shortname = NA, unit = NA,
            bbox = NA, startdate = NA, enddate = NA)
        for (i in 1:nbvar) {
            carac$unit[i] <- unlist(r[[3]][[i]][[2]])[3]
            carac$shortname[i] <- unlist(r[[3]][[i]][[3]])[3]
            carac$name[i] <- unlist(r[[3]][[i]][[4]])[3]
            carac$bbox[i] <- gsub("\n", ",", paste(unlist(r[[3]][[i]][[5]])[5],
                unlist(r[[3]][[i]][[5]])[9], collapse = "\n"))
            tps <- unlist(r[[3]][[i]][[5]])
            tps <- as.vector(tps[names(tps) == "children.timePosition.children.text.value"])
            tps <- strptime(paste(tps, "15", sep = "-"), "%Y-%m-%d")
            carac$startdate[i] <- format(min(tps, na.rm = T),
                "%Y-%m")
            carac$enddate[i] <- format(max(tps, na.rm = T), "%Y-%m")
        }
    }
    else {
        print("no internet connection or GMIS server down")
        carac <- data.frame(source = NA, name = NA, shortname = NA,
            unit = NA, bbox = NA, time = NA)
    }
    return(carac)
}

#EXTRACTION of the MODIST SST
#================================================================
name <- "GMIS_T_SST"
resolution <- "4km"
startdate <- "2001-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "oC"
logscale <- FALSE

mpa_sst<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the PRIMARY PRODUCTION
#================================================================
name <- "GMIS_A_PPR"
resolution <- "4km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "mg m-2 day-1"
logscale <- FALSE

mpa_ppr<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the SALINITY
#================================================================
name <- "GMIS_C_SALI"
resolution <- "28km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- ".0001"
logscale <- FALSE

mpa_salinity<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the CHLA
#================================================================
name <- "GMIS_A_CHLA"
resolution <- "4km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "mg.m-3"
logscale <- TRUE

mpa_chla<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the KD443
#================================================================
name <- "GMIS_A_K490"
resolution <- "4km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "m^-1"
logscale <- TRUE

mpa_kd443<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the Surface oxygene
#================================================================
name <- "GMIS_O_OXYG"
resolution <- "28km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "mmol m-3"
logscale <- FALSE

mpa_oxygene<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the Surface bbp
#================================================================
name <- "GMIS_A_BBP"
resolution <- "4km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "m^-1"
logscale <- FALSE

mpa_bbp<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)

#EXTRACTION of the Surface adg
#================================================================
name <- "GMIS_A_ADG"
resolution <- "4km"
startdate <- "1998-01"
enddate <- "2018-12"
gmis_wcst_url <- "http://mapserver.marine-analyst.eu/webservices/4km/wcs-t"
unite <- "m^-1"
logscale <- FALSE

mpa_adg<-mpaextract(name = name, resolution = resolution, gmis_wcst_url = gmis_wcst_url, startdate = startdate, enddate =enddate, xmin = extent(mpa)@xmin-1, xmax = extent(mpa)@xmax+1, ymin = extent(mpa)@ymin-1, ymax = extent(mpa)@ymax+1)


SIM.para <- matrix(rnorm(100,0,1), ncol=10)
SIM.para[,1] <-c(1:10)
params <- SIM.para[jobID+1,]

###write.table(rate.1,paste("SIMULATION.K/",5,"_SM.T4.L.5.txt",sep=""),row.names=FALSE,col.names=FALSE,sep="\t",quote=FALSE)
write.table(params,"result.txt",sep="\t")


context("regionCounts checks")

myobj=read( system.file("extdata", "test1.myCpG.txt", package = "methylKit"),
                sample.id="test1",assembly="hg18",pipeline="amp")

library(GenomicRanges)

promoters=GRanges(seqnames=c("chr21","chr21"),
                             ranges=IRanges(start=c(17806094,1011979),end=c(17808094,10121796)),strand=c("+","-") )

test_that("check that regionCounts on methylRaw works", {
    expect_that( regionCounts(myobj,promoters),
        is_a('methylRaw'))
})

data(methylKit)
test_that("check that tileMethylCounts on methylBase works", {
  expect_that( tileMethylCounts(object=methylBase.obj,win.size=1000,step.size=1000,cov.bases=0) ,
  is_a('methylBase'))
})


##
#  Copyright (c) 2010-2011 LabKey Corporation
#
#  Licensed under the Apache License, Version 2.0: http://www.apache.org/licenses/LICENSE-2.0
##

# This R script will calculate and store inbreeding coefficients for all animals in the colony.  This data will be compared against
# the information currently stored in the DB and the minimal number of inserts/updates/deletes are then performed.  This script is designed
# to run as a daily cron job.

# When the script runs it outputs the log to /usr/local/labkey/kinship/inbreedingOut.txt.  This file is monitored by monit and an alert will be through
# if the timestamp does not change once per day.  This monitors whether the script is running, but does not directly monitor for errors.

options(echo=FALSE);
options(expressions = 1000);
library(pedigree)
library(Rlabkey)

#NOTE: to run directly in R instead of through labkey, uncomment this:
labkey.url.base = "https://ehr.primate.wisc.edu/"

#this section queries labkey to obtain the pedigree data
#you could replace it with a command that loads from TSV if you like
df <- labkey.selectRows(
    baseUrl=labkey.url.base,
    folderPath="/WNPRC/EHR",
    schemaName="study",
#NOTE: querying demographics will return a subset of all pedigree data
#comment that line and uncomment the line below to return the full table of pedigree data
#    queryName="Demographics",
    queryName="Pedigree",
    colSelect=c('Id', 'dam', 'sire'),
    showHidden = TRUE,
    colNameOpt = 'fieldname',  #rname
)

colnames(df)<-c("id", "dam", "sire")
df <-data.frame(id=df$id, dam=df$dam, sire=df$sire)

#this is an error-checking function in the pedigree package.  i do not know much about it
errors.ped(df)

#this is a function in the pedigree package designed to add missing parents to the dataframe
#see pedigree package documentation for more detail
df <- add.Inds(df);

#use an existing package to calculate inbreeding
ib = calcInbreeding(df);
colnames(df)<-c("id", "dam", "sire")

#we set date=now() as a timestamp
#the purpose of this is so we have a record when we save to the DB of when this was calculated.
date <- as.character( date() );
newRecords <- data.frame(Id=as.character(df$id), coefficient=ib, date=c(date), stringsAsFactors=FALSE);

#in the next sections we will compare the newly created dataframe to the data already in the DB
#the first time this script is run, the DB will be blank
#on subsequent runs, we perform these steps to minimize the amount of add/deletes against this data

#find old records first by querying labkey
#this can be replaced with a TSV load for testing if needed
oldRecords <- labkey.selectRows(
    baseUrl=labkey.url.base,
    folderPath="/WNPRC/EHR",
    schemaName="study",
    queryName="inbreeding",
    colSelect=c('lsid', 'Id', 'date', 'coefficient'),
    showHidden = TRUE,
    colNameOpt = 'fieldname'  #rname
)
#str(oldRecords);
#str(newRecords);

#first we find any cases where an Id existing in oldRecords, but not newRecords.  These need to be deleted
IdxToDelete <- setdiff(oldRecords$Id, newRecords$Id);
toDelete <- oldRecords[match(IdxToDelete, oldRecords$Id),]

#delete any animals present in the inbreeding table, but not the dataframe
print("To Delete: ")
length(toDelete$Id)

if(length(toDelete$Id)){
#during testing, i suggest just verifying that the script is working as expected
#without actually running the delete command

    del <- labkey.deleteRows(
        baseUrl=labkey.url.base,
        folderPath="/WNPRC/EHR",
        schemaName="study",
        queryName="inbreeding",
        toDelete=data.frame(lsid=toDelete$lsid)
    );
}

#next we find any cases where an Id exists in both oldRecords and newRecords, but the coefficient is different.
#These need to be updated

IdxToUpdate <- intersect(oldRecords$Id, newRecords$Id);
coefficient1 <- oldRecords[match(IdxToUpdate, oldRecords$Id),]
coefficient2 <- newRecords[match(IdxToUpdate, newRecords$Id),]

toGet <- (!is.na(coefficient1$coefficient) & is.na(coefficient2$coefficient)) | (is.na(coefficient1$coefficient) & !is.na(coefficient2$coefficient)) | (!is.na(coefficient1$coefficient) & !is.na(coefficient2$coefficient) & coefficient1$coefficient != coefficient2$coefficient)
toUpdate <- coefficient1[toGet,];

toUpdate$coefficient <- coefficient2$coefficient[toGet];

print("To Update: ")
length(toUpdate$Id)

if(length(toUpdate$Id)){
#during testing, i suggest just verifying that the script is working as expected
#without actually running the update command

    #change the date to reflect today's date
    toUpdate$date <- c( as.character( date() ) );

    update <- labkey.updateRows(
        baseUrl=labkey.url.base,
        folderPath="/WNPRC/EHR",
        schemaName="study",
        queryName="inbreeding",
        toUpdate=toUpdate
    );
}

#next we find any cases where an Id exists in newRecords, but not oldRecords.
#These need to be inserted

IdxToInsert <- setdiff(newRecords$Id, oldRecords$Id);
toInsert <- newRecords[match(IdxToInsert, newRecords$Id),]
#str(toInsert)

print("To Insert: ")
length(toInsert$Id)

if(length(toInsert$Id)){
#during testing, i suggest just verifying that the script is working as expected
#without actually running the insert command

    ins <- labkey.insertRows(
        baseUrl=labkey.url.base,
        folderPath="/WNPRC/EHR",
        schemaName="study",
        queryName="inbreeding",
        toInsert=toInsert
    );
}


# takes g_inputdir,g_filetable and g_outputdir
##and g_duration_slider, g_bin_size
# return activity plots

message("starting activity.r - corrected for experimental length")
### compute the activities

act_table = data.frame()

#compute activities for each individum
for (i in c(1:nrow(id_table))) {
	act = c.activity_speed(traj[id(traj)==id_table$id[i]],g_duration_slider/10)
	act_id = rep(id_table$id[i],nrow(act))
	act_group = rep(id_table$group[i],nrow(act))
	act_table = rbind(act_table,data.frame(act,id=act_id,group=act_group))

}

# filter activities which are smaller than the act slider
act_table_ori = act_table
pause_table = act_table[act_table$act<0,]
pause_table$pause = - pause_table$act
act_table_2 = act_table_ori[act_table_ori$act>g_duration_slider/10*4,]
act_table = act_table_ori[act_table_ori$act>0,]

#print(head(act_table_ori))

#calculation of linearity of curve for each bout
#########################
#act_table$lin = sqrt( (act_table$Xe-act_table$Xs)^2+(act_table$Ye-act_table$Ys)^2)/act_table$dist_traveled

#print(head(act_table))

### get rid of act of lenght 1
act_table_choice = act_table[act_table$dist_traveled>10,]
#print(head(act_table))

#calculate total activity time for each individual
sum_act = c()
#sum_act2 =c()
sum_act_choice =c()
median_act = c()
 #median_act2 = c()
 median_act_choice = c()
median_pause = c()
number_pause = c()
median_lin = c()
mean_lin = c()
ppause = c()
for (i in c(1:nrow(id_table))) {
	act = act_table[act_table$id==id_table$id[i],]$act
 #act2= act_table_2[act_table_2$id==id_table$id[i],]$act
 act_choice= act_table_choice[act_table_choice$id==id_table$id[i],]$act
	pause = pause_table[pause_table$id==id_table$id[i],]$pause
	lin = act_table_choice[act_table_choice$id==id_table$id[i],]$lin
    ppause = c(ppause,pause)
	sum_act = c(sum_act,sum(act))
 #sum_act2 =c(sum_act2, sum(act2))
 sum_act_choice=c(sum_act_choice, sum(act_choice))
	median_act = c(median_act,median(act))
 #median_act2 = c(median_act2,median(act2))
 median_act_choice = c(median_act_choice,median(act_choice))
	median_pause = c(median_pause, median(abs(pause)))
	number_pause = c(number_pause,length(pause))
	median_lin = c(median_lin, quantile(lin, probs =0.25, na.rm=TRUE))

}
# act_table_2_2 = data.frame(sumact1=sum_act,#sumact_longtime=sum_act2,
                           # sumact_dist=sum_act_choice,
                           # median_act2=median_act,#median_act_longtime=median_act2,
                           # median_act_dist=median_act_choice,
                           # median_pause2=median_pause,number_pause2=number_pause,median_lin2= median_lin,id=id_table$id,group=id_table$group)

number_pause=number_pause/f_table$length_experiment
sum_act=sum_act/f_table$length_experiment

f_table=data.frame(f_table,activitytime_permin_TT=sum_act,
                   act_bouts_TT=median_act,
                   pause_length_TT=median_pause,
                   numb_pauses_permin_TT= number_pause)

f_table_positive=data.frame(f_table_positive,activitytime_permin_TT=sum_act,
                   act_bouts_TT=median_act,
                   pause_length_TT=median_pause,
                   numb_pauses_permin_TT= number_pause)

message("starting writing activities log.txt")

setwd(rgghome)

# if (g_bin_size==0)
	# {g_bin_size = 0.5}

# v = act_table$act
# bins = seq(min(v[!is.na(v)])-g_bin_size,max(v[!is.na(v)])+g_bin_size,g_bin_size)

# #create mean and sd table
# mean_table = create.mean.table(act_table_2_2,group_ids,data_cols=1:7)

# message("starting plots activity")
# ### create plots
# mybarplot(mean_table$means$sumact1,mean_table$ses$sumact1,rownames(mean_table$means),
	# main="Total activity time",ylab="Total activity time [s]", ylim= c(0,ylim_acttime))

# # mybarplot(mean_table$means$sumact_longtime,mean_table$ses$sumact_longtime,rownames(mean_table$means),
# #  main="Total activity time, activity bouts>g_duration_slider/10*4",ylab="Total activity time [s]", ylim= c(0,ylim_acttime))

# mybarplot(mean_table$means$sumact_dist,mean_table$ses$sumact_dist,rownames(mean_table$means),
  # main="Total activity time, bouts distance > 10mm",ylab="Total activity time [s]", ylim= c(0,ylim_acttime))
# #####
# mybarplot(mean_table$means$median_act2,mean_table$ses$median_act2,rownames(mean_table$means),
	# main="Mean of medians of bouts duration",ylab="median of bouts length [s]",ylim = c(0,5))

# ##  mybarplot(mean_table$means$median_act_longtime,mean_table$ses$median_act_longtime,rownames(mean_table$means),
# ##  main="Mean of medians of bouts length bouts >g_duration_slider/10*4",ylab="median of bouts length [s]",ylim = c(0,20))

# mybarplot(mean_table$means$median_act_dist,mean_table$ses$median_act_dist,rownames(mean_table$means),
  # main="Mean of medians of bouts duration bouts >10mm",ylab="median of bouts length [s]",ylim = c(0,10))
# #####

# mybarplot(mean_table$means$number_pause,mean_table$ses$number_pause,rownames(mean_table$means),
	# main="Number of pauses threshold",ylab="Number of pauses", ylim = c(0,ylim_pauses))

# mybarplot(mean_table$means$median_pause,mean_table$ses$median_pause,rownames(mean_table$means),
	# main="Mean of medians of pause duration",ylab="Median pause time [s]", ylim =c(0, ylim_pausetime))

# mybarplot(mean_table$means$median_lin,mean_table$ses$median_lin,rownames(mean_table$means),
	# main="Mean of low quartile of linearity score",ylab="Lin score [0 to 1]", ylim =c(0, 1))

# #
# #bins = 0.05
# #hplot1 = hist(act_table$lin,breaks= c(seq(0,1, bins)), plot=FALSE)
# #
# #print(plot(hplot1, xlim=c(0,1),freq = FALSE))
# #
# #bins = 0.11
# #
# #hplot4 = hist(act_table$act,breaks= c(seq(0,max(act_table$act)+bins*5, bins*5)), plot=FALSE)
# #print(plot(hplot4, freq = FALSE, xlim=c(0,100)))
# #
# #
# #
# #plot (act_table$lin, act_table$dist_traveled, ylim =c(0,1000))
# #
# #plot (act_table$lin, act_table$dist_traveled, ylim =c(0,35))
# #
# #plot (act_table_ori$speedmax_inbout, act_table_ori$dist_traveled)
# #hist(act_table_ori$speedmax_inbout)

# ########

# #
# # tail(act_table[act_table$lin==1,])
# # hist(act_table_choice$dist_traveled[act_table_choice$group=="real_fly"], breaks= 800, xlim= c(0,50))
# # act_table_choice2=subset(act_table_choice,act_table_choice$group=="real_fly")
# # plot(act_table_choice2$dist_traveled,act_table_choice2$lin)
# # abline( h=quantile(act_table_choice2$lin, probs =0.25, na.rm=TRUE), col=2)
# #act_table$bla= (sqrt( (act_table$Xe-act_table$Xs)^2+(act_table$Ye-act_table$Ys)^2))
# #plot((act_table$bla) ~act_table$group)
# #hist(act_table$bla)


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)

source("utils/arg-parser.r")
source("utils/read-covariates.r")
source("utils/ifr-tools.r")
source("utils/log-and-process.r")

regions <- read_country_file("active-regions.cfg")
active_countries <- read_country_file("active-countries.cfg")

region_to_country_map = list()
for(Region in regions){
  region_to_country_map[[Region]] <- "France"
}
for(Country in active_countries){
  region_to_country_map[[Country]] <- Country
}

# Commandline options and parsing
parsedargs <- base_arg_parse()
DEBUG <- parsedargs[["DEBUG"]]
FULL_RUN <- parsedargs[["FULL"]]
StanModel <- parsedargs[["StanModel"]]
new_sub_folder <- parsedargs[["new_sub_folder"]]

JOBID = Sys.getenv("PBS_JOBID")
if(JOBID == "")
  JOBID = as.character(abs(round(rnorm(1) * 1000000)))
print(sprintf("Jobid = %s",JOBID))
fullstr <- ""
if (FULL_RUN){
  fullstr <- "fullrun"
} else if (DEBUG) {
  fullstr <- "debug"
}

run_name <- paste0(StanModel,'-',fullstr,'-', format(Sys.time(), '%Y%m%dT%H%M%S'),'-',JOBID)
if (new_sub_folder){
  result_folders <- c(
      "results", "figures"
    )
  for (fold in result_folders){
    dir.create(paste0(fold ,'/', run_name))
  }
  run_name <- paste0(run_name ,'/', run_name)
}
## Reading data from region file and world data
data_files <- c(
  "data/COVID-19-up-to-date.rds",
  "data/all-france.rds"
)
d <- do.call('rbind', lapply(data_files, readRDS))

## get IFR and population from same file

serial.interval = read.csv("data/serial_interval.csv")
ifr.by.country <- return_ifr()
covariates <- covariates_read('data/interventions.csv')

forecast = 0
N2 = 120 # increase if you need more forecast Max is 100 at the moment

dates = list()
reported_cases = list()
# Pads serial interval with 0 if N2 is greater than the length of the serial
# interval array
if (N2 > length(serial.interval$fit)) {
  pad_serial.interval <- data.frame(
    "X"=(length(serial.interval$fit)+1):N2,
    "fit"=rep(0.0, max(N2-length(serial.interval$fit), 0 ))
  )
  serial.interval = rbind(serial.interval, pad_serial.interval)
}
stan_data = list(
  M=length(names(region_to_country_map)),N=NULL,covariate1=NULL,
  covariate2=NULL,covariate3=NULL,covariate4=NULL,covariate5=NULL,
  covariate6=NULL,deaths=NULL,f=NULL,N0=6,cases=NULL,
  SI=serial.interval$fit[1:N2],
  EpidemicStart = NULL, pop = NULL) # N0 = 6 to make it consistent with Rayleigh
deaths_by_country = list()

# various distributions required for modeling
infection_to_onset <- c("mean"=5.1, "deviation"=0.86)
onset_to_death <- c("mean"=18.8, "deviation"=0.45)
# infection-to-onset distribution
x1 = rgammaAlt(1e7,infection_to_onset["mean"], infection_to_onset["deviation"])
# onset-to-death distribution
x2 = rgammaAlt(1e7,onset_to_death["mean"], onset_to_death["deviation"])

ecdf.saved = ecdf(x1+x2)

log_simulation_inputs(run_name, region_to_country_map,  ifr.by.country,
  infection_to_onset, onset_to_death)

for(Region in names(region_to_country_map))
{
  Country = region_to_country_map[[Region]]
  print(sprintf("Region: %s in country: %s ",Region,Country))
  IFR=ifr.by.country$ifr[ifr.by.country$country == Country]

  covariates1 <- covariates[covariates$Country == Country, c(2,3,4,5,6)]

  d1_pop = ifr.by.country[ifr.by.country$country==Country,]
  d1=d[d$Countries.and.territories==Region,c(1,5,6,7)]
  d1$date = as.Date(d1$DateRep,format='%d/%m/%Y')
  d1$t = decimal_date(d1$date)
  d1=d1[order(d1$t),]
  if(length(d1$date) == 0){
    stop(sprintf(
      "Region %s in country %s had no data (d1 length(d1)==0)", region, Country))
  }
  date_min <- dmy('31/12/2019')
  if (as.Date(d1$DateRep[1], format='%d/%m/%Y') > as.Date(date_min, format='%d/%m/%Y')){
    print(paste(Region,'In padding'))
    pad_days <- as.Date(d1$DateRep[1], format='%d/%m/%Y') - date_min
    pad_dates <- date_min + days(1:pad_days[[1]]-1)
    padded_data <- data.frame("Countries.and.territories" = rep(Region, pad_days),
                              "DateRep" = format(pad_dates, '%d/%m/%Y'),
                              "t" = decimal_date(as.Date(pad_dates,format='%d/%m/%Y')),
                              "date" = as.Date(pad_dates,format='%d/%m/%Y'),
                              "Cases" = as.integer(rep(0, pad_days)),
                              "Deaths" = as.integer(rep(0, pad_days)),
                              stringsAsFactors=F)

    d1 <- bind_rows(padded_data, d1)
  }
  index = which(d1$Cases>0)[1]
  index1 = which(cumsum(d1$Deaths)>=10)[1] # also 5
  index2 = index1-30

  print(sprintf("First non-zero cases is on day %d, and 30 days before 10 deaths is day %d",index,index2))
  d1=d1[index2:nrow(d1),]
  stan_data$EpidemicStart = c(stan_data$EpidemicStart,index1+1-index2)
  stan_data$pop = c(stan_data$pop, d1_pop$popt)

  for (ii in 1:ncol(covariates1)) {
    covariate = names(covariates1)[ii]
    d1[covariate] <- (as.Date(d1$DateRep, format='%d/%m/%Y') >= as.Date(covariates1[1,covariate]))*1  # should this be > or >=?
  }

  dates[[Region]] = d1$date
  # hazard estimation
  N = length(d1$Cases)
  print(sprintf("%s has %d days of data",Region,N))
  forecast = N2 - N
  if(forecast < 0) {
    print(sprintf("%s: %d", Country, N))
    print("ERROR!!!! increasing N2 to have at least 7 days")
    N2 = N
    forecast = N2 - N
  }

  # IFR is the overall probability of dying given infection
  convolution = function(u) (IFR * ecdf.saved(u))

  f = rep(0,N2) # f is the probability of dying on day i given infection
  f[1] = (convolution(1.5) - convolution(0))
  for(i in 2:N2) {
    f[i] = (convolution(i+.5) - convolution(i-.5))
  }

  reported_cases[[Region]] = as.vector(as.numeric(d1$Cases))
  deaths=c(as.vector(as.numeric(d1$Deaths)),rep(-1,forecast))
  cases=c(as.vector(as.numeric(d1$Cases)),rep(-1,forecast))
  deaths_by_country[[Region]] = as.vector(as.numeric(d1$Deaths))
  covariates2 <- as.data.frame(d1[, colnames(covariates1)])
  # x=1:(N+forecast)
  covariates2[N:(N+forecast),] <- covariates2[N,]

  ## append data
  stan_data$N = c(stan_data$N,N)
  # stan_data$x = cbind(stan_data$x,x)
  stan_data$covariate1 = cbind(stan_data$covariate1,covariates2[,1])
  stan_data$covariate2 = cbind(stan_data$covariate2,covariates2[,2])
  stan_data$covariate3 = cbind(stan_data$covariate3,covariates2[,3])
  # stan_data$covariate4 is an "any" covariates marker calculated below
  stan_data$covariate4 = cbind(stan_data$covariate4,covariates2[,4])
  stan_data$covariate5 = cbind(stan_data$covariate5,covariates2[,4])
  stan_data$covariate6 = cbind(stan_data$covariate6,covariates2[,5])
  stan_data$f = cbind(stan_data$f,f)
  stan_data$deaths = cbind(stan_data$deaths,deaths)
  stan_data$cases = cbind(stan_data$cases,cases)

  stan_data$N2=N2
  stan_data$x=1:N2
  if(length(stan_data$N) == 1) {
    stan_data$N = as.array(stan_data$N)
  }
}

# create the `any intervention` covariate
stan_data$covariate4 = 1*as.data.frame((stan_data$covariate1+
                                          stan_data$covariate2+
                                          stan_data$covariate3+
                                          stan_data$covariate5+
                                          stan_data$covariate6) >= 1)

if(DEBUG) {
  for(i in 1:length(region_to_country_map)) {
    write.csv(
      data.frame(date=dates[[i]],
                 `school closure`=stan_data$covariate1[1:stan_data$N[i],i],
                 `self isolating if ill`=stan_data$covariate2[1:stan_data$N[i],i],
                 `public events`=stan_data$covariate3[1:stan_data$N[i],i],
                 `government makes any intervention`=stan_data$covariate4[1:stan_data$N[i],i],
                 `lockdown`=stan_data$covariate5[1:stan_data$N[i],i],
                 `social distancing encouraged`=stan_data$covariate6[1:stan_data$N[i],i]),
      file=sprintf("results/%s%s-check-dates.csv",run_name, names(region_to_country_map)[i]),row.names=F)
  }
}

options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(paste0('stan-models/',StanModel,'.stan'))

if(DEBUG) {
  fit = sampling(m,data=stan_data,iter=40,warmup=20,chains=2)
} else if (FULL_RUN){
  fit = sampling(m,data=stan_data,iter=4000,warmup=2000,chains=4,thin=4,
    control = list(adapt_delta = 0.95, max_treedepth = 10))

} else {
  # uncomment the line below for a full run to replicate results and comment the second line below
  fit = sampling(m,data=stan_data,iter=200,warmup=100,chains=4,thin=4,
    control = list(adapt_delta = 0.95, max_treedepth = 10))
}

out = rstan::extract(fit)
prediction = out$prediction
estimated.deaths = out$E_deaths
estimated.deaths.cf = out$E_deaths0

save.image(paste0('results/',run_name,'.Rdata'))

countries <- names(region_to_country_map)
save(
  fit, prediction, dates,reported_cases,deaths_by_country,countries,
  region_to_country_map, estimated.deaths, estimated.deaths.cf,
  out,covariates,infection_to_onset, onset_to_death,
  file=paste0('results/',run_name,'-stanfit.Rdata'))

postprocess_simulation(run_name, out, countries, dates)


## Generates input data files for MESSAGE-Basin
## Some scripts need to run sequentially while others could be run in parallel
basin = 'Indus'
require( tictoc )

# Files ordered accordingly
files = c( 	'delineation',
			'renewable_exclusion_zones',
			'load_factor',
			'capacity_factor_final',
			'powerplants_historical_capacity',
			'fuel_cost',
			'storage_capacity',
			'demands',
			'water_connection',
			'diesel_pumps',
			'canal_transfers',
			'irrigation_transfers',
			'transmission',
			'water_table_depth',
			'freshwater_extraction',
			'water_resources',
			'land_use_maps',
			'crop_yields'
			)

res = lapply( files, function( fl ){

	print("##########################################")
	print( paste0( "Working on: ", fl ) )
	print("##########################################")

	setwd( Sys.getenv("INDUS_IX_PATH") ) # Local location of indus ix model - MAKE SURE TO ADD TO SYSTEM ENVIRONMENT VARIABLES

	tic()

	source(  paste0( 'input_data_scripts/', fl, '.r' ) )

	gc()

	h = toc()

	rr = paste0( as.character( round( unlist( h$toc-h$tic ) ) ), ' sec' )

	return( rr ) # return the time it takes to run each data processing script

	} )

names( res ) = files


library(ggplot2)

visualize_as_histogram <- function(corpus) {
    melted <- melt_and_group_columns(corpus)
    manifest <- corpus$manifest

    min <- get_property_value(manifest, "min")
    max <- get_property_value(manifest, "max")
    bin_size <- get_property_value(manifest, "bin-size")

    plot <- ggplot(melted, aes(x = value, col = variable, fill = variable)) +
        (
            if(!is.null(min) && !is.null(max) && !is.null(bin_size))
            geom_histogram(aes(y = stat(count / sum(count))), breaks = seq(min, max, by = bin_size), position="dodge", show.legend=!manifest['disable-legend'][[1]])
            else if(!is.null(bin_size))
            geom_histogram(binwidth = bin_size, position="dodge", show.legend=!manifest['disable-legend'][[1]])
            else
            geom_histogram(position="dodge", show.legend=!manifest['disable-legend'][[1]])
        ) +
        # geom_density(alpha=.7, show.legend=FALSE) +
        xlab(manifest['labels'][[1]]['x-axis']) +
        ylab(manifest['labels'][[1]]['y-axis']) +
        ggtitle(
            # eval(parse(text="expression(atop(bold('ok'),atop('ok')))"))
            eval(parse(text=paste('expression(
                atop(
                    bold(
                        ', manifest['labels'][[1]]['title'], '
                    ),
                    atop(
                        ', manifest['labels'][[1]]['subtitle'], '
                    )
                )
            )', sep='')))
        ) + theme(
            # axis.text.x = element_text(angle=-45, hjust=0, vjust=1),
            plot.title = element_text(size = 14, colour = "black", vjust = -1, hjust=0.5)
        )
        # scale_colour_discrete("Continents")
            # +
        # guides(
        #         color = guide_legend(
        #             override.aes = list(fill = NA)
        #         ),
        #         linetype = guide_legend(
        #             override.aes = list(fill = NA)
        #         )
        #     ) +
        # theme(
        #     legend.key = element_rect(fill = "white")
        # ) +
        # guides(fill="none") + # delete entries from legend which correspond to the bars fill color
        # scale_fill_discrete(name="Experimental\nCondition")

    custom_legend_properties = get_property_value(manifest, 'legend')
    if (!is.null(custom_legend_properties)) {
        # plot + scale_fill_discrete(name = "New Legend Title", fill = FALSE)
        custom_legend_title = get_property_value(custom_legend_properties, 'title')
        if (!is.null(custom_legend_title)) {
            plot + guides(fill = guide_legend(title=custom_legend_title)) + guides(col = "none")
        }
    }

    return(plot)
}


#------------------------------------------------------------------------------
#'	(Internal) model.interface class for svm
#'
#'	This reference class contains methods for \code{\link[e1071]{svm}} in
#'	\emph{e1071} package.
#'
#'	@include model.interface.default.r
#'	@name model.interface.svm-class (svm)
#------------------------------------------------------------------------------
model.interface.svm.class <- R6::R6Class(
	"model.interface.svm", inherit = model.interface.default.class
)

#------------------------------------------------------------------------------
#'	@method model.interface svm
#'	@export
#'	@describeIn model.interface S3 method for class 'svm'
#------------------------------------------------------------------------------
model.interface.svm <- model.interface.svm.class$new

#------------------------------------------------------------------------------
model.interface.svm.class$set(
	"public", "predict",
	function(object, newdata = NULL, type, ...) {
		if (is.null(newdata)) {
			pred <- stats::predict(
				object, predict.all = TRUE, probability = TRUE, ...
			)
		} else {
			pred <- stats::predict(
				object, newdata = newdata, predict.all = TRUE,
				probability = TRUE, ...
			)
		}
		if (type == "prob") {
			# If type is "prob", extract probability.
			pred <- attr(pred, "probabilities")
		}
		return(pred)
	}
)