####by Heather E. Wheeler 20150209####
args <- commandArgs(trailingOnly=T)
#args <- c('21','0.0001')
date <- Sys.Date()
"%&%" = function(a,b) paste(a,b,sep="")
###############################################
### Directories & Variables
pre <- "/group/im-lab/nas40t2/hwheeler/"

my.dir <- pre %&% "PrediXcan_CV/"
ct.dir <- pre %&% "PrediXcan_CV/cis.v.trans.prediction/"
gt.dir <- pre %&% "PrediXcan_CV/GTEx_2014-06013_release/transfers/PrediXmod/DGN-WB/DGN-imputation/DGN-imputed-for-PrediXcan/"
en.dir <- pre %&% "PrediXcan_CV/GTEx_2014-06013_release/transfers/PrediXmod/DGN-WB/DGN-calc-weights/DGN-WB_weights/"

tis <- "DGN-WB"
k <- 10 ### k-fold CV
chrom <- as.numeric(args[1])
chrname <- "chr" %&% chrom
pthresh <- as.numeric(args[2]) ##p-vaule threshold to test in CV

################################################
### Functions & Libraries

stderr <- function(x) sqrt(var(x,na.rm=TRUE)/length(x))
lower <- function(x) quantile(x,0.025,na.rm=TRUE)
upper <- function(x) quantile(x,0.975,na.rm=TRUE)

## fit betas by Vasa edited by Heather to get pvals
fit.betas <- function(G, Y) {
require(RcppGSL)
betas <- rep(NA, ncol(G))
stderrs <- rep(NA, ncol(G))
dfs <- rep(NA, ncol(G))
for (i in 1:ncol(G)) {
res <- fastLmPure(y=Y, X=matrix(G[,i]))
betas[i] <- res$coefficients
stderrs[i] <- res$stderr
dfs[i] <- res$df
}
t <- betas/stderrs
pvals <- 2*pt(-abs(t),df=dfs)
output <- cbind(betas,pvals)
return(output)
}

################################################
###input adjusted expression data###
rpkmid <- ct.dir %&% tis %&% ".exp.ID.list"
expid <- scan(rpkmid,"character")
rpkmgene <- ct.dir %&% tis %&% ".exp.GENE.list"
geneid <- scan(rpkmgene,"character")
rpkmfile <- ct.dir %&% tis %&% ".exp.IDxGENE"
expdata <- scan(rpkmfile)
expdata <- matrix(expdata, ncol = length(geneid), byrow=TRUE)
rownames(expdata) <- expid
colnames(expdata) <- geneid

t.expdata <- expdata #don't need to transpose DGN

gencodefile <- my.dir %&% 'gencode.v12.V1.summary.protein.nodup.genenames'
gencode <- read.table(gencodefile)
rownames(gencode) <- gencode[,6]
gencode <- gencode[gencode[,1]==chrname,] ##pull genes on chr of interest
t.expdata <- t.expdata[,intersect(colnames(t.expdata),rownames(gencode))] ###pull gene expression data w/gene info

expsamplelist <- rownames(t.expdata) ###samples with exp data###

bimfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8.hapmapSnpsCEU.chr" %&% chrom %&% ".bim" ###get SNP position information###
bim <- read.table(bimfile)
rownames(bim) <- bim$V2

famfile <- gt.dir %&% "DGN.imputed_maf0.05_R20.8.hapmapSnpsCEU.ID.list" ###samples with imputed gt data###
fam <- scan(famfile,"character")
samplelist <- intersect(fam,expsamplelist)

exp.w.geno <- t.expdata[samplelist,] ###get expression of samples with genotypes###
explist <- colnames(exp.w.geno)

gtfile <- gt.dir %&% 'DGN.imputed_maf0.05_R20.8.hapmapSnpsCEU.chr' %&% chrom %&% '.SNPxID'
gtX <- scan(gtfile)
gtX <- matrix(gtX, ncol = length(fam), byrow=TRUE)
colnames(gtX) <- fam
rownames(gtX) <- bim$V2
X <- gtX[,samplelist]

X <- t(X) #transpose to match code below (one ID per row)

###create results array
resultsarray <- array(NA,c(length(explist),5))
dimnames(resultsarray)[[1]] <- explist
resultscol <- c("gene","Pthresh","n.snps","CV.R2","CV.pval")
dimnames(resultsarray)[[2]] <- resultscol
workingbest <- "working_" %&% tis %&% "_exp_" %&% k %&% "-foldCV_polyscore_Pthresh" %&% pthresh %&% "_imputedSNPs_chr" %&% chrom %&% "_" %&% date %&% ".txt"
write(resultscol,file=workingbest,ncolumns=5,sep="\t")

weightcol = c("gene","SNP","refAllele","effectAllele","beta")
workingweight <- en.dir %&% tis %&% "_polyscore_Pthresh" %&% pthresh %&% "_weights_chr" %&% chrom %&% "_" %&% date %&% ".txt"
write(weightcol,file=workingweight,ncol=5,sep="\t")

###run polyscore CV

set.seed(1001)

for(i in 1:length(explist)){
  cat(i,"/",length(explist),"\n")
  gene <- explist[i]
  geneinfo <- gencode[gene,]
  chr <- geneinfo[1]
  c <- substr(chr$V1,4,5)
  start <- geneinfo$V3 - 1e6 ### 1Mb lower bound for cis-eQTLS
  end <- geneinfo$V4 + 1e6 ### 1Mb upper bound for cis-eQTLs
  chrsnps <- subset(bim,bim[,1]==c) ### pull snps on same chr
  cissnps <- subset(chrsnps,chrsnps[,4]>=start & chrsnps[,4]<=end) ### pull cis-SNP info
  cisgenos <- X[,intersect(colnames(X),cissnps[,2])] ### pull cis-SNP genotypes
  if(is.null(dim(cisgenos))){
    ###effectively skips genes with <2 cis-SNPs
    resinfo <- c(gene,pthresh,"no.cis.snps",NA,NA)
    resultsarray[gene,] <- resinfo
  }else{
    minorsnps <- subset(colMeans(cisgenos), colMeans(cisgenos,na.rm=TRUE)>0) ###pull snps with at least 1 minor allele###
    minorsnps <- names(minorsnps)
    cisgenos <- cisgenos[,minorsnps]
    cisgenos <- scale(cisgenos, center=T, scale=T)
    cisgenos[is.na(cisgenos)] <- 0
    if(is.null(dim(cisgenos)) | dim(cisgenos)[2] == 0){###effectively skips genes with <2 cis-SNPs
      ###effectively skips genes with <2 cis-SNPs
      resinfo <- c(gene,pthresh,"no.cis.snps",NA,NA)
      resultsarray[gene,] <- resinfo
    }else{
      exppheno <- exp.w.geno[,gene] ### pull expression data for gene
      exppheno <- scale(exppheno, center=T, scale=T)  ###need to scale for fastLmPure to work properly
      exppheno[is.na(exppheno)] <- 0
      rownames(exppheno) <- rownames(exp.w.geno)

      ### run k-fold CV

      ###randomize samples into CV groups
      samplelength <- length(exppheno)
      g <- 1:k ##k-fold CV
      groupid <- sample(g,samplelength,replace=T)
      newiddata <- data.frame(groupid,samplelist)

      ### create empty matrix to fill in with polyscore vals
      cvset <- data.frame(samplelist,matrix(NA,samplelength,1),exppheno)
      rownames(cvset) <- samplelist
      names(cvset) <- c("ID","Pred","Exp")
      for(idsubset in 1:k){
        trainset <- data.frame(newiddata$samplelist[newiddata$groupid != idsubset])
        testset <- data.frame(newiddata$samplelist[newiddata$groupid == idsubset])
        ### pull trainset genos and phenos
        traingenos <- cisgenos[intersect(trainset[,1],rownames(cisgenos)),]
        trainexp <- exppheno[match(trainset[,1],rownames(exppheno))]  ###if scaled, use rownames
        ### calculate betas and pvals from training set
        betares <- fit.betas(traingenos,trainexp)
        rownames(betares) <- colnames(traingenos)
        topres <- subset(betares,betares[,2] < pthresh) ###pull snps with P < pthresh
        betas <- topres[,1]
        if(length(betas) <= 1){
          names(betas) <- rownames(topres)
        }
        ### polyscore
        ### multiply betas by test genotypes and take sum
        testgenos <- cisgenos[intersect(testset[,1],rownames(cisgenos)),intersect(names(betas),colnames(cisgenos))]
        if(is.array(testgenos)=='FALSE'){ ### calcs polyscore if only one individual in test set, happens when expression sample size is low (<100)
          if(dim(testset)[1] < 2){ ### calcs polyscore if only one individual in test set, happens when expression sample size is low (<100)
            pred.polyscore <- sum(testgenos * betas)
            names(pred.polyscore)<-testset[,1]
          }else{ ### calcs polyscore if only one beta with p<pthresh
            pred.polyscore <- testgenos * betas
          }
          cvset$Pred[match(names(pred.polyscore),rownames(cvset))] <- pred.polyscore
        }else{
       	  testsweep <- sweep(testgenos, 2, betas, "*")
          pred.polyscore <- as.vector(rowSums(testsweep))
          names(pred.polyscore) <- rownames(testsweep)
          ### add predictions to cvset
          cvset$Pred[match(names(pred.polyscore),rownames(cvset))] <- pred.polyscore
        }
      }

      ### output bestbetas for PrediXcan
      allbetares <- fit.betas(cisgenos,exppheno) ###~30sec/gene
      rownames(allbetares) <- colnames(cisgenos)
      alltopres <- subset(allbetares,allbetares[,2] < pthresh) ###pull snps with P < pthresh
      allbetas <- alltopres[,1]
      nallbetas <- length(allbetas)
      if(nallbetas <= 1){
        names(allbetas) <- rownames(alltopres)
      }
      if(nallbetas==0){
        ### calculate correlation between predicted and observed expression
        res<-summary(lm(cvset$Pred~cvset$Exp))
        resinfo <- c(gene,pthresh,nallbetas,res$r.squared,res$coef[2,4])
        resultsarray[gene,] <- resinfo
      }else{
        allbetalist <- names(allbetas)
        allbetainfo <- bim[allbetalist,]
        betatable <- as.matrix(cbind(allbetainfo,alltopres))
        betafile<-cbind(gene,betatable[,2],betatable[,5],betatable[,6],betatable[,7]) ##output "gene","SNP","refAllele","effectAllele","beta"
        write(t(betafile),file=workingweight,ncolumns=5,append=T,sep="\t") # t() necessary for correct output from write() function

        ### calculate correlation between predicted and observed expression
        res<-summary(lm(cvset$Pred~cvset$Exp))
        resinfo <- c(gene,pthresh,nallbetas,res$r.squared,res$coef[2,4])
        resultsarray[gene,] <- resinfo
      }
    }
  }
  write(resultsarray[gene,],file=workingbest,ncolumns=5,append=T,sep="\t")
}

write.table(resultsarray,file=tis %&% "_exp_" %&% k %&% "-foldCV_polyscore_Pthresh" %&% pthresh %&% "_imputedSNPs_chr" %&% chrom %&% "_" %&% date %&% ".txt",quote=F,row.names=F,sep="\t")


# cabal2nix/doc/analyze-hydra-builds.r
#
# Generate the input file "builds.csv" by running
#
#     sudo -u hydra psql -c "Copy (select b.project, b.jobset, b.job, b.timestamp, b.drvpath, b.system, b.buildstatus, b.size, b.closuresize, bs.type, bs.starttime, bs.stoptime, bs.machine from builds b left join buildsteps bs on b.id=bs.build and b.drvpath=bs.drvpath where finished=1 and iscachedbuild=0) to stdout With CSV HEADER;" >builds.csv
#
# on Hydra.

library(data.table)

builds <- within(as.data.table(read.csv("builds.csv", header=T, stringsAsFactors=T)), {
    timestamp <- as.POSIXct(timestamp, origin="1970-01-01")
    starttime <- as.POSIXct(starttime, origin="1970-01-01")
    stoptime <- as.POSIXct(stoptime, origin="1970-01-01")
    runtime <- difftime(stoptime, starttime, units="mins")
    machine <- sub("^(hydra|root)@", "", machine)
})
builds[machine=="", machine:="localhost"]
setkey(builds, project, jobset, job, timestamp)

## Determine the average build runtime of all successful Haskell builds that
## ran on "work".

hs <- builds[project=="nixpkgs" & jobset=="haskell-updates",]
hs <- hs[machine=="work" & buildstatus==0 & system == "x86_64-linux" & runtime > 0,]
hs <- hs[,job:=sub("\\.x86_64-linux$", "", job)]
hs <- hs[,job:=sub("^haskell(ng)?Packages\\.", "", job)]
hs <- hs[,job:=sub(".*git-?annex.*", "git-annex", job, ignore.case=T)]
hs <- hs[,job:=sub("idris_plain$", "idris", job)]
hs <- hs[!grep("haskell(-ng)?\\.compiler\\.", job),]
hs <- hs[!grep("^ghc\\.ghc", job),]
hs <- hs[!grep("ghc[0-9]+$", job),]
hs <- hs[!duplicated(hs$drvpath)]
hs <- hs[
        , list(builds=length(runtime),runtime=sum(runtime),runtime.median=median(runtime),runtime.mean=mean(runtime),runtime.sd=sd(runtime))
        , by=job
        ]
hs <- hs[builds>10,]
head(hs[order(runtime.mean, decreasing=T)], n=30)
head(hs[order(builds, decreasing=T)], n=20)
summary(as.numeric(hs$runtime.mean,units="mins"))
quantile(as.numeric(hs$runtime.mean,units="mins"), 0.82)

## Determine the number of builds per day.

hs <- builds[ project=="nixpkgs" & jobset=="haskell-updates" & starttime >= as.POSIXct("2015-01-01")
            , list(builds=length(timestamp))
            , by=list(day=as.Date(timestamp))
            ]
hs <- merge(hs, data.table(day=seq(min(hs$day), max(hs$day), by="days"), ignore=0), by="day", all=T)
hs[is.na(builds)] <- 0
hs$ignore <- NULL
summary(hs$builds)
quantile(hs$builds, .8)


## Perform k-medoids of pooled data with the wrapper function
# bp_km_wrap.r

pooled_ind_ana_km_df <- function(list_ss,
                                 paths,
                                 sessions,
                                 max_trials){

  baseline <- bp_km_wrap(list_Ss = list_ss,
                         sessions = sessions,
                         path_read = paths[1],
                         rp_index = c(1, 11))

  baseline$phase <- "training"

  experimental <- bp_km_wrap(list_Ss = list_ss,
                             sessions = sessions,
                             path_read = paths[2],
                             rp_index = c(1, 11))

  experimental$phase <- "aco"

  experimental$trial <- 1
  experimental <- experimental %>%
    group_by(sujeto,cde) %>%
    arrange(desc(sesion)) %>%
    mutate(cum_trial = cumsum(trial))

  baseline$trial <- 1

  baseline <- baseline %>%
    group_by(sujeto,cde) %>%
    arrange(desc(sesion)) %>%
    mutate(cum_trial = cumsum(trial))

  booleantrial <- baseline$cum_trial <= max_trials
  baseline  <- baseline[booleantrial,]
  booleantrial <- experimental$cum_trial <= max_trials
  experimental       <- experimental[booleantrial, ]

  pool_BL_EXP  <- bind_rows(experimental, baseline)

  pool_BL_EXP
}


opt.table<-function(out.file,dirs,labels,first.y=2051,last.y=2051,stochastic=F,test=F){
   #####################
  for (dir in dirs) {
    if ( file.access(file.path(data.path,dir,"op.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist'))
  }

  Init.function() # get SMS.contol object  including sp.names

  ref<-Read.reference.points.OP(dir=data.path)
  Blim<-as.vector(c(rep(-1, first.VPA-1),ref[,'Blim']))
  Bpa<-as.vector(c(rep(-1, first.VPA-1),ref[,'Bpa']))
  Fpa<-as.vector(c(rep(-1, first.VPA-1),ref[,'Fpa']))

  b<-NULL
  for (dir in dirs) {
    a<-Read.OP.condensed(dir=file.path(data.path,dir))
    a<-droplevels(subset(a,Year>=first.y & Year<=last.y & Species !='Plaice' & Species !='Sole'))
    a<-data.frame(scen=dir,a)
    b<-rbind(b,a)
  }

  b$belowBlim<-ifelse(b$SSB<Blim[b$Species.n],1,0)
  b$belowBpa<-ifelse(b$SSB<Bpa[b$Species.n],1,0)
  b$aboveFpa<-ifelse(b$Fbar>Fpa[b$Species.n],1,0)

  minY<-min(b$Year)
  maxY<-max(b$Year)
  ny<-maxY-minY+1

  a<-aggregate(cbind(yield,value,SSB)~scen+Species.n+Species,mean,data=b)
  aa<-aggregate(cbind(yield,value,SSB)~scen,sum,data=a)

  risk<-aggregate(cbind(belowBlim,belowBpa,aboveFpa)~scen+Species.n+Species,sum,data=b)
  if (test)  saverisk<<-risk
  risk$belowBlim<-risk$belowBlim*100/ny
  risk$belowBpa<-risk$belowBpa*100/ny
  risk$aboveFpa<-risk$aboveFpa*100/ny
  risk.average<-aggregate(list(risk.average.Blim=risk$belowBlim),list(scen=risk$scen),mean)
  if (test)  saverisk2<<-risk
  risk$belowBlim<-ifelse(risk$belowBlim<5,0,1)
  risk$belowBlim10<-ifelse(risk$belowBlim<10,0,1)

  risk$belowBpa<-ifelse(risk$belowBpa<5,0,1)
  risk$aboveFpa<-ifelse(risk$aboveFpa>5,1,0)

  risk<-aggregate(cbind(belowBlim,belowBlim10,belowBpa,aboveFpa)~scen,sum,data=risk)
  if (test)  saverisk3<<-risk
  aa<-merge(aa,risk)
  aa<-merge(aa,risk.average)

  label<-data.frame(scen=dirs,labels)
  aa<-merge(aa,label)

  a<-cbind(
    t(t(tapply(aa$yield,aa$labels,sum)/1000)),
    t(t(tapply(aa$value,aa$labels,sum)/1000)),
    t(t(tapply(aa$SSB,aa$labels,sum)/1000)) ,
    t(t(tapply(aa$belowBlim,aa$labels,sum))),
    t(t(tapply(aa$belowBpa,aa$labels,sum))),
      t(t(tapply(aa$aboveFpa,aa$labels,sum))))
  if (stochastic) a<-cbind(a,t(t(tapply(aa$risk.average,aa$labels,sum))))
  my.dimnames<-c('Yield','Value','SSB','no. of stocks','no. of stocks','no. of stocks')
  if (stochastic) my.dimnames<-c(my.dimnames,'Average (%)')

  dimnames(a)[[2]]<-my.dimnames

  print(a)
  if (!stochastic) {
    my.units<-c('(kt)','(m Euro)','(kt)','below Blim','below Bpa ','above Fpa ')
    my.dec<-c(0,0,0,0,0,0)
  } else {
    my.units<-c('(kt)','(m Euro)','(kt)','p(SSB < Blim) > 5%','p(SSB < Bpa) > 5%','above Fpa ','SSB < Blim')
    my.dec<-c(0,0,0,0,0,0,0)
  }
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,'.html',sep='')),
             dec=my.dec, width='"100%"',units=my.units)

  cat('\nOutput file: ',file.path(paste(out.file,'.html',sep='')))
}

#dirs<-paste("D1f_HCR_1_1_Rec0_penBpa____CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D2f_HCR_2_0_Rec0_penBpa____CVadj_limF_110_Oth",1:10,sep='')
dirs<-paste("D1f_HCR_1_1_Rec0_penBpa____CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D1c_HCR_1_1_Rec0_penBpa_atAgeW___CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D1e_HCR_1_1_Rec0_penBlim____CVadj_limF_110_Oth",1:10,sep='')
#dirs<-paste("D1b_HCR_1_1_Rec0_penBlim_atAgeW___CVadj_limF_110_Oth",1:10,sep='')
labels<-c('01. Default','02. Birds','03. R. radiata','04. Gurnards','05. Mackerel','06. Horse Mackerel','07. Grey seal','08. Porpoise','09. Hake','10. All')
opt.table(out.file=file.path(data.path,'opti_compare_determ_HCR1_all_other'),first.y=2034,last.y=2043,stochastic=F, test=T,
          dirs=dirs,
          labels=labels )

dirs<-c(
  "D1a_HCR_1_1_Rec0__atAgeW___CVadj_limF_110_",
  "D1d_HCR_1_1_Rec0_____CVadj_limF_110_",
  "D1b_HCR_1_1_Rec0_penBlim_atAgeW___CVadj_limF_110_",
  "D1e_HCR_1_1_Rec0_penBlim____CVadj_limF_110_",
  "D1c_HCR_1_1_Rec0_penBpa_atAgeW___CVadj_limF_110_",
  "D1f_HCR_1_1_Rec0_penBpa____CVadj_limF_110_"
)

labels<-c(
  "Value",
  "Yield",
  "Value, penalize SSB < Blim",
  "Yield, penalize SSB < Blim",
  "Value, penalize SSB < Bpa",
  "Yield, penalize SSB < Bpa"
)

opt.table(out.file=file.path(data.path,'opti_compare_determ_HCR1'),first.y=2034,last.y=2043,stochastic=F, test=T,
          dirs=dirs,
          labels=labels )

dirs<-c(
  "D2a_HCR_2_0_Rec0__atAgeW___CVadj_limF_110_",
  "D2d_HCR_2_0_Rec0_____CVadj_limF_110_",
  "D2b_HCR_2_0_Rec0_penBlim_atAgeW___CVadj_limF_110_",
  "D2e_HCR_2_0_Rec0_penBlim____CVadj_limF_110_",
  "D2c_HCR_2_0_Rec0_penBpa_atAgeW___CVadj_limF_110_",
  "D2f_HCR_2_0_Rec0_penBpa____CVadj_limF_110_"
)

labels<-c(
  "Value",
  "Yield",
  "Value, penalize SSB < Blim",
  "Yield, penalize SSB < Blim",
  "Value, penalize SSB < Bpa",
  "Yield, penalize SSB < Bpa"
)

opt.table(out.file=file.path(data.path,'opti_compare_determ_HCR2'),first.y=2034,last.y=2043,stochastic=F, test=T,
          dirs=dirs,
          labels=labels )


# The MIT License (MIT)
# Copyright (c) 2017 Louise AC Millard, MRC Integrative Epidemiology Unit, University of Bristol
#
# Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated
# documentation files (the "Software"), to deal in the Software without restriction, including without
# limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
# the Software, and to permit persons to whom the Software is furnished to do so, subject to the following
# conditions:
#
# The above copyright notice and this permission notice shall be included in all copies or substantial portions
# of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
# TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
# DEALINGS IN THE SOFTWARE.

makeQQPlot <- function(resDir, resultsAll) {

	## remove the fields excluded as stated in variable information file
        idx = which(is.na(resultsAll[,"isTraitOfInterest"]) | resultsAll[,"isTraitOfInterest"]=="")

	print(paste("Number not exposure variable:", length(idx)))

	resultsIncluded = resultsAll[idx,];
	pvalues = sort(resultsIncluded[,"pvalue"]);

	numRes = length(pvalues)
	pSort = sort(pvalues)
	rank = rank(pSort, ties.method="first")
	rankProportion = rank/numRes
	rankProportionLog10 = -log10(rankProportion)
	pLog10 = -log10(pSort)

	## do bonferroni correction and output this.
	bonf= 0.05/numRes
	print(paste('Bonferroni threshold:', bonf))
	threshold = -log10(bonf)
	belowBonf = length(which(pSort<bonf))
	print(paste('Number below Bonferroni threshold:', belowBonf));

	# check pvalues are valid (not zero)
        idxZero = which(pvalues==0)
        if (length(idxZero)>0) {
                print(paste("There are ", length(idxZero)," results with pvalues too small to be stored exactly, colored red on QQ plot.", sep=""))
        }

	# set indicator for pvalue ~zero (we don't have a precise p value for these results), these are coloured red on QQ plot
	zeroVal  = rep(0, length(rankProportionLog10))
	zeroVal[idxZero] = 1
	zeroVal = as.factor(zeroVal)
	pLog10[idxZero] = -log10(5e-324)

	## plot qqplot
	pdf(paste(resDir,"qqplot.pdf",sep=""))

	# qq
	par(pch='.')
	plot(rankProportionLog10, pLog10,col=c("#990099", "red")[zeroVal], xlab='expected -log10(p)', ylab='actual -log10(p)',cex=0.8, pch=c(16, 8)[zeroVal])

	# ascending diagonal, dotted blue
	minVal = min(max(rankProportionLog10), max(pLog10))
	segments(0, 0, minVal, minVal, col='#0066cc',lty=3)

	# horizontal threshold line, dashed green
	segments(0, threshold, max(rankProportionLog10), threshold, col='#008000',lty=2)

	junk<- dev.off()

	print("Finished QQ plot")

}


require(reshape)
require(maptools)
require(countrycode)
require(raster)
require(reshape)
require(dplyr)
require(rgeos)
require(rgdal)
memory.limit(size=1e9)

basin = c('Indus')

setwd('P:/is-wel/indus/message_indus')

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
buff.sp = gBuffer( basin.sp, width=0.1 )
buff2.sp = gBuffer( basin.sp, width=10 )
proj4string(basin.sp) = proj4string(basin.spdf)
proj4string(buff.sp) = proj4string(basin.spdf)
proj4string(buff2.sp) = proj4string(basin.spdf)

# Country region mapping key
country_region_map_key.df = data.frame( read.csv('input/country_region_map_key.csv', stringsAsFactors=FALSE) )

# historical connection rates
ww.df = data.frame(read.csv('input/sewerage_connection_and_treatment.csv', header=TRUE, sep=',', stringsAsFactors=F, as.is=T))
ww.df$country_id = as.character(countrycode(ww.df$country, 'country.name', 'iso3c'))

# Existing urban wastewater treatment
# Income vs connection from Baum et al 2010
income_vs_connection.df = data.frame(level = c('low','middle','upper','high'), max_income = c(1045/2,(4125-1045)/2+1045,(12375-4125)/2+4125,(30000-12375)/2+12375), connection = c(3.6,12.7,53.6,86.8)/100, treatment=c(0.02,2,13.8,78.9)/100)
y = c(0.0001,income_vs_connection.df$connection,0.95)
x = c(100,income_vs_connection.df$max_income,60000)
r = nls(y ~ SSlogis(x,a,m,s))
cp.a = coef(r)[1]
cp.m = coef(r)[2]
cp.s = coef(r)[3]
y = c(0.0001,income_vs_connection.df$treatment,0.9)
r = nls(y ~ SSlogis(x,a,m,s))
tp.a = coef(r)[1]
tp.m = coef(r)[2]
tp.s = coef(r)[3]

yy = c(2015,seq(2020,2060,by=10))

for( case in c( 'base', 'sdg' ) )
	{

	res.list = lapply( c(1,2,5), function(ss){

		dat.df = reshape::merge_recurse( lapply( 1:length(yy), function(y){
			bsn.df=basin.spdf
			if(ss==1){rr=1}
			if(ss==2){rr=2}
			if(ss==5){rr=4}
			if(yy[y]==2015){yy2=2010}else{yy2=yy[y]}
			dat.df = data.frame( readRDS( paste('input/harmonized_rcp_ssp_data/water_use_ssp',ss,'_rcp',rr,'_',yy2,'_data.Rda',sep='') ) )
			names(dat.df)[which(names(dat.df) == paste('xloc',yy2,sep='.'))] = 'xloc'
			names(dat.df)[which(names(dat.df) == paste('yloc',yy2,sep='.'))] = 'yloc'
			names(dat.df)[which(names(dat.df) == paste('urban_pop',yy2,sep='.'))] = 'urban_pop'
			names(dat.df)[which(names(dat.df) == paste('rural_pop',yy2,sep='.'))] = 'rural_pop'
			names(dat.df)[which(names(dat.df) == paste('urban_gdp',yy2,sep='.'))] = 'urban_gdp'
			names(dat.df)[which(names(dat.df) == paste('rural_gdp',yy2,sep='.'))] = 'rural_gdp'
			coordinates(dat.df) = ~ xloc + yloc
			gridded(dat.df) = TRUE
			dat.spdf = dat.df
			proj4string(dat.df) = proj4string(bsn.df)
			dat.df = cbind(data.frame(dat.df), over(dat.df,bsn.df[,which(names(bsn.df) == 'PID')]))
			dat.df = dat.df[-1*which(is.na(dat.df$PID)),]
			dat.df = data.frame( dat.df  )
			dat.df = cbind( dat.df[ ,c( 'country_id','PID', 'xloc', 'yloc', 'urban_pop', 'rural_pop', 'urban_gdp', 'rural_gdp' ) ] )
			names(dat.df) = c('country_id','PID','xloc','yloc', paste('urban_pop',yy[y],sep='.'), paste('rural_pop',yy[y],sep='.'),paste('urban_gdp',yy[y],sep='.'), paste('rural_gdp',yy[y],sep='.') )
			return(dat.df)
			} ), by = c('xloc','yloc','country_id','PID') )

		# Countries and regions
		dat.df$country = sapply( dat.df$country_id, function(cc){ if( cc %in% country_region_map_key.df$UN_Code ){ return( country_region_map_key.df$Region[ which(country_region_map_key.df$UN_Code == cc) ] ) }else{ return(NA) } } )
		dat.df$region = sapply( dat.df$country_id, function(cc){ if( cc %in% country_region_map_key.df$UN_Code ){ return( country_region_map_key.df$Eleven_region[ which(country_region_map_key.df$UN_Code == cc) ] ) }else{ return(NA) } } )
		dat.df = dat.df[which(!is.na(dat.df$region)),]

		if( case == 'sdg' ){ add_SDG_constrain = 1 }else{ add_SDG_constrain = 0 }

		# piped water access / sewerage connection
		national_connection_rate.df = do.call( rbind, lapply( yy , function(yyy){

			ret1 = data.frame( do.call( rbind, lapply(  unique( dat.df$country_id )[ which( unique( dat.df$country_id ) %in% as.numeric( country_region_map_key.df$UN_Code ) ) ], function(cc){

				ret2 = do.call( rbind, lapply( c('urban','rural'), function(tt){

					inc_o = max( 0, sum( dat.df[ which(  dat.df$country_id == cc ) , c(  paste( tt, '_gdp.', yy[1], sep='' ) ) ], na.rm=TRUE ) / sum( dat.df[ which(  dat.df$country_id == cc ) , c(  paste( tt, '_pop.', yy[1], sep='' ) ) ], na.rm=TRUE ) , na.rm=TRUE )
					inc_f = max( 0, sum( dat.df[ which(  dat.df$country_id == cc ) , c(  paste( tt, '_gdp.', yyy, sep='' ) ) ], na.rm=TRUE ) / sum( dat.df[ which(  dat.df$country_id == cc ) , c(  paste( tt, '_pop.', yyy, sep='' ) ) ], na.rm=TRUE  ) , na.rm=TRUE )
					ind = which( ww.df$country_id == as.character( country_region_map_key.df$Region[ which( as.numeric( country_region_map_key.df$UN_Code ) == cc ) ] ) )
					if( length( ind ) > 0 )
						{
						c0 = ww.df$connected.2010[ ind ] / 100
						t0 = ww.df$treated.2010[ ind ] / 100
						}else
						{
						if(inc_f > 0)
							{
							c0 = c( SSlogis(inc_o,cp.a,cp.m,cp.s) )
							t0 = c( SSlogis(inc_o,tp.a,tp.m,tp.s) )
							}else
							{
							c0 = 0
							t0 = 0
							}
						}

					decay = max( 0, 1 / length(yy) * log( 1 / 0.01 ), na.rm=TRUE )
					if( yyy > yy[1] )
						{
						c_mod = c( SSlogis( inc_f, cp.a, cp.m, cp.s ) )
						cp = ( 1 +  ( c0 / c_mod - 1 ) * exp( -1 * decay * ( which(yy == yyy) - 1 ) ) ) * c_mod
						if( add_SDG_constrain == 1 & yyy >= 2030 & cp < 0.95 ){ cp = 0.95 }

						t_mod = c( SSlogis( inc_f, tp.a, tp.m, tp.s ) )
						tp = ( 1 +  ( t0 / t_mod - 1 ) * exp( -1 * decay * ( which(yy == yyy) - 1 ) ) ) * t_mod
						if( add_SDG_constrain == 1 & yyy >= 2030 & tp < 0.5 ){ tp = 0.5 }

						}else
						{
						cp = c0
						tp = t0
						}

					ret3  = data.frame( cp = cp, tp = tp )
					names(ret3) = paste(tt,names(ret3),sep='.')

					return( as.matrix(c(cp,tp)) )

					} ) )

				ret2 = data.frame(t(ret2))
				names(ret2) = c( 'urban.cp', 'urban.tp', 'rural.cp', 'rural.tp' )
				row.names(ret2) = paste(country_region_map_key.df$Region[ which( as.numeric( country_region_map_key.df$UN_Code ) == cc ) ],yyy,sep='.')
				return(ret2)

				} ) ) )

			return(ret1)

			} ) )

		dat.df = cbind( dat.df, round( do.call(cbind, lapply(yy, function(yyy){
			ret = data.frame( res = sapply( dat.df$country, function(cc){ national_connection_rate.df[ paste( cc, yyy, sep = '.' ), 'urban.cp' ] } ) )
			ret$res[ which( !( unlist( dat.df[ , paste( 'urban_pop', yyy, sep = '.' ) ] ) > 0 ) ) ] = 0
			names(ret) = paste( 'urban_connection_rate', yyy, sep = '.' )
			return(ret)
			} ) ), digits = 2 ) )
		dat.df = cbind( dat.df, round( do.call(cbind, lapply(yy, function(yyy){
			ret = data.frame( res = sapply( dat.df$country, function(cc){ national_connection_rate.df[ paste( cc, yyy, sep = '.' ), 'urban.tp' ] } ) )
			ret$res[ which( !( unlist( dat.df[ , paste( 'urban_pop', yyy, sep = '.' ) ] ) > 0 ) ) ] = 0
			names(ret) = paste( 'urban_treated_rate', yyy, sep = '.' )
			return(ret)
			} ) ), digits = 2 ) )
		dat.df = cbind( dat.df, round( do.call(cbind, lapply(yy, function(yyy){
			ret = data.frame( res = sapply( dat.df$country, function(cc){ national_connection_rate.df[ paste( cc, yyy, sep = '.' ), 'rural.cp' ] } ) )
			ret$res[ which( !( unlist( dat.df[ , paste( 'rural_pop', yyy, sep = '.' ) ] ) > 0 ) ) ] = 0
			names(ret) = paste( 'rural_connection_rate', yyy, sep = '.' )
			return(ret)
			} ) ), digits = 2 ) )
		dat.df = cbind( dat.df, round( do.call(cbind, lapply(yy, function(yyy){
			ret = data.frame( res = sapply( dat.df$country, function(cc){ national_connection_rate.df[ paste( cc, yyy, sep = '.' ), 'rural.tp' ] } ) )
			ret$res[ which( !( unlist( dat.df[ , paste( 'rural_pop', yyy, sep = '.' ) ] ) > 0 ) ) ] = 0
			names(ret) = paste( 'rural_treated_rate', yyy, sep = '.' )
			return(ret)
			} ) ), digits = 2 ) )

		return(dat.df)

		} )

	names(res.list) = c('SSP1','SSP2','SSP5')

	# Now estimate average connection level for each PID
	res_pid.df = do.call( rbind, lapply( c('SSP1','SSP2','SSP5'), function( ssp ){

		do.call( rbind, lapply( c( unique( unlist( strsplit( names( res.list[[ssp]] )[ grepl( "urban_pop" , names( res.list[[ssp]] ) ) ], '[.]' ) )[seq(2,2*length(names( res.list[[ssp]] )[ grepl( "urban_pop" , names( res.list[[ssp]] ) ) ]),by=2)] ) ), function( yy ){

			do.call( rbind, lapply( unique(res.list[[1]]$PID), function(ppp){

				upop = data.frame( res.list[[ssp]][ which( res.list[[ssp]]$PID == as.character( ppp ) ), names( res.list[[ssp]] )[ grepl( paste("urban_pop",yy,sep='.') , names( res.list[[ssp]] ) ) ] ] )

				rpop = data.frame( res.list[[ssp]][ which( res.list[[ssp]]$PID == as.character( ppp ) ), names( res.list[[ssp]] )[ grepl( paste("rural_pop",yy,sep='.') , names( res.list[[ssp]] ) ) ] ] )

				ucon = data.frame( res.list[[ssp]][ which( res.list[[ssp]]$PID == as.character( ppp ) ), names( res.list[[ssp]] )[ grepl( paste("urban_connection_rate",yy,sep='.') , names( res.list[[ssp]] ) ) ] ] )

				rcon = data.frame( res.list[[ssp]][ which( res.list[[ssp]]$PID == as.character( ppp ) ), names( res.list[[ssp]] )[ grepl( paste("rural_connection_rate",yy,sep='.') , names( res.list[[ssp]] ) ) ] ] )

				utrt = data.frame( res.list[[ssp]][ which( res.list[[ssp]]$PID == as.character( ppp ) ), names( res.list[[ssp]] )[ grepl( paste("urban_treated_rate",yy,sep='.') , names( res.list[[ssp]] ) ) ] ] )

				rtrt = data.frame( res.list[[ssp]][ which( res.list[[ssp]]$PID == as.character( ppp ) ), names( res.list[[ssp]] )[ grepl( paste("rural_treated_rate",yy,sep='.') , names( res.list[[ssp]] ) ) ] ] )

				df = data.frame( 	SSP = ssp,
									PID = ppp,
									year = yy,
									urban_connection_rate = round( max( weighted.mean( unlist( ucon ), unlist( upop ) ), 0, na.rm=TRUE ), digits = 3 ),
									rural_connection_rate = round( max( weighted.mean( unlist( rcon ), unlist( rpop ) ), 0, na.rm=TRUE ), digits = 3 ),
									urban_treated_rate = round( max( weighted.mean( unlist( utrt ), unlist( utrt ) ), 0, na.rm=TRUE ), digits = 3 ),
									rural_treated_rate = round( max( weighted.mean( unlist( rtrt ), unlist( rtrt ) ), 0, na.rm=TRUE ), digits = 3 )	)

				return( df )

				} ) )

			} ) )

		} ) )

	res_pid.df = res_pid.df[ order( res_pid.df$SSP, res_pid.df$PID ) , ]

	write.csv( res_pid.df[ order( res_pid.df$SSP, res_pid.df$PID ) , ], paste0( "input/indus_water_connections_", case, ".csv" ), row.names=FALSE )

	# Add historical capacity
	if( case == 'base' )
		{

		res_pid.df  = read.csv( paste0( "input/indus_water_connections_", case, ".csv" ), stringsAsFactors = FALSE )
		names(res_pid.df)[ c(1,2,3) ] = c('scenario','node','year_all')
		ucon.df = 	res_pid.df %>%
					filter( year_all == 2015 ) %>%
					filter( scenario == 'SSP2' ) %>%
					dplyr::select( node, urban_connection_rate )
		utrt.df = 	res_pid.df %>%
					filter( year_all == 2015 ) %>%
					filter( scenario == 'SSP2' ) %>%
					dplyr::select( node, urban_treated_rate )
		rcon.df = 	res_pid.df %>%
					filter( year_all == 2015 ) %>%
					filter( scenario == 'SSP2' ) %>%
					dplyr::select( node, rural_connection_rate )
		rtrt.df = 	res_pid.df %>%
					filter( year_all == 2015 ) %>%
					filter( scenario == 'SSP2' ) %>%
					dplyr::select( node, rural_treated_rate )

		# Demands
		demand.df = read.csv( "input/indus_demands.csv", stringsAsFactors=FALSE )

		# Just keep the current SSP and add level and commodity to match core GAMS model
		demand.df = demand.df[ which( demand.df$scenario == 'SSP2' ), c( which( names( demand.df ) != 'scenario' ) ) ]
		demand.df$commodity = NA
		demand.df$commodity[ which( demand.df$type %in% c('withdrawal','return') ) ] = 'freshwater'
		demand.df$commodity[ which( demand.df$type %in% c('electricity') ) ] = 'electricity'
		demand.df$level = NA
		demand.df$level[ which(  demand.df$type %in% c('withdrawal','electricity') & demand.df$sector == c('urban') ) ] = 'urban_final'
		demand.df$level[ which(  demand.df$type %in% c('withdrawal','electricity') & demand.df$sector == c('industry') ) ] = 'industry_final'
		demand.df$level[ which(  demand.df$type %in% c('withdrawal','electricity') & demand.df$sector == 'rural' )  ] = 'rural_final'
		demand.df$level[ which(  demand.df$type %in% c('return') & demand.df$sector == 'urban' ) ] = 'urban_waste'
		demand.df$level[ which(  demand.df$type %in% c('return') & demand.df$sector == 'industry' ) ] = 'industry_waste'
		demand.df$level[ which(  demand.df$type %in% c('return') & demand.df$sector == 'rural' ) ] = 'rural_waste'
		demand.df = demand.df[ , c( 'pid', 'level', 'commodity', 'year', 'month', 'value' ) ]
		names(demand.df) = c('node','level','commodity','year_all','time', 'value0' )

		# Multiply the fraction by the historical demands to calibrate historical gw demands
		urban_connected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('urban_final')) %>%
			left_join(ucon.df,by = c("node")) %>%
			mutate(value = value0 * urban_connection_rate) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'urban_piped_distribution') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		urban_unconnected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('urban_final')) %>%
			left_join(ucon.df,by = c("node")) %>%
			mutate(value = value0 * (1-urban_connection_rate)) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'urban_unimproved_distribution') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		urban_collected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('urban_waste')) %>%
			left_join(ucon.df,by = c("node")) %>%
			mutate(value = value0 * urban_connection_rate) %>%
			mutate(tec = 'urban_piped_collection') %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'urban_piped_collection') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		urban_uncollected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('urban_waste')) %>%
			left_join(ucon.df,by = c("node")) %>%
			mutate(value = value0 * (1-urban_connection_rate)) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'urban_wastewater_release') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		urban_treated.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('urban_waste')) %>%
			left_join(utrt.df,by = c("node")) %>%
			mutate(value = value0 * urban_treated_rate ) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'urban_wastewater_treatment') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		rural_connected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('rural_final')) %>%
			left_join(rcon.df,by = c("node")) %>%
			mutate(value = value0 * rural_connection_rate) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'rural_piped_distribution') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		rural_unconnected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('rural_final')) %>%
			left_join(rcon.df,by = c("node")) %>%
			mutate(value = value0 * (1-rural_connection_rate)) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'rural_unimproved_distribution') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		rural_collected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('rural_waste')) %>%
			left_join(rcon.df,by = c("node")) %>%
			mutate(value = value0 * rural_connection_rate) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'rural_piped_collection') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		rural_uncollected.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('rural_waste')) %>%
			left_join(rcon.df,by = c("node")) %>%
			mutate(value = value0 * (1-rural_connection_rate)) %>%
			dplyr::select(node,year_all,time,value) %>%
			group_by(node) %>%
			summarise( value =  round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'rural_wastewater_release') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		rural_treated.df = demand.df %>%
			filter(year_all == 2015) %>%
			filter(commodity == 'freshwater') %>%
			filter(level %in% c('rural_waste')) %>%
			left_join(rtrt.df,by = c("node")) %>%
			mutate(value = value0 * rural_treated_rate ) %>%
			dplyr::select(node,time,value) %>%
			group_by(node) %>%
			summarise( value = round( max( value ) / 1e6, digits = 2 ) ) %>%
			mutate(units = 'mcm_per_day') %>%
			mutate(tec = 'rural_wastewater_treatment') %>%
			mutate(year_all = 2015) %>%
			data.frame() %>%
			dplyr::select( node, tec, year_all, value, units )

		### Write to csv
		water_access.df = do.call( rbind, list( urban_connected.df,
												urban_collected.df,
												urban_treated.df,
												rural_connected.df,
												rural_collected.df,
												rural_treated.df ) )

		### Append historical capacity csv to include water connection capacities

		# historical capacity csv
		historical_capacity.df1 = read.csv( "input/historical_new_cap.csv", stringsAsFactors=FALSE )
		ind = which( 	as.character( historical_capacity.df1$tec ) %in%
						c(	'urban_piped_distribution',
							'urban_unimproved_distribution',
							'urban_piped_collection',
							'urban_wastewater_release',
							'urban_wastewater_treatment',
							'rural_piped_distribution',
							'rural_unimproved_distribution',
							'rural_piped_collection',
							'rural_wastewater_release',
							'rural_wastewater_treatment' ) )
		if( length( ind ) > 0 ){ historical_capacity.df1 = historical_capacity.df1[ -1 * ind, ] }
		historical_capacity.df1 = rbind( 	historical_capacity.df1,
											urban_connected.df,
											urban_unconnected.df,
											urban_collected.df,
											urban_uncollected.df,
											urban_treated.df,
											rural_connected.df,
											rural_unconnected.df,
											rural_collected.df,
											rural_uncollected.df,
											rural_treated.df )
		write.csv( 	historical_capacity.df1,
					"input/historical_new_cap.csv",
					row.names = FALSE )

		}

	}


procesaEstacion <- function(estacion, fechaInicio, fechaFin,
								matrizDIV, vectorDIVHorario, horaInicio, origenDato,
								nombreEstacion = NA, # Si se da un valor a esta variable el nombre que aparece en el gráfico y en el nombre de los archivos incluye el valor de esta variable, sino lo obtiene automáticamente de la BBDD o API
								guardarCSV = FALSE, # Si está en FALSE sí que se guarda un archivo .csv con el resumen diario del resumen horario, si está en TRUE se guarda un .csv para los resultados diarios del modelo americano y del modelo horario, también se puede forzar en el código para que se guarden los resultados del modelo horario.
								unSoloPDF = TRUE, salidaAzucareraAB = TRUE,
								campania = NA, # si se aporta la campañia (un string) se añade a los nombres de los archivos de gráficos y .csv
								salidaGrafica = TRUE,  # Si es false sólo se calcula el modelo pero no se pintan los gráficos
								offsetHR = 0) # Se usó durante el proyecto para hacer pruebas con distintos umbrales de HR
{
	resultado <- calculaRiesgoDIV_V20(estacion = estacion, fechaInicio = fechaInicio, fechaFin,
										matrizDIV, vectorDIVHorario, horaInicio = horaInicio, offsetHR = offsetHR, origenDato = origenDato, nombreEstacion = nombreEstacion) #-> a

	mensajeLog = paste('DIVs de la estación', resultado$nombreEstacion, 'codigo', estacion, 'de', origenDato, 'calculados')
	print(mensajeLog)

	textoDIVs = paste0('RESULTADO MODELO PARA ESTACIÓN ', resultado$nombreEstacion, ":",
					'\n\t\t\tactualizado a las ', horaInicio, ' hora solar, ultimo dato disponible: ', strftime(resultado$fechaUltimoDato, '%H:%M'),
					if(as.Date(resultado$fechaUltimoDato) < Sys.Date()) paste(' ATENCION: DATOS NO ACTUALIZADOS, ÚLTIMA FECHA DISPONIBLE:', strftime(resultado$fechaUltimoDato, '%d/%m/%y')),
					"\n\n\tDIVacumulado USANDO HR > 90%:    ", as.character(round(sum(tail(resultado$DIV$DIV_HR90, 2)), 2)),
					"\n\tDIVacumulado USANDO HR > 85%:    ", as.character(round(sum(tail(resultado$DIV$DIV_HR85, 2)), 2)),
					"\n\tDIVacumulado USANDO HR > 80%:    ", as.character(round(sum(tail(resultado$DIV$DIV_HR80, 2)), 2)),
					"\n\n\tDIVacumulado USANDO HUMECTACIÓN: ", as.character(round(sum(tail(resultado$DIV$DIV_HumectUmbral, 2)), 2)))

	# GENERACIÓN GRÁFICOS
	archivos <- character()
	archivosBasicos <- character()
	nombreEstacion = resultado$nombreEstacion

	if(salidaGrafica)
	{
		archivo <- pintaGraficaRiesgoDIV_V17(resultado, etiquetasEjeX = etiquetasEjeX)
		archivos <- c(archivos, archivo) # Esta variable guardará todos los archivos que se generen en la función y se enviarán a expertos
		archivosBasicos = pintaGraficaRiesgoDIV_V17(resultado, etiquetasEjeX = etiquetasEjeX, pintaGraficaTHR = FALSE) # Esta variable guardará los archivos que se enviarán a todo el mundo

		archivo <- pintaGraficaRiesgoDIV_V17(resultado, etiquetasEjeX = etiquetasEjeX, pintaDIV_AMERICANO = TRUE, pintaGraficaTHR = FALSE)
		archivos <- c(archivos, archivo) # Esta variable guardará todos los archivos que se generen en la función
		archivosBasicos <- c(archivosBasicos, archivo)

		#
		if(nrow(resultado$DIV_Horario) > 5*24)
		{
			resultadoGrafico <- resultado$DIV_Horario[(5*24):nrow(resultado$DIV_Horario),] # PAra dibujarlos les quito los 5 primeros días que no hay valores de DIV acumulado7d
			datosClimaticos <- resultado$datosClimaticos[(5*24):nrow(resultado$datosClimaticos),] # Para dibujarlos les quito los 5 primeros días que no hay valores de DIV acumulado7d

			archivo <- pintaGraficoDIVAcumulados(resultadoGrafico, offsetHR = offsetHR, nombreEstacion = resultado$nombreEstacion,
												nombreArchivo = paste0(nombreEstacion, '-GraficoDIVAcumulados-1', '.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, graficosADibujar = c(TRUE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE), tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoDIVAcumulados(resultadoGrafico, offsetHR = offsetHR, nombreEstacion = resultado$nombreEstacion,
												nombreArchivo = paste0(nombreEstacion, '-GraficoDIVAcumulados-2', '.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, graficosADibujar = c(FALSE, FALSE, FALSE, FALSE, TRUE, TRUE, TRUE), tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoVisualizacionComparativaHR(resultadoGrafico, datosClimaticos, offsetHR = offsetHR, resultado = resultado,
												tipoHR = 80, nombreArchivo = paste0(nombreEstacion, '-Riesgo_y_Clima_HR80_V1.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoVisualizacionComparativaHR(resultadoGrafico, datosClimaticos, offsetHR = offsetHR, resultado = resultado,
												tipoHR = 82.5, nombreArchivo = paste0(nombreEstacion, '-Riesgo_y_Clima_HR82.5_V1.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoVisualizacionComparativaHR(resultadoGrafico, datosClimaticos, offsetHR = offsetHR, resultado = resultado,
												tipoHR = 85, nombreArchivo = paste0(nombreEstacion, '-Riesgo_y_Clima_HR85_V1.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoVisualizacionComparativaHR(resultadoGrafico, datosClimaticos, offsetHR = offsetHR, resultado = resultado,
												tipoHR = 87.5, nombreArchivo = paste0(nombreEstacion, '-Riesgo_y_Clima_HR87.5_V1.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoVisualizacionComparativaHR(resultadoGrafico, datosClimaticos, offsetHR = offsetHR, resultado = resultado,
												tipoHR = 90, nombreArchivo = paste0(nombreEstacion, '-Riesgo_y_Clima_HR90_V1.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)

			archivo <- pintaGraficoVisualizacionComparativaHR(resultadoGrafico, datosClimaticos, offsetHR = offsetHR, resultado = resultado,
												tipoHR = 92.5, nombreArchivo = paste0(nombreEstacion, '-Riesgo_y_Clima_HR92.5_V1.pdf'), tipografico = "pdf",
												incluirTitulo = TRUE, tituloUnSoloPDF = !unSoloPDF)
			archivos <- c(archivos, archivo)
		}

		# UNIR TODOS LOS GRÁFICOS EN UNO SOLO
		 #!!! NO SE USA PORQUE LA FUNCIÓN DA UN PROBLEMA con solución no trivial descrita aquí: https://github.com/pridiltal/staplr/issues/45
		if(unSoloPDF)
		{
			nombreArchivoInforme = paste0(strftime(fechaFin, '%Y-%m-%d-'), nombreEstacion, if(!is.na(campania)) paste0('-Campaña-', campania) else '', '-InformeCercosporaV', numeroVersion, '.pdf')
			output_file <- file.path(getwd(), nombreArchivoInforme)
			input_files <- file.path(getwd(), archivos)
			staple_pdf(input_directory = NULL, input_files = input_files, output_filepath = output_file, overwrite = TRUE)
			archivos <- nombreArchivoInforme # Reseteamos la variable!
		}
		if(salidaAzucareraAB)
		{
			nombreArchivoInforme = paste0(strftime(fechaFin, '%Y-%m-%d-'), nombreEstacion, if(!is.na(campania)) paste0('-Campaña-', campania) else '', '-InformeCercospora-', strftime(Sys.Date(), "%d-%b-%Y"), '.pdf')
			output_file <- file.path(getwd(), nombreArchivoInforme)
			input_files <- file.path(getwd(), archivosBasicos)
			staple_pdf(input_directory = NULL, input_files = input_files, output_filepath = output_file, overwrite = TRUE)
			archivosBasicos <- nombreArchivoInforme # Reseteamos la variable!
		}
	}

	# GENERAR ARCHIVOS CSV
	if(guardarCSV)
	{
		if(TRUE)
		{	archivo <- paste0(paste(strftime(fechaFin, '%Y-%m-%d'),	'DatosHorariosDIVyClima', 'modeloHorario', nombreEstacion, origenDato, sep = '-'),
								if(!is.na(campania)) paste0('-Campaña-', campania) else '', '.csv')
			write.csv2(cbind(resultado$DIV_Horario[,c(1:3, 9, 15, 21, 27, 33, 39)], resultado$datosClimaticos[,2:5]), archivo, row.names = F)
		}
		archivos <- c(archivos, archivo)
		archivo <- paste0(paste(strftime(fechaFin, '%Y-%m-%d'), 'DatosDiariosDIV', 'modeloAmericano', nombreEstacion, origenDato, sep = '-'),
							if(!is.na(campania)) paste0('-Campaña-', campania) else '', '.csv')
			write.csv2(resultado$DIV_AMERICANO, archivo, row.names = F)
		archivos <- c(archivos, archivo)
		archivo <- paste0(paste(strftime(fechaFin, '%Y-%m-%d'), 'DatosDiariosDIV', 'modeloHorario', nombreEstacion, origenDato, sep = '-'),  # Es el mismo archivo que el enviado por e-mail (ver else)
							if(!is.na(campania)) paste0('-Campaña-', campania) else '', '.csv')
			write.csv2(resultado$DIV, archivo, row.names = F)
		archivos <- c(archivos, archivo)
	}else
	{
		if(TRUE)
		{	archivo <- paste0(paste(strftime(fechaFin, '%Y-%m-%d'),	'DatosDIVAcumulado', 'modeloHorario', nombreEstacion, origenDato, sep = '-'), '.csv')
								#if(!is.na(campania)) paste0('-Campaña-', campania) else '',
			write.csv2(resultado$DIV_Horario[strftime(resultado$DIV_Horario$fecha, '%H:%M') == '10:00', c(1:2, 5:7, 23:25)], archivo, row.names = F)
		}
		archivos <- c(archivos, archivo)
		nombreArchivoCSV <- paste0(paste(strftime(fechaFin, '%Y-%m-%d'), 'DatosDIV', 'modeloHorario', nombreEstacion, sep = '-'), '.csv') #origenDato, nombreEstacion, sep = '-'), '.csv')
		write.csv2(resultado$DIV, nombreArchivoCSV, row.names = FALSE)
		archivos <- c(archivos, nombreArchivoCSV)
		#archivosBasicos = c(archivosBasicos, nombreArchivoCSV)
	}

	#Encoding(textoDIVs) <- 'UTF-8'

	return(list(resultado = if(DEBUG) resultado else '', archivos = archivos, archivosBasicos = archivosBasicos, textoDIVs = textoDIVs, alertaRiesgo = if(sum(tail(resultado$DIV$DIV_HR85, 2)) > 2) TRUE else FALSE))
}

enviaEmail <- function(destinatariosEmail, archivos, zona = '', descripcion = '', bodyEmail = '', mensajeExtra = '', fechaFin = Sys.Date())
{

	subject = paste('Modelo Cercospora, GRAFICOS AIMCRA,', zona, ' actualizados a', strftime(fechaFin, '%d/%m/%y'))

	bodyEmail = paste0(bodyEmail, 'RESULTADO MODELO PARA ESTACIONES ', zona, ': ', descripcion, '\n\n') #,

	if(Sys.Date() == as.Date("2020-04-22"))
	{
		mensajeExtra = paste0("Buenas tardes/noches, esta es una prueba de envío de correos con los nuevos gráficos con las novedades que comentamos en la reunión de la pasada semana.\n\n",
							"Se adjuntan dos archivos:\n\t -Uno con las gráficas de DIV_Horario acumulado a 7 días (verde), 14 días (azul) y 21 días (rojo). ",
							"Las gráficas se calculan según diferentes condiciones de humedad (90% y 85%) y humectación\n\n",
							"\t -Otro con la gráfica de DIV Acumulado para HR > 85% y una serie de gráficos adicionales con datos climáticos. ",
							"Además, en la parte inferior aparece un gráfico de \"Condiciones de Infección\", que se calculan siguiendo distintos métodos; ",
							"en ese gráfico, en general, cuanto más roja o ancha sea la barra dibujada => más peligro existe\n\n",
							"Los gráficos enviados son provisionales, cualquier mejora que creáis necesaria hacednoala llegar a siar.cida@larioja.org\n\nUn saludo\n\n")

	}

	if(Sys.Date() == as.Date("2020-04-24"))
	{
		mensajeExtra = paste0("Buenas tardes\n\n",
							"Desde hoy adjuntamos los datos de las dos estaciones. Para la estación 2789 (Riego a pie), ",
							"las curvas de DIV acumulado a 14 y 21 días, irán apareciendo según vayan avanzando los días y haya ",
							"suficiente información para calcularla\n\n",
							"Tenemos pendientes algunas mejoras en los gráficos, como indicábamos el otro día estos ",
							"son provisionales, cualquier mejora que creáis necesaria hacednosla llegar a siar.cida@larioja.org\n\nUn saludo\n\n")

	}

	if(Sys.Date() == as.Date("2020-05-07"))
	{
		mensajeExtra = paste0("Buenos días\n\n",
							"Desde hoy adjuntamos los gráficos de acuerdo a una nueva especificación",
							"\n\n",
							"Como siempre cualquier mejora que creáis necesaria hacednosla llegar a siar.cida@larioja.org\n\nUn saludo\n\n")

	}

	if(Sys.Date() == as.Date("2020-06-07"))
	{
		mensajeExtra = paste0("Buenas tardes\n\n",
							"\tDesde hoy adjuntamos los gráficos de acuerdo a una nueva especificación. También comienzan a enviarse los correos con la información calculada para las estaciones CESENS en Castilla León ",
							'Los correos se enviarán todos los días a las 11:30 y en los próximos días se añadirán las dos estaciones que hemos instalado aquí en La Rioja.',
							"\n\n",
							'\tAlgunos gráficos gráficos no tienen leyenda, nos queda pendiente, los que recibís estos datos por primera vez',
							'\n\n\tDespués de lo hablado sobre los cálculos con Manuel nos queda claro que sólo las HR > 85% son relevantes, por ello el modelo se calcula, a partir de ahora, ',
							'con los umbrales de humedad relativa de 85, 87.5, 90 y 92.5%.\n',
							'\tEn los gráficos de DIVs acumulados a 7, 14 y 21 días aparece ahora el acumulado de 2 días (en color dorado).\n\n',
							'\tUn tema pendiente es la pensar la posibilidad de representar los valores de DIV acumulados a 7, 14 y 21 días en el mismo gráfico donde ',
							'se representan actualmente el valor del DIV diario usando un código de color. En ese gráfico aparecen distintos DIVs calculados usando el sensor de humectación o bien distintos valores de HR. ',
							'Por un lado hay un problema de formato ya que los datos actuales representados en ese gráfico son diarios y estos otros son horarios, no parece complejo a priori; ',
							' por otro ese cuadro es un gráfico muy visual, pero es mucha información para dibujar: hay un resultado del modelo para método de cálculo usando la humectación o la humedad relativa considerando distintos umbrales: ',
							'85, 87.5, 90 y 92.5 y, para cada uno de ellos se obtiene para cada hora, el valor del DIV acumulado a 2, 7, 14 y 21 días. ',
							'A nosotros nos ayudará poner en común esta información y plantear ideas.\n\n',
							"\tEs un problema que aparezcan tantos gráficos, estoy buscando la manera de hacer un solo informe por estación, con varias páginas.\n\n",
							"\tAlgo de lo que hemos  hablado pero no hemos concretado en un procedimiento es incluir en estos gráficos la incidencia de la enfermedad observada en campo. Tenemos que definir un procedimiento y que nos envieis esa información periódicamente para que podamos contrastar la validez del modelo.\n\n",
							'\tComo siempre cualquier mejora que creáis necesaria hacednosla llegar a siar.cida@larioja.org\n\nUn saludo\n\n',
							'Nota: los gráficos de DIV acumulados sólo se generan cuando al menos hay 5 días de datos')
	}
	if(Sys.Date() == as.Date("2020-06-09"))
	{
		mensajeExtra = paste0("Buenos días\n\n",
							"Desde hoy adjuntamos los gráficos de acuerdo a una nueva especificación. Se incluyen  todos los informes en un solo archivo y se ha reparado el error con los archivos adjuntos",
							"\n\n",
							"Como siempre cualquier mejora que creáis necesaria hacednosla llegar a siar.cida@larioja.org\n\nUn saludo\n\n")

	}

	if(Sys.Date() == as.Date("2020-10-07"))
	{
		mensajeExtra = paste0("Buenos días\n\n",
							"Las temperaturas en los últimos días han sido relativamente bajas, por debajo de 15ºC la mayor parte del día, por lo que",
							"los riesgos de ataque de cercospora (DIV) calculados según el modelo han sido cero o muy cercanos a cero.\n",
							"Si bien se prevén unos días con temperaturas más cálidas no prevemos que los DIVs calculados sean altos, además el cultivo de remolacha está cercano a su fin por lo que ",
							"este es el último correo que se enviará con el cálculo del riesgo de cercospora (DIV).\n",
							"\n\n",
							"Para cualquier sugerencia enviar correo electrónico a la dirección siar.cida@larioja.org\n\nUn saludo\n\n")

	}

	bodyEmail <- paste0(bodyEmail, mensajeExtra)

	Encoding(bodyEmail) <- 'UTF-8' #encoding #"iso-8859-1" #'UTF-8' #
	Encoding(archivos) <- 'UTF-8' #encoding #'UTF-8'

	enviaMailNoHTML(destinatariosEmail = destinatariosEmail,
					from = "cercospora@larioja.org",
					subject = subject,
					bodyEmail  = bodyEmail,
					files = archivos,#paste0(getwd(), '/', archivos), #
					encoding, smtp = smtp, mensajeLog ="Enviados Correos a ") #encoding = 'UTF--8'
}

procesaEstacionPresentacionAIMCRA <- function(estacion, fechaInicio, fechaFin,
										matrizDIV, vectorDIVHorario, horaInicio, offsetHR = 0, origenDato,
										etiquetasEjeXDIV3 = NULL, etiquetasEjeXDIV5 = NULL, etiquetasEjeXAgricultor = NULL, evolucionEnfermedad = NULL, tituloGrafico = NULL,
										textoDIV3 = 'Estrategia DIV > 3', textoDIV5 = 'Estrategia DIV > 5', textoAgricultor = 'Estrategia Agricultor',
										tipoGrafico = 'pdf', resultado = NA)
{
	if(is.na(resultado))
	{
		resultado <- calculaRiesgoDIV_V17(estacion = estacion, fechaInicio = fechaInicio, fechaFin,
										matrizDIV, vectorDIVHorario, horaInicio = horaInicio, offsetHR = offsetHR, origenDato = origenDato)#-> a
	}

	mensajeLog = paste('DIVs de la estación', estacion, origenDato, 'calculados')
	print(mensajeLog)

	# GENERACIÓN GRÁFICOS
	archivos <- character()

	archivo <- pintaGraficaRiesgoDIV_V17(resultado, etiquetasEjeX = etiquetasEjeX, graficoCampania = FALSE, pintaGraficaTHR = FALSE, pintaGraficoHeatmapSimplificado = TRUE, tipoGrafico = tipoGrafico,
				etiquetasEjeXDIV3 = etiquetasEjeXDIV3, etiquetasEjeXDIV5 = etiquetasEjeXDIV5, etiquetasEjeXAgricultor = etiquetasEjeXAgricultor,
				textoDIV3 = textoDIV3, textoDIV5 = textoDIV5, textoAgricultor = textoAgricultor,
				evolucionEnfermedad = evolucionEnfermedad, tituloGrafico = tituloGrafico)
	archivos <- c(archivos, archivo) # Esta variable guardará todos los archivos que se generen en la función y se enviarán a expertos

	archivo <- pintaGraficaRiesgoDIV_V17(resultado, etiquetasEjeX = etiquetasEjeX, pintaDIV_AMERICANO = TRUE, pintaGraficaTHR = FALSE, pintaGraficoHeatmapSimplificado = TRUE, tipoGrafico = tipoGrafico, tituloGrafico = tituloGrafico)
	archivos <- c(archivos, archivo) # Esta variable guardará todos los archivos que se generen en la función

	return(list(resultado = if(DEBUG) resultado else '', archivos = archivos))
}

uneDatosDIV_V17 <- function(resultado1, resultado2, estacion = NA, nombreEstacion = NA, origenDato = NA)
{
	datosClimatico <- rbind(resultado1$datosClimaticos, resultado2$datosClimaticos)
	DIV <- rbind(resultado1$DIV, resultado2$DIV)
	DIV_AMERICANO <- rbind(resultado1$DIV_AMERICANO, resultado2$DIV_AMERICANO)
	DIV_Horario <- rbind(resultado1$DIV_Horario, resultado2$DIV_Horario)
	HR95.8horas <- rbind(resultado1$fechasInfeccion$HR95.8horas, resultado2$fechasInfeccion$HR95.8horas)
	HR95.6horas <- rbind(resultado1$fechasInfeccion$HR95.6horas, resultado2$fechasInfeccion$HR95.6horas)
	HR90.8horas <- rbind(resultado1$fechasInfeccion$HR90.8horas, resultado2$fechasInfeccion$HR90.8horas)
	HR90.6horas <- rbind(resultado1$fechasInfeccion$HR90.6horas, resultado2$fechasInfeccion$HR90.6horas)
	humectacion.8horas <- rbind(resultado1$fechasInfeccion$humectacion.8horas, resultado2$fechasInfeccion$humectacion.8horas)
	humectacion.6horas <- rbind(resultado1$fechasInfeccion$humectacion.6horas, resultado2$fechasInfeccion$humectacion.6horas)
	fechaUltimoDato <- max(resultado1$fechaUltimoDato, resultado2$fechaUltimoDato)
	origenDato <- if(!is.na(origenDato))  origenDato else if(resultado1$origenDato == resultado2$origenDato) resultado1$origenDato else "error"
	estacion <- if(!is.na(estacion))  estacion else if(resultado1$estacion == resultado2$estacion) resultado1$estacion else "error"
	nombreEstacion <- if(!is.na(nombreEstacion))  nombreEstacion else if(resultado1$nombreEstacion == resultado2$nombreEstacion) resultado1$nombreEstacion else "error"

	return(list(datosClimatico = datosClimatico,
				DIV = DIV, DIV_AMERICANO = DIV_AMERICANO, DIV_Horario = DIV_Horario,
				fechasInfeccion = list(HR95.8horas = HR95.8horas, HR95.6horas = HR95.6horas, HR90.8horas = HR90.8horas, HR90.6horas = HR90.6horas,
										humectacion.8horas = humectacion.8horas, humectacion.6horas = humectacion.6horas),
				UltimoDato = fechaUltimoDato, origenDato = origenDato, estacion = estacion, nombreEstacion = nombreEstacion)
			)
}


library(foreach)
library(doSNOW)

r=3
k=c(2,2,2,3)
source("codeKfixedLOG.r")
source("codeKvariable.r")
kmax=4

n=100
Ti=4
pers=12
sepp=2.5

source("doSimu.r")

pers=10

source("doSimu.r")

pers=8

source("doSimu.r")


library(data.table)
library(ggplot2)
source('../../labs.r')

load('mcmc-results.rdata')

mcsel <- mcmc[variable %in% mc_attributes[vartype %in% c('q0', 'q_f', 'q_g', 'q_f0', 'q_g0', 'q_gf', 'q_gf0'), variable]]
mcsel <- merge(mcsel, mc_attributes, by = 'variable', all.x = T, all.y = F)

mcsel[vartype %in% c('q_g', 'q_g0') , lab := sprintf('Species group - %s', labs[as.character(species_group)])]
mcsel[vartype %in% c('q_f', 'q_f0') , lab := sprintf('Fishery group - %s', labs[as.character(fishery_group)])]
mcsel[vartype %in% c('q_gf', 'q_gf0') , lab := sprintf('Sp. x F. group - %s x %s', labs[as.character(species_group)], labs[as.character(fishery_group)])]
mcsel[vartype == 'q0'  , lab := 'Intercept']

mcsel[, lab := factor(lab, levels = c('Intercept',
                                      sort(grep('Fishery', unique(lab), val=T)),
                                      sort(grep('Species', unique(lab), val=T)),
                                      sort(grep('Sp\\. x', unique(lab), val=T))))]

if (mcsel[, any(is.na(lab) | grepl('\\bNA\\b', lab))]) {
    print(mcsel[is.na(lab) | grepl('\\bNA\\b', lab), .N, .(vartype, lab)])
    stop('Some NAs in labels')
}

n.labs <- mcsel[, length(unique(lab))]
n.brks.y <- ifelse(n.labs > 30, 2, 5)

g <- ggplot(mcsel, aes(x = ch_sample, y = value, colour = factor(chain), group = factor(chain))) +
    geom_line(size = 0.2) +
    facet_wrap(~ lab, ncol=1, strip.position = 'left', scales = 'free_y') +
    scale_x_continuous(expand = c(0,0)) +
    scale_y_continuous(breaks = function(lims) pretty(lims, n=n.brks.y, min.n=2)) +
    labs(x = 'MCMC sample', y = NULL) +
    theme_minimal() +
    theme(legend.position='none',
          strip.text.y=element_text(angle=0, hjust = 0, size = 8),
          strip.placement='outside',
          panel.background=element_rect(fill = '#F4F4F4', color = NA),
          panel.grid.minor=element_blank(),
          panel.grid.major.y=element_line(color = 'white'),
          panel.grid.major.x=element_blank(),
          axis.text = element_text(size = 5),
          axis.title.x = element_text(size = 8))
ggsave('assets/traces_vulnerabilities.png', width = 8, height = 9)


library(data.table)
library(rgrass7)
library(sp)
library(WatershedTools)
library(raster)
library(rgdal)

tryCatch(rgrass7::use_sp(), error = function(e) warning(e))

metadat <- fread("catchment_list.csv")[catchment == "vjosa"]
dir <- file.path(metadat$dir, metadat$catchment, metadat$version)
shpdir <- file.path(dir, "shape")
shareDir <- metadat$dir

dir.create(dir, recursive=TRUE, showWarnings = FALSE)
dir.create(shpdir, showWarnings = FALSE)

gisbase <- WatershedTools:::getGISBase()
dem <- raster(file.path(dir, "filled_dem.tif"))
gs <- GrassSession(dem, gisbase, layerName = 'filledDEM')

#############
# Compute drainage direction/flow accumulation
#############
gs <- drainageAccumulation('filledDEM', gs = gs, accumulation = 'accum', drainage = 'drainage')
# compression didn't help these
drain <- GSGetRaster('drainage', gs, file = file.path(dir, "drainage.tif"))
accum <- GSGetRaster('accum', gs, file = file.path(dir, "accumulation.tif"))

plot(drain, col=rainbow(12), xaxt='n', yaxt='n')
plot(log(accum), xaxt='n', yaxt='n')

#############
# Extract the watershed
#	the threshold must be determined empirically, just choosing something that works
#############
thresh <- 0.995
streamChannel <- extractStream(dem = 'filledDEM', gs = gs, accumulation = 'accum',
							   qthresh = thresh, type='both')

#############
# Find an outlet point (by eye-in QGIS) and delineate catchment
#############
dir.create(file.path(dir, "tmp"), showWarnings=FALSE)
writeOGR(streamChannel$vector, file.path(dir, "tmp"), "vjosa_995_unclipped", "ESRI Shapefile")
outlet <- SpatialPoints(matrix(c(5122456, 2000900), nrow=1), proj4string = CRS(proj4string(dem)))
plot(streamChannel$vector, col='blue')
outlet <- snapToStream(outlet, streamChannel$raster, 200)
plot(outlet, add=T, pch=16)

catchment <- catchment(outlet, drainage = 'drainage', gs = gs, areas=FALSE,
					   file = file.path(dir, "catchment.tif"))
plot(catchment, add=TRUE, col="#aa000044")

#############
# Crop the delineated watershed to the catchment
#############
vjosaStream <- cropToCatchment(outlet, streamChannel$raster, streamChannel$vector,
							   'drainage', gs = gs)

#############
# View in QGIS and manually select reaches to delete
#############
writeOGR(vjosaStream$vector, file.path(dir, "tmp"), "vjosa_crop_pretrim", "ESRI Shapefile")

delnodes <- c(354, 352, 350, 11, 4:7, 38, 39, 345, 343, 335, 337, 340, 42, 43, 46, 323, 50:52,
			  57, 59, 64, 240, 241, 302, 306, 311, 308, 248, 279, 249:251, 259, 255, 267, 265, 235, 67,
			  68, 226, 78, 79, 89, 98, 99, 100, 102, 153, 217, 163, 167, 169, 206, 212, 204, 173, 174,
			  175, 178, 180, 186, 181, 182, 190, 191, 193, 105, 141, 135:137, 131, 107, 127, 112, 119)
delPixIDs <- vjosaStream$vector$a_cat_[match(delnodes, vjosaStream$vector$cat)]

### make sure we are deleting the right nodes
test <- vjosaStream$vector
cols <- rep('blue', length(test))
cols[test[[1]] %in% delnodes] <- 'red'
plot(test, col = cols)
testRas <- vjosaStream$raster
plot(testRas, xlim=c(5120000, 5160000), ylim=c(1960000, 2000000))
testRas[testRas %in% delPixIDs] <- -1000
plot(testRas, xlim=c(5120000, 5160000), ylim=c(1960000, 2000000))

indexToKill <- which(vjosaStream$vector[[1]] %in% delnodes)
vjosaStream$vector <- vjosaStream$vector[-indexToKill,]
plot(vjosaStream$vector)
writeOGR(vjosaStream$vector, file.path(dir, "shape"), "vjosa_stream", "ESRI Shapefile")

vjosaStream$raster[vjosaStream$raster %in% delPixIDs] <- NA
plot(vjosaStream$raster)
writeRaster(vjosaStream$raster, file=file.path(dir, "vjosa_stream.tif"), overwrite = TRUE, options=c("COMPRESS=LZW", "PREDICTOR=2"))

# split coordinates for catchment area by reach
pixvals <- values(vjosaStream$raster)
coords <- coordinates(vjosaStream$raster)
df <- cbind(pixvals, coords)
df <- df[complete.cases(df),]
caPts <- by(df, df[,1], function(x) x[,2:3])
saveRDS(caPts, file.path(dir, "tmp", "caPoints_byReach.rds"))


data <- read.csv("ga-data.csv", sep=",")

with(data, {
     Day.Index <- as.Date(Day.Index, format="%m/%d/%Y")

     plot(Day.Index,
          Pageviews,
          xlab = "Date",
          type = "l",
          col = "white",
          main = "Google Analytics",
          ylim = c(0, 200))

     xarea <- c(Day.Index, rev(Day.Index))
     yarea <- c(Pageviews, rep(0, nrow(data)))
     polygon(xarea, yarea, col = rgb(0.3, 0.8, 1, 0.5), border=NA)

     lines(Pageviews ~ Day.Index, col = "navy")

     points(Pageviews ~ Day.Index,
            pch = 21,
            bg = "navy",
            col = "blue")

     abline(a = 100,
            b = 0,
            col = "gray")
})


#functions used to calculate differentiation between two populations or diversity statistics within populations
# make sure the output file is already written in format (header):
# population1	population2	statistic	chromosome	start	end	number_sites	number_variable_sites	calculated_stat
# e.g., write(c("pop1", "pop2", "stat", "chr", "start", "end", "number_sites", "number_variable_sites", "calculated_stat"), ncolumns=9, file=outname, sep="\t")

# input is simplified vcf (entire vcf) and 3-column popmap (ordered the same as the vcf) and output file name
# and the input simple vcf file name that contains the chr and start and end information
# only calculate for invariant sites and biallelic snps
heterozygosity <- function(xxx, popmap, outname, filename) {
	options(scipen=999)
	xxx <- xxx[nchar(xxx[,2]) == 1 & nchar(xxx[,3]) == 1, ]
	for(a in 1:nrow(popmap)) {
		output_rep <- c(popmap[a,1], "none", "heterozygosity", strsplit(filename, ":")[[1]][1],
			as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
			as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]))
		# select this individual
		a_rep <- xxx[,a+3]
		# remove missing genotypes
		a_rep <- a_rep[a_rep != "./."]
		# count number of sites
		a_total <- length(a_rep)
		# remove phasing information
		a_rep <- gsub("\\|", "/", a_rep)
		# find number of heterozygous sites
		a_het <- length(a_rep[a_rep == "0/1"])
		# add to output
		output_rep <- c(output_rep, a_total, a_het, a_het/a_total)
		write(output_rep, file=outname, append=T, ncolumns=9, sep="\t")
	}
}

# function to determine if a site is polymorphic (to be applied across rows)
# used in pi_tajima_theta function
polymorphic_function <- function(xxx) {
	return(length(unique(xxx)))
}
# function to determine frequency of allele 1 (to be applied across rows)
# used in pi_tajima_theta function
p_function <- function(xxx) {
	xxxx <- c(sapply(strsplit(xxx, "/"), "[[", 1), sapply(strsplit(xxx, "/"), "[[", 2))
	xxxx <- length(xxxx[xxxx == 0])
	return(xxxx)
}
# function to determine frequency of allele 2 (to be applied across rows)
# used in pi_tajima_theta function
q_function <- function(xxx) {
	xxxx <- c(sapply(strsplit(xxx, "/"), "[[", 1), sapply(strsplit(xxx, "/"), "[[", 2))
	xxxx <- length(xxxx[xxxx == 1])
	return(xxxx)
}

# input is simplified vcf (subsampled to single population (plus initial three columns)),
# the name of the populations, and output file name
# and the input simple vcf file name that contains the chr and start and end information
# only calculate for invariant sites and biallelic snps
# no missing data allowed
# estimate watterson's theta, nucleotide diversity, and tajima's d with the formulae from
# Carlson et al. 2005: 10.1101/gr.4326505 (equations 1, 2, and 4)

# e.g., xxx <- test[,c(1,2,3,5,6,7)]
pi_tajima_theta <- function(xxx, popname, outname, filename) {
	options(scipen=999)
	# remove sites that are not either invariant or bi-allelic SNPs
	xxx <- xxx[nchar(xxx[,2]) == 1 & nchar(xxx[,3]) == 1, ]
	# remove phasing information
	for(a in 4:ncol(xxx)) {
		xxx[,a] <- gsub("\\|", "/", xxx[,a])
	}
	# remove sites with missing data
	for(a in 4:ncol(xxx)) {
		xxx <- xxx[xxx[,a] != "./.",]
	}

	# define number of chromosomes sampled
	n_chromosomes <- (ncol(xxx) - 3) * 2
	# define number of sites genotyped for this population without missing data
	n_sites <- nrow(xxx)

	# continue if there are sites genotyped
	if(n_sites > 0) {
		# subset to only polymorphic sites
		xxx <- xxx[apply(xxx[,4:ncol(xxx)], 1, polymorphic_function) > 1, ]

		# count polymorphic sites
		n_polymorphic <- nrow(xxx)

		# determine denominator of theta calculation
		theta_denominator <- sum(1 / seq(from=1, to=(n_chromosomes - 1)))

		# continue if there are polymorphic sites
		if(n_polymorphic > 0) {
			# calculate per site theta
			theta <- (n_polymorphic / theta_denominator) / n_sites

			# calculate frequencies of alleles 1 and 2 for each polymorphic site
			p_freq <- as.vector(apply(xxx[,4:ncol(xxx)], 1, p_function)) / n_chromosomes
			q_freq <- as.vector(apply(xxx[,4:ncol(xxx)], 1, q_function)) / n_chromosomes

			# calculate per site nucleotide diversity (pi)
			pi <- sum(2 * p_freq * q_freq) * (n_chromosomes / (n_chromosomes - 1)) / n_sites

			# calculate D using the variance of d (and all necessary subcomponents)
			a1 <- sum(1 / seq(from=1, to=(n_chromosomes - 1)))
			a2 <- sum(1 / (seq(from=1, to=(n_chromosomes - 1))^2))
			b1 <- (n_chromosomes + 1) / (3 * (n_chromosomes - 1))
			b2 <- (2 * (n_chromosomes^2 + n_chromosomes + 3)) / (9 * n_chromosomes * (n_chromosomes - 1))
			c1 <- b1 - (1 / a1)
			c2 <- b2 - ((n_chromosomes + 2) / (a1 * n_chromosomes)) + (a2 / (a1^2))
			e1 <- c1 / a1
			e2 <- c2 / ((a1^2) + a2)
			Var_d <- (e1 * n_polymorphic) + (e2 * n_polymorphic * (n_polymorphic - 1))
			Tajima_D <- ((pi * n_sites - theta * n_sites)) / sqrt(Var_d)

			# write output
			output_rep1 <- c(popname, "none", "theta", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_polymorphic, theta)
			output_rep2 <- c(popname, "none", "pi", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_polymorphic, pi)
			output_rep3 <- c(popname, "none", "Tajima_D", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_polymorphic, Tajima_D)
			write(output_rep1, file=outname, append=T, ncolumns=9, sep="\t")
			write(output_rep2, file=outname, append=T, ncolumns=9, sep="\t")
			write(output_rep3, file=outname, append=T, ncolumns=9, sep="\t")
		} else { # if no polymorphic sites retained
			output_rep1 <- output_rep1 <- c(popname, "none", "theta", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_polymorphic, "NA")
			output_rep2 <- output_rep1 <- c(popname, "none", "pi", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_polymorphic, "NA")
			output_rep3 <- output_rep1 <- c(popname, "none", "Tajima_D", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_polymorphic, "NA")
			write(output_rep1, file=outname, append=T, ncolumns=9, sep="\t")
			write(output_rep2, file=outname, append=T, ncolumns=9, sep="\t")
			write(output_rep3, file=outname, append=T, ncolumns=9, sep="\t")
		}
	} else { # if no sites retained
		output_rep1 <- output_rep1 <- c(popname, "none", "theta", strsplit(filename, ":")[[1]][1],
			as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
			as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
			n_sites, "NA", "NA")
		output_rep2 <- output_rep1 <- c(popname, "none", "pi", strsplit(filename, ":")[[1]][1],
			as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
			as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
			n_sites, "NA", "NA")
		output_rep3 <- output_rep1 <- c(popname, "none", "Tajima_D", strsplit(filename, ":")[[1]][1],
			as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
			as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
			n_sites, "NA", "NA")
		write(output_rep1, file=outname, append=T, ncolumns=9, sep="\t")
		write(output_rep2, file=outname, append=T, ncolumns=9, sep="\t")
		write(output_rep3, file=outname, append=T, ncolumns=9, sep="\t")
	}

}

# function to determine if a site is only missing data for a population (used across rows of vcf)
# used in differentiation function
total_missing <- function(xxx) {
	return(length(xxx[xxx != "./."]) > 0)
}
# function to determine if a site is polymorphic (to be applied across rows) after removing missing
# used in differentiation function
polymorphic_function2 <- function(xxx) {
	xxx <- xxx[xxx != "./."]
	return(length(unique(xxx)))
}

# input is two simplified vcfs (subsampled to single population), already filtered for invariant/biallelic SNPs,
# the names of the populations, and output file name
# and the input simple vcf file name that contains the chr and start and end information
# only calculate for invariant sites and biallelic snps
# fst is calculation of Reich et al. 2009
# fst is the reich et al. 2009 estimator for small sample sizes
# equation presented nicer in Willing et al. 2012 page 9

differentiation <- function(xxx1, xxx2, popname1, popname2, outname, filename) {
	# remove phasing information
	for(a in 1:ncol(xxx1)) {
		xxx1[,a] <- gsub("\\|", "/", xxx1[,a])
	}
	for(a in 1:ncol(xxx2)) {
		xxx2[,a] <- gsub("\\|", "/", xxx2[,a])
	}

	# remove sites that are completely missing from either population
	keep1 <- apply(xxx1, 1, total_missing)
	keep2 <- apply(xxx2, 1, total_missing)
	xxx1 <- xxx1[keep1 == TRUE & keep2 == TRUE, ]
	xxx2 <- xxx2[keep1 == TRUE & keep2 == TRUE, ]

	# count the total number of included genotyped sites at this point
	n_sites <- nrow(xxx1)

	# combine the two matrices to find sites that are variant w/in and between the two pops
	xxx_combined <- cbind(xxx1, xxx2)
	variant_sites <- apply(xxx_combined, 1, polymorphic_function2)

	# keep only variant sites
	xxx1_variant <- xxx1[variant_sites > 1, ]
	xxx2_variant <- xxx2[variant_sites > 1, ]

	# count the number of variant sites
	n_variant_sites <- nrow(xxx1_variant)

	# loop for each polymorphic site to calculate dxy
	dxy_all <- list()
	for(a in 1:nrow(xxx1_variant)) {
		a_rep1 <- as.character(xxx1_variant[a,])
		a_rep2 <- as.character(xxx2_variant[a,])

		# remove missing
		a_rep1 <- a_rep1[a_rep1 != "./."]
		a_rep2 <- a_rep2[a_rep2 != "./."]

		# measure proportion of reference allele
		a_ref1 <- (length(a_rep1[a_rep1 == "0/0"]) * 2 + length(a_rep1[a_rep1 == "0/1"]) * 1) / (length(a_rep1) * 2)
		a_ref2 <- (length(a_rep2[a_rep2 == "0/0"]) * 2 + length(a_rep2[a_rep2 == "0/1"]) * 1) / (length(a_rep2) * 2)

		# calc dxy
		dxy_all[[a]] <- a_ref1 * (1 - a_ref2) + a_ref2 * (1 - a_ref1)
	}
	dxy_all <- sum(unlist(dxy_all)) / n_sites

	# loop for each polymorphic site to calculate fst
	numerator_all <- list()
	denominator_all <- list()
	for(a in 1:nrow(xxx1_variant)) {
		a_rep1 <- as.character(xxx1_variant[a,])
		a_rep2 <- as.character(xxx2_variant[a,])

		# remove missing
		a_rep1 <- a_rep1[a_rep1 != "./."]
		a_rep2 <- a_rep2[a_rep2 != "./."]

		# number of individuals per population
		pop1_ind_count <- length(a_rep1)
		pop2_ind_count <- length(a_rep2)

		# non-reference allele counts
		alt_allele_count1 <- (2 * length(a_rep1[a_rep1 == "1/1"]) + 1 * length(a_rep1[a_rep1 == "0/1"]))
		alt_allele_count2 <- (2 * length(a_rep2[a_rep2 == "1/1"]) + 1 * length(a_rep2[a_rep2 == "0/1"]))

		# total allele counts
		all_allele_count1 <- 2 * length(a_rep1)
		all_allele_count2 <- 2 * length(a_rep2)

		# expected heterozygosity for each population
		expected_het1 <- (alt_allele_count1 * (all_allele_count1 - alt_allele_count1)) /
			(all_allele_count1 * (all_allele_count1 - 1))
		expected_het2 <- (alt_allele_count2 * (all_allele_count2 - alt_allele_count2)) /
			(all_allele_count2 * (all_allele_count2 - 1))

		# find the fst numerator and denominator values for this snp (they all get summed and divided for
		# the final estimate)
		numerator_all[[a]] <- (alt_allele_count1 / (2 * pop1_ind_count) -
			alt_allele_count2 / (2 * pop2_ind_count))^2 - (expected_het1 / (2 * pop1_ind_count)) -
			(expected_het2 / (2 * pop2_ind_count))
		denominator_all[[a]] <- numerator_all[[a]] + expected_het1 + expected_het2
	}
	# calculate total fst for this window
	fst_all <- sum(unlist(numerator_all)) / sum(unlist(denominator_all))

	# write to output for dxy and fst
	output_rep1 <- c(popname1, popname2, "Dxy", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_variant_sites, dxy_all)
	output_rep2 <- c(popname1, popname2, "Fst", strsplit(filename, ":")[[1]][1],
				as.numeric(strsplit(strsplit(filename, ":")[[1]][2], "-")[[1]][1]),
				as.numeric(strsplit(strsplit(filename, "-")[[1]][2], ".simple")[[1]][1]),
				n_sites, n_variant_sites, fst_all)
	write(output_rep1, file=outname, append=T, ncolumns=9, sep="\t")
	write(output_rep2, file=outname, append=T, ncolumns=9, sep="\t")

}

# input is one simplified vcfs,
# the popmap, and output file name
# and the input simple vcf file name that contains the chr and start and end information
# only for invariant sites and biallelic snps
# lastly, input number of sites needed to write file

create_fasta_from_vcf <- function(xxx, popmap, outname, filename, num_sites_needed) {
	options(scipen=999)
	# remove sites that are not either invariant or bi-allelic SNPs
	xxx <- xxx[nchar(xxx[,2]) == 1 & nchar(xxx[,3]) == 1, ]

	# keep going only if enough sites
	if(num_sites_needed <= nrow(xxx)) {
		# remove phasing information
		for(a in 4:ncol(xxx)) {
			xxx[,a] <- gsub("\\|", "/", xxx[,a])
		}

		# define names of individuals in output fasta
		output_names_fasta <- paste(">", popmap[,1], sep="")

		# subset the genotypes from the allele info
		allele_info <- xxx[,2:3]
		genotypes <- xxx[,4:ncol(xxx)]

		# convert all numbers in genotypes to actual bases and ambiguities
		for(a in 1:nrow(genotypes)) {
			if(allele_info[a,2] == ".") { # if non-polymorphic
				genotypes[a,] <- gsub("0/0", allele_info[a,1], genotypes[a,])
				genotypes[a,] <- gsub("\\./\\.", "?", genotypes[a,])
			} else { # if polymorphic
				both_genotypes <- sort(as.character(allele_info[a,]))
				if(both_genotypes[1] == "A" & both_genotypes[2] == "C") { het = "M" }
				if(both_genotypes[1] == "A" & both_genotypes[2] == "G") { het = "R" }
				if(both_genotypes[1] == "A" & both_genotypes[2] == "T") { het = "W" }
				if(both_genotypes[1] == "C" & both_genotypes[2] == "G") { het = "S" }
				if(both_genotypes[1] == "C" & both_genotypes[2] == "T") { het = "Y" }
				if(both_genotypes[1] == "G" & both_genotypes[2] == "T") { het = "K" }
				genotypes[a,] <- gsub("0/0", allele_info[a,1], genotypes[a,])
				genotypes[a,] <- gsub("\\./\\.", "?", genotypes[a,])
				genotypes[a,] <- gsub("1/1", allele_info[a,2], genotypes[a,])
				genotypes[a,] <- gsub("0/1", het, genotypes[a,])
			}
		}

		# write output
		for(a in 1:ncol(genotypes)) {
			if(a == 1) {
				write(output_names_fasta[a], file=outname, ncolumns=1)
				write(paste(genotypes[,a], collapse=""), file=outname, ncolumns=1, append=T)
			} else {
				write(output_names_fasta[a], file=outname, ncolumns=1, append=T)
				write(paste(genotypes[,a], collapse=""), file=outname, ncolumns=1, append=T)
			}
		}
	}
}


library(stringr)
source("~esswein/science/region/daq/CA2013/StatModel/PM2.5.Analysis.filters.r")
source("~esswein/science/region/daq/CA2013/StatModel/maiac.OK.R")
source('~esswein/lib/R/strssep.R')
source('~esswein/lib/R/getbits.R')

# Get rid of old warnings:
## doesn't work: suppressWarnings(warning(''))
assign("last.warning", NULL, envir = baseenv())
# Grid resolution in degrees:
res.lat = .01
# Margin in degrees for "large" grid.
# The large grid is used for calculating streamlines.
ext.margin = 10

region = 'SJV'
subregion = ''
regdotsub = region
if (subregion != '') regdotsub = str_c(region,'.',subregion)

# Define top level; someone else can change it.
data.dir = '~esswein/science/region/daq/CA2013/Data.extracted/'

# Need both read and write permssions for this directory:
result.dir = str_c('~esswein/science/region/daq/CA2013/StatModel/NEW.',region,'.PM2.5.Regress.results')
# result.dir = '~esswein/science/region/daq/CA2013/testdir/'
rdperm = file.access(result.dir,mode=2+4)
if (rdperm != 0) stop(str_c('Permissions not set to use ',result.dir))

# Specify the actual data to be used for the regression:
# For example, AOT might be either MAIAC 'AOT_550' or Aeronet 'AOT_500.D'
# The list index in model.vars is the generic name; the element is the particular name.
# See ~esswein/science/region/daq/CA2013/Maps/site.data.names.doc
# for information on the "extracted" data array
# submodel corresponds to the choices made by further edits below here.
# "info" = Any additional information the user may want to use to characterize the run:
info = c()
model20.def = list(series.id = 'CWV' , model = PM2.5 ~ I(AOT/CWV)  + I(lon - mean(lon)) + (I(AOT/CWV)+1 | DOY ) , model.id = 'CM.hdist' , model.vars = list(AOT='AOT550.M',CWV='CWV.M') )

rgr = model20.def

info = c('No PM2.5 filtering')
daterange = c(20121119,20130218)
filters = c()
filters.df = c()
# filter.list = c('SJV.geography') # Don't need; don't have "hdist" anymore.
# filter.list = c('CWV')
# For models using fewer variables, ordinarily there will be more
# complete cases. But want to not have more; want to use the same
# points as for the more restrictive model.
# Note that we want to make sure not to go in the other direction of using days
# from a less restricted data frame, for analyzing a more restrictive
# data frame.
#
# To compare models, want to use the same data for each.
# Since different variables are regressedin different models,
# the number of complete cases will differ. Thereofore, to do a set
# of models, need the intersection of the data that would have
# been used for each.
# The present case we are using the days from the following.
# We are not set up to do a set of models, only one at at time,
# So the common data set must be chosen "manually".
dat.regress.longformula = readRDS('/Users/esswein/science/region/daq/CA2013/StatModel/SJV.PM2.5.Regress.results/Regress.PM2.5.AOT.B.hdist.Xc.rds')
row.list = rownames(model.frame(dat.regress.longformula$fit))
DOY.list = unique(sort(dat.regress.longformula$site.df$DOY))
site.delete.list = strssep('EPA_Davis EPA_Coarsegold EPA_Roseville EPA_Sacramento-TStreet EPA_San.Andreas')
local.hour.list = 12:18
  do.save = F ; do.pdf = F ; do.txt = F
file.regress = str_c(result.dir,'/',region,'.',rgr$series.id,'.')
if (subregion != '') file.regress = str_c(file.regress,subregion,'.')
if (rgr$model.id != '') file.regress = str_c(file.regress,rgr$model.id,'.')
file.regress = str_c(file.regress,'Regress.rds')

  source("~esswein/science/region/daq/CA2013/StatModel/run.Regress.PM2.5.r")
  source("~esswein/science/region/daq/CA2013/StatModel/Regress.PM2.5.Plot.r")
  source("~esswein/science/region/daq/CA2013/StatModel/ConnnectHiCorResiduals.r")
  source("~esswein/science/region/daq/CA2013/StatModel/xvalid.loo.r")


check_res <- function(lon,lat){

    rs = 0

    if(all(dim(lat) == dim(lon)) == FALSE){
      write("lat/lon lattices with different dimensions...", stderr())
    }

    reso <- round(get_res(lon,lat),digit=3)

    if(round((range(lat)[2]-range(lat)[1])/nrow(lat),digit=3) != reso){
        write("lat resolution is not constant...", stderr())
        rs = rs +1
    }

    if(round((range(lon)[2]-range(lon)[1])/ncol(lon),digit=3) != reso){
        write("lon resolution is not constant...", stderr())
        rs = rs +1
    }

    return(rs)
}

get_res <- function(lon,lat){

    resx <- lon[nrow(lon),2] - lon[nrow(lon),1]
    resy <- lat[nrow(lat)-1,1] - lat[nrow(lat),1]

    if(round(resx,digit=6) == round(resy,digit=6)){
        return(resx)
    } else {
        warning("raster resolution differs...")
        return(list("resx"=resx,"resy"=resy))
    }
}

get_ext <- function(lon,lat){

    ext <- extent(as.numeric(c(range(lon),range(lat))))
    return(ext)

}

write_stack_by_vars <- function(dates,agg='annual',rs_crop=TRUE){

    dates <- data.frame(fulldate=dates,year=format(dates,'%Y'),id_rows=seq(1,length(dates),1))

    # Crop for the eastern part of US
    ext_crop <- ext
    ext_crop[c(1,4)] <- c(-97,63)

    if (agg == 'monthly') {

        for (t in 1:dim(dates)[1]){
            rs_date <- dates[t,1]

            tp_tasmin <- as.matrix(ls_arr_vars$tasmin[t,,])
            tp_tasmax <- as.matrix(ls_arr_vars$tasmax[t,,])
            tp_pr <- as.matrix(ls_arr_vars$pr[t,,])

            tp_tasmin[which(tp_tasmin=='NaN')] <- NA
            tp_tasmax[which(tp_tasmax=='NaN')] <- NA
            tp_pr[which(tp_pr=='NaN')] <- NA

            rs_tmin <- raster(tp_tasmin)
            rs_tmax <- raster(tp_tasmax)
            rs_pr <- raster(tp_pr)

            extent(rs_tmin) <- extent(rs_tmax) <- extent(rs_pr) <- ext
            projection(rs_tmin) <- projection(rs_tmax) <- projection(rs_pr) <- CRS("+proj=longlat +ellps=GRS80 +datum=NAD83 +no_defs ")

            st <- stack(rs_tmin,rs_tmax,rs_pr)

            if(rs_crop==TRUE){st<-crop(st,ext_crop)}

            names(st) <- c("tmin","tmax","pr")
            NAvalue(st) <- -9999

            invisible(writeRaster(stack(st), str_c(argList$folder_outputs,str_replace_all(argList$hdf,".mat",""),"/",names(st),"-",str_replace_all(argList$hdf,".mat",""),"-", str_replace_all(rs_date,"[X.]",""),".asc"), format='ascii',overwrite=TRUE,bylayer=TRUE))

            rm(st,rs_tmin,rs_tmax,rs_pr,tp_tasmin,tp_tasmax,tp_pr)
        }

    } else if(agg=='annual_biovars'){

        #Get min and max rowid for each year
        summary_dates <- as.data.frame(dates %>% group_by(year) %>% summarise(min_row=min(id_rows),max_row=max(id_rows)))

        for (r in 1:dim(summary_dates)[1]){
            st_final <- st_tmin <- st_tmax <- st_pr <- stack()
            yr <- summary_dates[r,1]

            for (l in summary_dates[r,2]:summary_dates[r,3]){
                # Storing layers (one year)
                tp_tasmin <- as.matrix(ls_arr_vars$tasmin[l,,])
                tp_tasmax <- as.matrix(ls_arr_vars$tasmax[l,,])
                tp_pr <- as.matrix(ls_arr_vars$pr[l,,])

                tp_tasmin[which(tp_tasmin=='NaN')] <- NA
                tp_tasmax[which(tp_tasmax=='NaN')] <- NA
                tp_pr[which(tp_pr=='NaN')] <- NA

                rs_tmin <- raster(tp_tasmin)
                rs_tmax <- raster(tp_tasmax)
                rs_pr <- raster(tp_pr)

                st_tmin <- addLayer(st_tmin,rs_tmin)
                st_tmax <- addLayer(st_tmax,rs_tmax)
                st_pr <- addLayer(st_pr,rs_pr)

                rm(rs_tmin,rs_tmax,rs_pr,tp_tasmin,tp_tasmax,tp_pr)
            }

            #Set proj and extent
            extent(st_tmin) <- extent(st_tmax) <- extent(st_pr) <- ext
            projection(st_tmin) <- projection(st_tmax) <- projection(st_pr) <- CRS("+proj=longlat +ellps=GRS80 +datum=NAD83 +no_defs ")

            #Set NA value
            NAvalue(st_tmin) <- NAvalue(st_tmax) <- NAvalue(st_pr) <- -9999

            # Crop on area
            if(rs_crop==TRUE){
                st_tmin <-  crop(st_tmin,ext_crop)
                st_tmax <- crop(st_tmax,ext_crop)
                st_pr <- crop(st_pr,ext_crop)
            }

            bios <- biovars(st_pr,st_tmin,st_tmax)

            invisible(writeRaster(bios, str_c(argList$folder_outputs,str_replace_all(argList$hdf,".mat",""),"/",names(bios),"-",str_replace_all(argList$hdf,".mat",""),"-", yr,".asc"), format='ascii',overwrite=TRUE,bylayer=TRUE))

        }

    } else {
        write("you need to specify temporal aggregation (monthly/annual_biovars)...", stderr())
    }

}

pg_export <- function(outdir) {

    cmd_export <- str_c(argList$rs2pg," -a -s 4326 -f raster -r -Y ",outdir,"*.asc -F -t auto clim_rs.fut_clim_vars 2>/dev/null | psql -h ", argList$serverhost ," -p ", argList$port, " -d ", argList$database, " -U ", argList$user)

    system(cmd_export,ignore.stdout = TRUE,ignore.stderr = TRUE, wait=TRUE)

}


#' Grab Dat File Index Selectivity Options
#'
#' This function gets index selectivity options from the original ASAP.DAT file.
#' @param wd directory where ASAP run is located
#' @param asap.name Base name of original dat file (without the .dat extension)
#' @param asap name of the variable that read in the asap.rdat file
#' @return list of fleet names and index names
#' @export

GrabDatFileIndexSelOptions <- function(wd,asap.name,asap){
  dat.file.index.sel.options <- NULL
  my.file.name <- paste0(wd, "\\", asap.name, ".dat")
  if (file.exists(my.file.name)){
    datfile <- readLines(con = my.file.name)
    nlines <- seq(1, length(datfile))
    myval <- c("# Index Selectivity Options 1=by age, 2=logisitic, 3=double logistic",
               "# Survey Selectivity Type")  # this one written in retro file
    index.sel.options.line <- nlines[datfile %in% myval]
    if (length(index.sel.options.line) > 0){
      dat.file.all.index.sel.options <- scan(file = my.file.name,
                                             n = asap$parms$navailindices,
                                             skip = index.sel.options.line)
      dat.file.index.sel.options <- dat.file.all.index.sel.options[asap$initial.guesses$index.use.flag==1]
    }
  } # end if-test for dat file

  return(dat.file.index.sel.options)

}