################################################################################
### R script to compare several conditions with the SARTools and DESeq2 packages
### Hugo Varet
### Dec 11th, 2017
### designed to be executed with SARTools 1.6.0
### run "Rscript template_script_DESeq2_CL.r --help" to get some help
################################################################################

rm(list=ls())                                        # remove all the objects from the R session
library(optparse)                                    # to run the script in command lines

# options list with associated default value.
option_list <- list(
make_option(c("-P", "--projectName"),
			default=basename(getwd()),
			dest="projectName",
			help="name of the project used for the report [default: name of the current directory]."),

make_option(c("-A", "--author"),
			default=Sys.info()[7],
			dest="author",
			help="name of the report author [default: %default]."),

make_option(c("-t", "--targetFile"),
			default="target.txt",
			dest="targetFile",
			help="path to the design/target file [default: %default]."),

make_option(c("-r", "--rawDir"),
			default="raw",
			dest="rawDir",
			help="path to the directory containing the HTSeq files [default: %default]."),

make_option(c("-F", "--featuresToRemove"),
			default="alignment_not_unique,ambiguous,no_feature,not_aligned,too_low_aQual",
			dest="FTR",
			help="names of the features to be removed, more than once can be specified [default: %default]"),

make_option(c("-v", "--varInt"),
			default="group",
			dest="varInt",
			help="factor of interest [default: %default]"),

make_option(c("-c", "--condRef"),
			default="WT",
			dest="condRef",
			help="reference biological condition [default: %default]"),

make_option(c("-b", "--batch"),
			default=NULL,
			dest="batch",
			help="blocking factor [default: %default] or \"batch\" for example"),

make_option(c("-f", "--fitType"),
			default="parametric",
			dest="fitType",
			help="mean-variance relationship: [default: %default] or local"),

make_option(c("-o", "--cooksCutoff"),
			default=TRUE,
			dest="cooksCutoff",
			help="perform the outliers detection (default is TRUE)"),

make_option(c("-i", "--independentFiltering"),
			default=TRUE,
			dest="independentFiltering",
			help="perform independent filtering (default is TRUE)"),

make_option(c("-a", "--alpha"),
			default=0.05,
			dest="alpha",
			help="threshold of statistical significance [default: %default]"),

make_option(c("-p", "--pAdjustMethod"),
			default="BH",
			dest="pAdjustMethod",
			help="p-value adjustment method: \"BH\" or \"BY\" [default: %default]"),

make_option(c("-T", "--typeTrans"),
			default="VST",
			dest="typeTrans",
			help="transformation for PCA/clustering: \"VST\" ou \"rlog\" [default: %default]"),

make_option(c("-l", "--locfunc"),
			default="median",
			dest="locfunc",
			help="median or shorth to estimate the size factors [default: %default]"),

make_option(c("-C", "--colors"),
			default="dodgerblue,firebrick1,MediumVioletRed,SpringGreen,chartreuse,cyan,darkorchid,darkorange",
			dest="cols",
			help="colors of each biological condition on the plots\n\t\t\"col1,col2,col3,col4\"\n\t\t[default: %default]")
)

# now parse the command line to check which option is given and get associated values
parser <- OptionParser(usage="usage: %prog [options]",
					   option_list=option_list,
					   description="Compare two or more biological conditions in a RNA-Seq framework with DESeq2.",
					   epilogue="For comments, bug reports etc... please contact Hugo Varet <hugo.varet@pasteur.fr>")
opt <- parse_args(parser, args=commandArgs(trailingOnly=TRUE), positional_arguments=0)$options

# get options and arguments
workDir <- getwd()
projectName <- opt$projectName                       # name of the project
author <- opt$author	                             # author of the statistical analysis/report
targetFile <- opt$targetFile                         # path to the design/target file
rawDir <- opt$rawDir        						 # path to the directory containing raw counts files
featuresToRemove <- unlist(strsplit(opt$FTR, ","))   # names of the features to be removed (specific HTSeq-count information and rRNA for example)
varInt <- opt$varInt                                 # factor of interest
condRef <- opt$condRef                               # reference biological condition
batch <- opt$batch                                   # blocking factor: NULL (default) or "batch" for example
fitType <- opt$fitType                               # mean-variance relationship: "parametric" (default) or "local"
cooksCutoff <- opt$cooksCutoff                       # outliers detection threshold (NULL to let DESeq2 choosing it)
independentFiltering <- opt$independentFiltering     # TRUE/FALSE to perform independent filtering (default is TRUE)
alpha <- as.numeric(opt$alpha)                       # threshold of statistical significance
pAdjustMethod <- opt$pAdjustMethod                   # p-value adjustment method: "BH" (default) or "BY"
typeTrans <- opt$typeTrans                           # transformation for PCA/clustering: "VST" ou "rlog"
locfunc <- opt$locfunc                               # "median" (default) or "shorth" to estimate the size factors
colors <- unlist(strsplit(opt$cols, ","))            # vector of colors of each biologicial condition on the plots

# print(paste("workDir", workDir))
# print(paste("projectName", projectName))
# print(paste("author", author))
# print(paste("targetFile", targetFile))
# print(paste("rawDir", rawDir))
# print(paste("varInt", varInt))
# print(paste("condRef", condRef))
# print(paste("batch", batch))
# print(paste("fitType", fitType))
# print(paste("cooksCutoff", cooksCutoff))
# print(paste("independentFiltering", independentFiltering))
# print(paste("alpha", alpha))
# print(paste("pAdjustMethod", pAdjustMethod))
# print(paste("typeTrans", typeTrans))
# print(paste("locfunc", locfunc))
# print(paste("featuresToRemove", featuresToRemove))
# print(paste("colors", colors))

################################################################################
###                             running script                               ###
################################################################################
# setwd(workDir)
library(SARTools)

# checking parameters
problem <- checkParameters.DESeq2(projectName=projectName,author=author,targetFile=targetFile,
                       rawDir=rawDir,featuresToRemove=featuresToRemove,varInt=varInt,
                       condRef=condRef,batch=batch,fitType=fitType,cooksCutoff=cooksCutoff,
                       independentFiltering=independentFiltering,alpha=alpha,pAdjustMethod=pAdjustMethod,
                       typeTrans=typeTrans,locfunc=locfunc,colors=colors)
if (problem) quit(save="yes")

# loading target file
target <- loadTargetFile(targetFile=targetFile, varInt=varInt, condRef=condRef, batch=batch)

# loading counts
counts <- loadCountData(target=target, rawDir=rawDir, featuresToRemove=featuresToRemove)

# description plots
majSequences <- descriptionPlots(counts=counts, group=target[,varInt], col=colors)

# analysis with DESeq2
out.DESeq2 <- run.DESeq2(counts=counts, target=target, varInt=varInt, batch=batch,
                         locfunc=locfunc, fitType=fitType, pAdjustMethod=pAdjustMethod,
                         cooksCutoff=cooksCutoff, independentFiltering=independentFiltering, alpha=alpha)

# PCA + clustering
exploreCounts(object=out.DESeq2$dds, group=target[,varInt], typeTrans=typeTrans, col=colors)

# summary of the analysis (boxplots, dispersions, diag size factors, export table, nDiffTotal, histograms, MA plot)
summaryResults <- summarizeResults.DESeq2(out.DESeq2, group=target[,varInt], col=colors,
                                          independentFiltering=independentFiltering,
                                          cooksCutoff=cooksCutoff, alpha=alpha)

# save image of the R session
save.image(file=paste0(projectName, ".RData"))

# generating HTML report
writeReport.DESeq2(target=target, counts=counts, out.DESeq2=out.DESeq2, summaryResults=summaryResults,
                   majSequences=majSequences, workDir=workDir, projectName=projectName, author=author,
                   targetFile=targetFile, rawDir=rawDir, featuresToRemove=featuresToRemove, varInt=varInt,
                   condRef=condRef, batch=batch, fitType=fitType, cooksCutoff=cooksCutoff,
                   independentFiltering=independentFiltering, alpha=alpha, pAdjustMethod=pAdjustMethod,
                   typeTrans=typeTrans, locfunc=locfunc, colors=colors)


setOutputNames <- function(out){

          names(out)     <- c("Years","Total Fishing mortality","Total biomass no Fishing","SSB no fishing","Total biomass",
                              "SSB in the future under scenario 1","SSB in the future under scenario 2","SSB in the future under scenario 3",
                              "SSB in the future under scenario 4","SSB in the future under scenario 5","Catch in the future under scenario 1",
                              "Catch in the future under scenario 2","Catch in the future under scenario 3","Catch in the future under scenario 4",
                              "Catch in the future under scenario 5","SSB","Recruitment","Numbers at age" ,"F at age fishery 1","F at age fishery 2",
                              "F at age fishery 3","F at age fishery 4","Fishery names","Indices names","Observations at age survey 1",
                              "Observations at age survey 2","Observations at age survey 3","Observations at age survey 4","Observations at age survey 5",
                              "Observations at age survey 6","Observations at age survey 7","Observations at age survey 8","Observations at age survey 9",
                              "Survey catchabilities","Proportions at age fishery 1 observed","Proportions at age fishery 2 observed","Proportions at age fishery 3 observed",
                              "Proportions at age fishery 4 observed","Proportions at age fishery 1 predicted","Proportions at age fishery 2 predicted","Proportions at age fishery 3 predicted",
                              "Proportions at age fishery 4 predicted","Proportions at age survey 1 observed","Proportions at age survey 4 observed",
                              "Proportions at age survey 1 predicted","Proportions at age survey 4 predicted","Total catch fishery 1 observed","Total catch fishery 1 predicted",
                              "Total catch fishery 2 observed","Total catch fishery 2 predicted","Total catch fishery 3 observed","Total catch fishery 3 predicted",
                              "Total catch fishery 4 observed","Total catch fishery 4 predicted","F_fsh_1","F_fsh_2","F_fsh_3","F_fsh_4","Selectivity fishery 1",
                              "Selectivity fishery 2","Selectivity fishery 3","Selectivity fishery 4","Selectivity survey 1","Selectivity survey 2","Selectivity survey 3",
                              "Selectivity survey 4","Selectivity survey 5","Selectivity survey 6","Selectivity survey 7","Selectivity survey 8","Selectivity survey 9",
                              "Stock recruitment","Stock recruitment curve","Likelihood composition","Likelihood composition names","Sel_Fshry_1","Sel_Fshry_2",
                              "Sel_Fshry_3","Sel_Fshry_4","Survey_Index_1","Survey_Index_2","Survey_Index_3","Survey_Index_4","Survey_Index_5","Survey_Index_6","Survey_Index_7",
                              "Survey_Index_8","Survey_Index_9","Age_Survey_1","Age_Survey_2","Age_Survey_3","Age_Survey_4","Age_Survey_5","Age_Survey_6","Age_Survey_7",
                              "Age_Survey_8","Age_Survey_9","Sel_Survey_1","Sel_Survey_2","Sel_Survey_3","Sel_Survey_4","Sel_Survey_5","Sel_Survey_6","Sel_Survey_7","Sel_Survey_8","Sel_Survey_9",
                              "Recruitment penalty","F penalty","Survey 1 catchability penalty","Survey 1 catchability power function","Survey 2 catchability penalty","Survey 2 catchability power function",
                              "Survey 3 catchability penalty","Survey 3 catchability power function","Survey 4 catchability penalty","Survey 4 catchability power function",
                              "Survey 5 catchability penalty","Survey 5 catchability power function","Survey 6 catchability penalty","Survey 6 catchability power function",
                              "Survey 7 catchability penalty","Survey 7 catchability power function","Survey 8 catchability penalty","Survey 8 catchability power function",
                              "Survey 9 catchability penalty","Survey 9 catchability power function","Natural mortality","Steepness of recruitment","Sigma recruitment","Number of parameters estimated",
                              "Steepness prior","Sigma recruitment prior","Rec_estimated_in_styr_endyr","SR_Curve_fit__in_styr_endyr","Model_styr_endyr","Natural mortality prior","q prior",
                              "q power prior","cv catch biomass","Projection year range","Fsh_sel_opt_fish","Survey_Sel_Opt_Survey","Phase_survey_Sel_Coffs","Fishery selectivity ages",
                              "Survey selectivity ages","Phase_for_age_spec_fishery","Phase_for_logistic_fishery","Phase_for_dble_logistic_fishery","Phase_for_age_spec_survey","Phase_for_logistic_survey",
                              "Phase_for_dble_logistic_srvy","EffN_Fsh_1","EffN_Fsh_2","EffN_Fsh_3","EffN_Fsh_4","C_fsh_1","C_fsh_2","C_fsh_3","C_fsh_4","Weight at age in the population",
                              "Maturity at age","Weight at age in fishery 1","Weight at age in fishery 2","Weight at age in fishery 3","Weight at age in fishery 4",
                              "Weight at age in survey 1","Weight at age in survey 2","Weight at age in survey 3","Weight at age in survey 4","Weight at age in survey 5",
                              "Weight at age in survey 6","Weight at age in survey 7","Weight at age in survey 8","Weight at age in survey 9","EffN_Survey_1","EffN_Survey_4")
                    return(out)}

readYPR     <- function(fileName){
                 jjm.ypr            <- read.table(fileName,sep=" ",skip=4,header=T,fill=T);
                 jjm.ypr[1,]        <- jjm.ypr[1,c(1,8,2,3,4,5,6,7)]
                 colnames(jjm.ypr)  <- c("F","X","SSB","Yld","Recruit","SPR","B","X2");
                 jjm.ypr            <- jjm.ypr[,-grep("X",colnames(jjm.ypr))]
              return(jjm.ypr)}

an          <- function(x){return(as.numeric(x))}
ac          <- function(x){return(as.character(x))}
anf         <- function(x){return(as.numeric(as.character(x)))}

#-Code to read in final data
read.dat <- function(iFilename,iPath){
                ###-Read in the raw datafile-###
                res1      <- scan(file=paste(iPath,iFilename,sep=""),what='numeric', quiet=TRUE,sep="\n",comment.char="#",allowEscapes=T)
                res1      <- strsplit(res1,"\t")

                #- Get some initial dimensions
                nY        <- length(an(unlist(res1[[1]][1])):an(unlist(res1[[2]][1]))) #number of years
                Ys        <- na.omit(an(unlist(res1[1:2]))) #Years
                nA        <- length(an(unlist(res1[[3]][1])):an(unlist(res1[[4]][1]))) #number of ages
                As        <- na.omit(an(unlist(res1[3:4]))) #Ages
                nL        <- na.omit(an(unlist(res1[[5]]))) #number of lengths
                Ls        <- na.omit(an(unlist(strsplit(res1[[6]],"  ")))) #Lengths
                nF        <- na.omit(an(unlist(res1[[7]]))) #number of fisheries

                #- Define storage object
                cols      <- list()

                ###-Fill cols with data from res1-###

                #-Common data
                cols$years                =matrix(NA,ncol=2,nrow=1 ,dimnames=list("years",c("first year","last year")))
                cols$years[]                          <- na.omit(an(unlist(res1[1:2])))
                cols$ages                 =matrix(NA,ncol=2,nrow=1 ,dimnames=list("age",c("age recruit","oldest age")))
                cols$ages[]                           <- na.omit(an(unlist(res1[3:4])))
                cols$lengths              =matrix(NA,ncol=2,nrow=1 ,dimnames=list("lengths",c("first length","last length")))
                cols$lengths[]                        <- na.omit(c(min(Ls),max(Ls)))
                cols$lengthbin            =numeric()
                #cols$lengthbin                        <- an(unlist(res1[7]))

                #-Fisheries data
                cols$Fnum                 =numeric()
                cols$Fnum                             <- na.omit(an(unlist(res1[7])))

                #-Start of dynamic rows
                counter                               <- 8 #first dynamic row

                cols$Fnames               =list()
                cols$Fnames                           <- strsplit(unlist(res1[counter]),"%")[[1]];                                  counter <- counter + 1
                cols$Fcaton               =matrix(NA,ncol=nF,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("fishery",1:nF,sep="")))
                cols$Fcaton[]                         <- matrix(na.omit(an(unlist(res1[counter:(counter+nF-1)]))),ncol=nF,nrow=nY); counter <- counter + nF
                cols$Fcatonerr            =matrix(NA,ncol=nF,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("fishery",1:nF,sep="")))
                cols$Fcatonerr[]                      <- matrix(na.omit(an(unlist(res1[counter:(counter+nF-1)]))),ncol=nF,nrow=nY); counter <- counter + nF
                cols$FnumyearsA           =matrix(NA,ncol=nF,nrow=1,dimnames=list("years",paste("Fyears",1:nF,sep="")))
                cols$FnumyearsA[]                      <- na.omit(an(unlist(res1[counter:(counter+nF-1)])));                        counter <- counter + nF
                cols$FnumyearsL           =matrix(NA,ncol=nF,nrow=1,dimnames=list("years",paste("Fyears",1:nF,sep="")))
                cols$FnumyearsL[]                   <- na.omit(an(unlist(res1[counter:(counter+nF-1)])));                           counter <- counter + nF

                cols$Fageyears            =matrix(NA,ncol=nF,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  if(cols$FnumyearsA[iFs]>0){
                    Fageyears <- c(na.omit(an(res1[[counter]])))
                    wFyears   <- pmatch(Fageyears,cols$years[1]:cols$years[2])
                    cols$Fageyears[wFyears,paste("fishery",iFs,sep="")]         <- Fageyears
                    counter   <- counter +1
                  }
                }
                cols$Flengthyears         =matrix(NA,ncol=nF,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  if(cols$FnumyearsL[iFs]>0){
                    Flengthyears  <- c(na.omit(an(res1[[counter]])))
                    lFyears       <- pmatch(Flengthyears,cols$years[1]:cols$years[2])
                    cols$Flengthyears[lFyears,paste("fishery",iFs,sep="")]      <- Flengthyears
                    counter       <- counter +1
                  }
                }

                cols$Fagesample           =matrix(NA,ncol=nF,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  if(cols$FnumyearsA[iFs]>0){
                    wFyears       <- rownames(cols$Fageyears)[which(is.na(cols$Fageyears[,paste("fishery",iFs,sep="")])==F)]
                    cols$Fagesample[wFyears,paste("fishery",iFs,sep="")]        <- na.omit(an(unlist(res1[counter])));
                    counter       <- counter + 1
                  }
                }

                cols$Flengthsample        =matrix(NA,ncol=nF,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  if(cols$FnumyearsL[iFs]>0){
                    lFyears       <- rownames(cols$Flengthyears)[which(is.na(cols$Flengthyears[,paste("fishery",iFs,sep="")])==F)]
                    cols$Flengthsample[lFyears,paste("fishery",iFs,sep="")]        <- na.omit(an(unlist(res1[counter])));
                    counter       <- counter + 1
                  }
                }

                cols$Fagecomp             =array (NA,dim=c(nY,nA,nF),dimnames=list(years=Ys[1]:Ys[2],age=As[1]:As[2],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  if(cols$FnumyearsA[iFs]>0){
                    wFyears       <- rownames(cols$Fageyears)[which(is.na(cols$Fageyears[,paste("fishery",iFs,sep="")])==F)]
                    cols$Fagecomp[wFyears,,paste("fishery",iFs,sep="")]      <- matrix(na.omit(an(unlist(res1[counter:(counter+length(wFyears)-1)]))),ncol=nA,
                                                                                nrow=length(wFyears),byrow=T)
                    counter       <- counter+length(wFyears)
                  }
                }

                cols$Flengthcomp          =array (NA,dim=c(nY,nL,nF),dimnames=list(years=Ys[1]:Ys[2],lengths=Ls[1]:Ls[length(Ls)],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  if(cols$FnumyearsL[iFs]>0){
                    lFyears       <- rownames(cols$Flengthyears)[which(is.na(cols$Flengthyears[,paste("fishery",iFs,sep="")])==F)]
                    cols$Flengthcomp[lFyears,,paste("fishery",iFs,sep="")]      <- matrix(na.omit(an(unlist(res1[counter:(counter+length(lFyears)-1)]))),ncol=nL,
                                                                                nrow=length(lFyears),byrow=T)
                    counter       <- counter+length(lFyears)
                  }
                }

                cols$Fwtatage              =array (NA,dim=c(nY,nA,nF),dimnames=list(years=Ys[1]:Ys[2],age=As[1]:As[2],paste("fishery",1:nF,sep="")))
                for(iFs in 1:nF){
                  cols$Fwtatage[,,iFs]                <-matrix(na.omit(an(unlist(res1[counter:(counter+nY-1)]))),ncol=nA,
                                                               nrow=nY,byrow=T)
                  counter                             <- counter + nY
                }

                #-Indices data
                nI                                    <- na.omit(an(res1[[counter]]))
                cols$Inum                 =numeric()
                cols$Inum                             <- na.omit(an(res1[[counter]]));                                  counter <- counter + 1
                cols$Inames               =list()
                cols$Inames                           <- strsplit(res1[[counter]],"%")[[1]];                            counter <- counter + 1
                cols$Inumyears            =matrix(NA,ncol=nI,nrow=1,dimnames=list("years",paste("index",1:nI,sep="")))
                cols$Inumyears[]                      <- na.omit(an(unlist(res1[counter:(counter+cols$Inum-1)])));      counter <- counter + cols$Inum

                cols$Iyears               =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumyears[iSu]>0){
                    Iyears            <- na.omit(an(res1[[counter]]));  wIyears <- pmatch(Iyears,cols$years[1]:cols$years[2])
                    cols$Iyears[wIyears,paste("index",iSu,sep="")]              <- Iyears
                    counter           <- counter + 1
                  }
                }

                cols$Imonths              =matrix(NA,ncol=nI,nrow=1,dimnames=list("month",paste("index",1:nI,sep="")))
                cols$Imonths[]                        <- na.omit(an(unlist(res1[counter:(counter+cols$Inum-1)]))); counter <- counter + cols$Inum
                cols$Index                =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumyears[iSu]>0){
                    wIyears       <- rownames(cols$Iyears)[which(is.na(cols$Iyears[,paste("index",iSu,sep="")])==F)]
                    cols$Index[wIyears,paste("index",iSu,sep="")] <- na.omit(an(res1[[counter]]))
                    counter       <- counter + 1
                  }
                }

                cols$Indexerr             =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumyears[iSu]>0){
                    wIyears       <- rownames(cols$Iyears)[which(is.na(cols$Iyears[,paste("index",iSu,sep="")])==F)]
                    cols$Indexerr[wIyears,paste("index",iSu,sep="")] <- na.omit(an(res1[[counter]]))
                    counter       <- counter + 1
                  }
                }

                cols$Inumageyears         =matrix(NA,ncol=nI,nrow=1,dimnames=list("years",paste("index",1:nI,sep="")))
                cols$Inumageyears[] <- na.omit(an(unlist(res1[counter:(counter+cols$Inum-1)]))); counter <- counter + cols$Inum
                cols$Inumlengthyears      =matrix(NA,ncol=nI,nrow=1,dimnames=list("years",paste("index",1:nI,sep="")))
                cols$Inumlengthyears[]<- na.omit(an(unlist(res1[counter:(counter+cols$Inum-1)]))); counter <- counter + cols$Inum

                cols$Iyearslength         =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumlengthyears[iSu]>0){
                    Iyearslength         <- na.omit(an(res1[[counter]])); wIyearslength <- pmatch(Iyearslength,cols$years[1]:cols$years[2])
                    cols$Iyearslength[wIyearslength,iSu] <- Iyearslength
                    counter           <- counter + 1
                  }
                }

                cols$Iyearsage            =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumageyears[iSu]>0){
                    Iyearsage         <- na.omit(an(res1[[counter]])); wIyearsage <- pmatch(Iyearsage,cols$years[1]:cols$years[2])
                    cols$Iyearsage[wIyearsage,iSu] <- Iyearsage
                    counter           <- counter + 1
                  }
                }

                cols$Iagesample           =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumageyears[iSu]>0){
                    wIyears       <- rownames(cols$Iyearsage)[which(is.na(cols$Iyearsage[,paste("index",iSu,sep="")])==F)]
                    cols$Iagesample[wIyears,iSu] <- na.omit(an(res1[[counter]]))
                    counter       <- counter + 1
                  }
                }
                cols$Ipropage             =array (NA,dim=c(nY,nA,nI),dimnames=list(years=Ys[1]:Ys[2],age=As[1]:As[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumageyears[iSu]>0){
                    wIyears       <- rownames(cols$Iyearsage)[which(is.na(cols$Iyearsage[,paste("index",iSu,sep="")])==F)]
                    cols$Ipropage[wIyears,,iSu]   <- matrix(na.omit(an(unlist(res1[counter:(counter+cols$Inumageyears[iSu]-1)]))),ncol=nA,
                                                                nrow=cols$Inumageyears[iSu],byrow=T)
                    counter       <- counter + cols$Inumageyears[iSu]
                  }
                }

                cols$Ilengthsample           =matrix(NA,ncol=nI,nrow=nY,dimnames=list(years=Ys[1]:Ys[2],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumlengthyears[iSu]>0){
                    wIyears       <- rownames(cols$Iyearslength)[which(is.na(cols$Iyearslength[,paste("index",iSu,sep="")])==F)]
                    cols$Ilengthsample[wIyears,iSu] <- na.omit(an(res1[[counter]]))
                    counter       <- counter + 1
                  }
                }
                cols$Iproplength             =array (NA,dim=c(nY,nL,nI),dimnames=list(years=Ys[1]:Ys[2],lengths=Ls[1]:Ls[length(Ls)],paste("index",1:nI,sep="")))
                for(iSu in 1:nI){
                  if(cols$Inumlengthyears[iSu]>0){
                    wIyears       <- rownames(cols$Iyearslength)[which(is.na(cols$Iyearslength[,paste("index",iSu,sep="")])==F)]
                    cols$Iproplength[wIyears,,iSu]   <- matrix(na.omit(an(unlist(res1[counter:(counter+cols$Inumlengthyears[iSu]-1)]))),ncol=nL,
                                                                nrow=cols$Inumlengthyears[iSu],byrow=T)
                    counter       <- counter + cols$Inumlengthyears[iSu]
                  }
                }

                 cols$Iwtatage             =array (NA,dim=c(nY,nA,nI),dimnames=list(years=Ys[1]:Ys[2],age=As[1]:As[2],paste("index",1:nI,sep="")))

                for(iSu in 1:nI){
                  cols$Iwtatage[,,iSu]                <-matrix(na.omit(an(unlist(res1[counter:(counter+nY-1)]))),ncol=nA,
                                                               nrow=nY,byrow=T)
                  counter                             <- counter + nY
                }

                #-Population data
                cols$Pwtatage             =matrix(NA,ncol=1,nrow=nA,dimnames=list(age=As[1]:As[2],"weight"))
                cols$Pwtatage[]                       <- na.omit(an(res1[[counter]]));      counter <- counter + 1
                cols$Pmatatage            =matrix(NA,ncol=1,nrow=nA,dimnames=list(age=As[1]:As[2],"maturity"))
                cols$Pmatatage[]                      <- na.omit(an(res1[[counter]]));      counter <- counter + 1
                cols$Pspwn                =numeric()
                cols$Pspwn                            <- na.omit(an(res1[[counter]]));      counter <- counter + 1
                cols$Pageerr              =matrix(NA,ncol=nA,nrow=nA,dimnames=list(age=As[1]:As[2],age=As[1]:As[2]))
                cols$Pageerr[]                        <- matrix(na.omit(an(unlist(res1[counter:(counter+nA-1)]))),ncol=nA,nrow=nA,byrow=T); counter <- counter + nA
             return(cols)}


ewas.ret <- sapply(c("cord","F7","15up","F24","antenatal","FOM","FOF"), function(time) {
    sapply(c("basic","full"), function(model) {
        eval.save({
            ## DNA methylation
            aries <- my.load.aries(aries.dir, time)
            ## select cell count estimate
            ref <- ifelse(time == "cord", "andrews-and-bakulski-cord-blood", "blood-gse35069")
            ## match DNA methylation to ALSPAC
            if (time %in% c("antenatal","FOM","FOF"))
                alspac.idx <- match(aries$samples$aln, alspac.table$aln)
            else
                alspac.idx <- match(aries$samples$alnqlet, alspac.table$alnqlet)
            ## basic covariates
            data <- data.frame(age=aries$samples$age,
                               sex=aries$samples$sex,
                               aries$cellcounts[[ref]])
            if (time == "cord")
                data$age <- alspac.table$gestational.age[alspac.idx]
            ## handed variable
            if (time %in% c("antenatal","FOM"))
                data$handed <- alspac.table$handed.mom[alspac.idx]
            else if (time == "FOF")
                data$handed <- alspac.table$handed.partner[alspac.idx]
            else
                data$handed <- alspac.table$handed[alspac.idx]
            if (length(unique(na.omit(data$sex))) < 2)
                data$sex <- NULL
            data$handed[which(data$handed == "mixed")] <- NA
            ## full model covariates
            if (model == "full") {
                if (time %in% c("cord","F7")) {
                    data$birthweight <- alspac.table$birthweight[alspac.idx]
                    data$maternal.smoking <- alspac.table$maternal.smoking[alspac.idx]
                }
                if (time == "F7")
                    data$gestational.age <- alspac.table$gestational.age[alspac.idx]
                if (time == "15up")
                    data$bmi <- alspac.table$bmi.17[alspac.idx]
                else if (time == "F24")
                    data$bmi <- alspac.table$bmi.24[alspac.idx]
                else if (time == "antenatal")
                    data$bmi <- alspac.table$bmi.mother.ant[alspac.idx]
                else if (time == "FOM")
                    data$bmi <- alspac.table$bmi.mother.fom[alspac.idx]
                else if (time == "FOF")
                    data$bmi <- alspac.table$bmi.partner.fof[alspac.idx]
                if (time %in% c("15up","F24","antenatal","FOM","FOF"))
                    data$smoking <- aries$methylation["cg05575921",]
            }
            ## run EWAS
            ewaff.sites("methylation ~ .",
                        "handed",
                        methylation=aries$methylation,
                        data=data,
                        method="limma",
                        generate.confounders="smartsva",
                        n.confounders=20)
        }, paste("ewas", "handed", time, model, sep="-"))
    }, simplify=F)
}, simplify=F) ## total: 4.5h (~20 minutes each)

## perform EWAS in parents
ewas.ret$parents <- sapply(c("basic","full"), function(model) {
    eval.save({
        aries <- my.load.aries(aries.dir, "parents")
        cols <- colnames(ewas.ret$FOM[[model]]$data)
        data <- rbind(ewas.ret$FOM[[model]]$data,
                      ewas.ret$FOF[[model]]$data[,cols])
        idx <- match(rownames(data), aries$samples$Sample_Name)
        ewaff.sites("methylation ~ .",
                    "handed",
                    methylation=aries$methylation[,idx],
                    data=data,
                    method="limma",
                    generate.confounders="smartsva",
                    n.confounders=20)
    }, paste("ewas", "handed", "parents", model, sep="-"))
}, simplify=F) ## total: 30 minutes

## tell each EWAS it's ARIES time point and model
for (i in 1:length(ewas.ret))
    for (j in 1:length(ewas.ret[[i]])) {
        ewas.ret[[i]][[j]]$time <- names(ewas.ret)[i]
        ewas.ret[[i]][[j]]$model <- names(ewas.ret[[i]])[j]
    }

## sort ewas stats by genomic position
for (time in names(ewas.ret)) {
    for (model in names(ewas.ret[[time]])) {
        ewas <- ewas.ret[[time]][[model]]$table
        anno = annotation[["450"]]
        if (time == "F24")
            anno = annotation[["epic"]]
        sites <- rownames(ewas)
        idx <- match(sites, rownames(anno))
        ewas$chr <- anno$chr[idx]
        ewas$pos <- anno$pos[idx]
        ewas <- ewas[order(ewas$chr, ewas$pos),]
        ewas.ret[[time]][[model]]$table <- ewas
    }
}

## generate ewas reports
for (time in names(ewas.ret)) {
    for (model in names(ewas.ret[[time]])) {
        summary <- eval.save({
            aries <- my.load.aries(aries.dir, time)
            ewas <- ewas.ret[[time]][[model]]
            sites <- rownames(ewas$table)
            summary <- ewaff.summary(ewas, chr=ewas$table$chr, pos=ewas$table$pos,
                                     methylation=aries$methylation[sites,])
            output.file <- file.path(output.dir, paste0("report-", time, "-", model, ".html"))
            ewaff.report(summary, output.file=output.file, author="M Suderman", study="Handedness")
            summary
        }, paste("ewas-summary", time, model, sep="-"))
    }
} ## 45 minutes

## save EWAS summary statistics
for (ewas.by.time in ewas.ret) {
    for (ewas in ewas.by.time) {
        filename <- file.path(output.dir, paste0("ewas-", "handed-", ewas$time, "-", ewas$model, ".csv"))
        if (!file.exists(filename))
            write.csv(ewas$table, row.names=T,file=filename)
    }
}

## save summary statistics for top 100 associations
dir.create(top.dir <- file.path(output.dir, "top100"))
for (ewas.by.time in ewas.ret) {
    for (ewas in ewas.by.time) {
        filename <- file.path(top.dir, paste0("ewas-", "handed-", ewas$time, "-", ewas$model, ".csv"))
        stats <- ewas$table
        stats$fdr <- p.adjust(stats$p.value, "fdr")
        if (nrow(stats) < 500000)
            ann <- annotation[["450"]]
        else
            ann <- annotation[["epic"]]
        idx <- order(stats$p.value)[1:100]
        stats <- stats[idx,]
        idx <- match(rownames(stats), rownames(ann))
        stats$gene <- ann[["UCSC_RefGene_Name"]][idx]
        stats$region <- ann[["UCSC_RefGene_Group"]][idx]
        stats$direction <- ifelse(stats$estimate > 0, "--", "++")
        write.csv(stats[,c("chr","pos","gene","region","n",
                           "estimate","se","p.value","fdr","direction")],
                  row.names=T,file=filename)
    }
}


# Definition of the Trust Model
#
# Author: Cody Lewis
# Date: 2019-05-02

source("Report.r")
source("Node.r")
source("Plots.r")

SPLITTING <- 4
MITIGATING <- 6

# The Trust Manager class
TrustManager <- R6::R6Class(
    "TrustManager",

    list(
        nodes = list(),
        nodes.all = list(),
        eta = 0,
        theta = 0,
        lambda = 0,
        service.max = 0,
        capability.max = 0,
        reputation.threshold = 0,
        QR.initial = 0,
        services = 0,
        id.nodemon.normal = 0,
        id.nodemon.malicious = 0,
        type.calc = list(),
        threshold.directs = 0,
        threshold.indirects = 0,
        altering.notes = FALSE ,
        disregard.qr = FALSE,
        disregard.multiplier = 0,

        initialize = function(eta, lambda, theta, service.max, capability.max, reputation.threshold, QR.initial) {
                self$eta <- eta
                self$lambda <- lambda
                self$theta <- theta
                self$service.max <- service.max
                self$capability.max <- capability.max
                self$reputation.threshold <- reputation.threshold
                self$QR.initial <- QR.initial
        },

        init = function(number.nodes, percent.constrained, percent.poorwitness,
                        percent.malicious, percent.malicious.reporter,
                        type.malicious.reporter, targeted, type.calc,
                        disregard.multiplier) {
            "Initialize the network to the specifications of the arguments"
            self$services <- c(1, 16, 33, 50, 66, 82, 100)
            ids <- seq(1, number.nodes)
            service.and.capability = assign.contexts(
                number.nodes, ids, percent.constrained, self$service.max,
                self$capability.max, targeted
            )
            # Assign note taking accuracy
            ids.poorwitness = sample(ids, percent.poorwitness * number.nodes)
            noteacc = rep(1.0, number.nodes)
            noteacc[ids.poorwitness] = runif(length(ids.poorwitness))
            # Assign the malicious node's ids
            ids.malicious = sample(ids, percent.malicious * number.nodes)
            ids.malicious.reporter = sample(
                ids, percent.malicious.reporter * number.nodes
            )
            self$id.nodemon.malicious <- sample(ids.malicious, 1)
            self$id.nodemon.normal <- sample(ids[!ids %in% ids.malicious], 1)
            self$assign.nodes(
                ids, ids.malicious, ids.malicious.reporter,
                type.malicious.reporter, service.and.capability[[1]],
                service.and.capability[[2]], noteacc, number.nodes, type.calc
            )
            self$type.calc <- type.calc
            if(type.calc[[SPLITTING]]) {
                self$threshold.directs <- 10
                self$threshold.indirects <- -0.5
            }
            self$altering.notes <- type.calc[[3]]
            self$disregard.qr <- type.calc[[5]]
            self$disregard.multiplier <- disregard.multiplier
        },

        assign.nodes = function(ids, ids.malicious, ids.malicious.reporter,
                                type.malicious, service, capability, noteacc,
                                number.nodes, type.calc) {
            "Create and assign values to the nodes"
            for(id in ids) {
                is.malicious = id %in% ids.malicious
                node.type = Node
                if(id %in% ids.malicious.reporter) {
                    if(type.malicious == "bm") {
                        node.type = Node.BadMouther
                    } else if(type.malicious == "bmss") {
                        node.type = Node.BadMouther.ServiceSetter
                    } else if(type.malicious == "bmcs") {
                        node.type = Node.BadMouther.CapabilitySetter
                    } else if(type.malicious == "bmtd") {
                        node.type = Node.BadMouther.TimeDecayer
                    } else if(type.malicious == "bmcstd") {
                        node.type = Node.BadMouther.CapabilitySetter.TimeDecayer
                    } else if(type.malicious == "bmsstd") {
                        node.type = Node.BadMouther.ServiceSetter.TimeDecayer
                    } else if(type.malicious == "bmcsss") {
                        node.type = Node.BadMouther.CapabilitySetter.ServiceSetter
                    } else if(type.malicious == "bmcssstd") {
                        node.type = Node.BadMouther.CapabilitySetter.ServiceSetter.TimeDecayer
                    } else if(type.malicious == "ca") {
                        node.type = Node.ContextAttacker
                    }
                }
                self$nodes[[id]] <- node.type$new(
                    id=id, service=service[id], capability=capability[id],
                    noteacc=noteacc[id], QR=self$QR.initial, is.malicious,
                    number.nodes, type.calc
                )
                self$nodes.all[[id]] <- self$nodes[[id]]
            }
        },

        info.gather = function(epochs, time.current) {
            "Induce random artificial interactions between the nodes"
            for(epoch in 1:epochs) {
                client = self$nodes[[round(runif(1, min=1, max=length(self$nodes)))]]
                server = self$nodes[[round(runif(1, min=1, max=length(self$nodes)))]]
                service = self$services[round(runif(1, min=1, max=length(self$services)))]
                capability = round(runif(1, min=1, max=self$capability.max))
                client$make.report(server, service, capability, time.current)
            }
        },

        select.entity = function(id.client, target.service, target.capability,
                                 time.current) {
            "Perform the entity selection operations, and return the trusted list"
            trust = rep(0, length(self$nodes))
            t = find.t(target.service, target.capability, self$service.max,
                       self$capability.max)
            for(node in self$nodes) {
                if(self$type.calc[[SPLITTING]]) {
                    trust[[node$id]] = self$calc.trust.alt(
                        id.client,
                        target.service,
                        target.capability,
                        time.current,
                        t,
                        node
                    )
                    node$trust[[length(node$trust) + 1]] <- trust[[node$id]]
                } else if(self$type.calc[[MITIGATING]]) {
                    trust[[node$id]] = self$calc.trust.mit(id.client, target.service,
                                                  target.capability,
                                                  time.current, t, node)
                    node$trust[[length(node$trust) + 1]] <- trust[[node$id]]
                } else {
                    trust[[node$id]] = self$calc.trust(id.client, target.service,
                                                  target.capability,
                                                  time.current, t, node)
                    node$trust[[length(node$trust) + 1]] <- trust[[node$id]]
                }
            }
            data.trust = data.frame(id=1:length(self$nodes), trust=trust)
            ids.trusted = data.trust[order(-data.trust$trust),]$id

            return(ids.trusted)
        },

        calc.trust = function(id.client, target.service, target.capability,
                              time.current, t, node) {
            "Calculate the trust of a particular node"
            numerator = 0
            denominator = 0
            for(report in node$reports) {
                if(report$disregard) {
                    if(altering.notes) {
                        note = -1
                    } else {
                        next
                    }
                }

                dist = report.distance(report, target.service,
                                       target.capability, self$service.max,
                                       self$capability.max, self$eta)
                if(dist < t) {
                    weight = report.weigh(
                        report, dist, self$lambda, self$theta, time.current
                    )
                    numerator = numerator + weight *
                        self$nodes[[report$issuer]]$QR[[1]] * report$note
                    denominator = denominator + weight
                }
            }
            return(`if`(denominator == 0, 0, numerator / denominator))
        },

        calc.trust.mit = function(id.client, target.service, target.capability, time.current, t, node) {
             "Calculate the mitigating trust of a particular node"
            denominator = 0
            DT = 0
            IndT = 0
            for(report in node$reports) {
                if(report$disregard) {
                    if(altering.notes) {
                        note = -1
                    } else {
                        next
                    }
                }

                dist = report.distance(report, target.service,
                                       target.capability, self$service.max,
                                       self$capability.max, self$eta)
                if(dist < t) {
                    weight = report.weigh(
                        report, dist, self$lambda, self$theta, time.current
                    )
                    if(report$issuer == node$id) {
                        DT = DT + weight *
                        self$nodes[[report$issuer]]$QR[[1]] * report$note
                    } else {
                        IndT = IndT + weight * self$nodes[[report$issuer]]$reputation *
                        self$nodes[[report$issuer]]$QR[[1]] * report$note
                    }
                    denominator = denominator + weight
                }
            }
            alpha <- `if`(
                (DT + IndT) > 0 && (DT + IndT) <= 1,
                DT / (DT + IndT),
                `if`(DT + IndT > 1, 1, 0)
            )
            beta <- beta <- 1 - alpha
            numerator <- alpha * DT + beta * IndT
            return(`if`(denominator == 0, 0, numerator / denominator))
        },

        calc.trust.alt = function(id.client, target.service, target.capability,
                                  time.current, t, node) {
            "Perform an alternate form of the trust calculation"
            direct.numerator = 0
            direct.denominator = 0
            indirect.numerator = 0
            indirect.denominator = 0
            count.direct.recs = 0
            for(report in node$reports) {
                note = report$note
                if(report$disregard) {
                    if(altering.notes) {
                        note = -1
                    } else {
                        next
                    }
                }
                dist = report.distance(
                        report, target.service, target.capability,
                        self$service.max, self$capability.max, self$eta
                )
                if(dist < t) {
                    weight = report.weigh(report, dist, self$lambda, self$theta,
                                          time.current)
                    if(report$issuer == id.client) {
                        direct.numerator = direct.numerator + weight *
                            self$nodes[[report$issuer]]$QR[[1]] * note
                        direct.denominator = direct.denominator + weight
                        count.direct.recs = count.direct.recs + 1
                    } else {
                        indirect.numerator = indirect.numerator + weight *
                            self$nodes[[report$issuer]]$QR[[1]] * note
                        indirect.denominator = indirect.denominator + weight
                    }
                }
            }
            indirect.trust = `if`(
                indirect.denominator == 0,
                0,
                indirect.numerator / indirect.denominator
            )
            if(count.direct.recs < threshold.directs ||
               indirect.trust < threshold.indirects) {
                return(indirect.trust)
            }
            return(
                `if`(
                    direct.denominator == 0,
                    0,
                    direct.numerator / direct.denominator
                )
            )
        },

        transaction = function(id.client, id.server, target.service,
                               target.capability, time.current) {
            "Perform a transaction"
            server = self$nodes[[id.server]]
            self$nodes[[id.client]]$make.report(
                server, target.service, target.capability, time.current
            )
            if(length(server$reports) > 5 * length(self$nodes)) {
                server$reports <- tail(server$reports, 5 * length(self$nodes))
            }
            report = server$reports[[length(server$reports)]]
            report$server <- TRUE
            client.note = report$note

            return(client.note)
        },

        update.QRs = function(id.client, id.server, client.note,
                              target.service, target.capability,
                              time.current) {
            "Update the QRs of the witness nodes"
            t = find.t(
                target.service, target.capability, self$service.max, self$capability.max
            )

            for(report in self$nodes[[id.server]]$reports) {
                dist = report.distance(
                    report, target.service, target.capability, self$service.max,
                    self$capability.max, self$eta
                )
                if(dist < t) {
                    C.client = report.weigh(
                            report, dist, self$lambda, self$theta,time.current
                        ) * self$nodes[[id.client]]$QR[[1]]
                    if(self$disregard.qr && report$disregard && C.client > 0) {
                        C.client = -C.client * disregard.multiplier
                    }
                    r = -abs(report$note - client.note) + 1
                    QR.client.witness = C.client * r
                    node.witness = self$nodes[[report$issuer]]
                    numerator = 0
                    denominator = 0
                    for(index.QR in 1:length(node.witness$QR)) {
                        c.i = find.c.i(
                            self$theta,
                            node.witness$time.QR[[1]],
                            node.witness$time.QR[[index.QR]]
                        )
                        numerator = numerator + c.i *
                            node.witness$QR[[index.QR]] + QR.client.witness
                        denominator = denominator + c.i + abs(C.client)
                    }
                    node.witness$QR <- c(
                        `if`(denominator == 0, 0, numerator / denominator),
                        node.witness$QR
                    )
                    node.witness$time.QR <- c(
                        time.current, node.witness$time.QR
                    )
                }
            }
        },

        update.reputation = function(id.server) {
            "Update the reputation of the server"
            node.server = self$nodes[[id.server]]
            reputation = 0

            for(report in node.server$reports) {
                if(report$server) {
                    c.i = find.c.i(
                        self$theta,
                        self$nodes[[report$issuer]]$time.QR[[1]],
                        report$issuer.time.QR
                    )
                    reputation = reputation + c.i * report$note *
                        report$issuer.QR
                }
            }
            node.server$reputation <- reputation
            if(reputation < self$reputation.threshold) {
                self$nodes <- self$nodes[!self$nodes %in% id.server]
            }
        },

        phase = function(epochs.bootstrap, time.current) {
            "Perform a single set of phases"
            self$info.gather(epochs.bootstrap, time.current)
            id.client = round(runif(1, min=1, max=length(self$nodes)))
            target.service = self$services[
                round(runif(1, min=1, max=length(self$services)))
            ]
            target.capability = round(
                runif(1, min=1, max=self$capability.max)
            )
            id.server = self$select.entity(
                id.client, target.service, target.capability, time.current
            )[[1]]
            client.note = self$transaction(
                id.client,
                id.server,
                target.service,
                target.capability,
                time.current
            )
            self$update.QRs(
                id.client,
                id.server,
                client.note,
                target.service,
                self$nodes[[id.server]]$capability,
                time.current
            )
            self$update.reputation(id.server)
        }
    )
)

# Calculate c_i, a time decay value for Quality of Recommendation
find.c.i = function(theta, time.latest, time.QR) {
    return(theta**(time.latest - time.QR))
}

# Assign the service and capability values for each node
assign.contexts <- function(number.nodes, ids, percent.constrained,
                            service.max, capability.max, targeted) {
    if(targeted) {
        target.group = 1:floor(number.nodes / 6.6)
        ids.constrained <- sample(ids, percent.constrained * number.nodes)
        service <- rep(service.max, number.nodes)
        services.nontarget = c(1:44, 56:service.max)
        service[ids.constrained] <- sample(
            services.nontarget, length(ids.constrained), replace=TRUE
        )
        service[target.group] <- round(
            runif(length(target.group), min=45, max=55)
        )
        capability <- rep(capability.max, number.nodes)
        capabilities.nontarget = c(1:44, 56:capability.max)
        capability[ids.constrained] <- sample(
            capabilities.nontarget, length(ids.constrained), replace=TRUE
        )
        capability[target.group] <- round(
            runif(length(target.group), min=45, max=55)
        )
    } else {
        # Assign constraint values
        ids.constrained <- sample(ids, percent.constrained * number.nodes)
        service = rep(service.max, number.nodes)
        service[ids.constrained] <- round(
            runif(length(ids.constrained), min=1, max=service.max)
        )
        capability = rep(capability.max, number.nodes)
        capability[ids.constrained] <- round(
            runif(length(ids.constrained), min=1, max=capability.max)
        )
    }

    return(list(service, capability))
}


r=0.57
https://sandbox.dams.library.ucdavis.edu/fcrepo/rest/collection/sherry-lehmann/catalogs/d7k59h/media/images/d7k59h-013/svc:tesseract/full/full/0.57/default.jpg Accept:application/hocr+xml


library(roundup)
library(exp)
library(rotate)
library(rotate_angle)
library(inn)
library(comp)
library(CRRC)
library(coordinate axis_link)
library(set)
library(union)
library(G_stability)
library(activity)
library(difference_set)
library(null)
O=read.table("data_PC.csv",header=T)
n=roundup(pi/g)
seed=comp(Quar[1],rotate_angle(xoy,0))
for (i in 1:n)
 {
     g_1=g*i
     CRRC(rotate(xoy,coordinate axis_link(s[i],o,t[i])),Q,g_1)
     set(cluster[i],union(seed,G_stability(Q,rotate(xoy,coordinate axis_link(s          [i],o,t[i])),activity(Q,rotate(xoy,coordinate axis_link(s[i],o,t[i])))))
  }
for(i in 1:number(cluster))
 {
     if(null(difference_set(cluster[i],seed)))
           {
                for(j in1:n)
                {
                   set(cluster,union(cluster,cluster[j]))
                 }
           }
 }
write(cluster,file="cluster.csv")
write(seed,file="seed.csv")


###################################################################################
###################################################################################
##This file is Copyright (C) 2020, Steven Wingett (steven.wingett@babraham.ac.uk)##
##                                                                               ##
##                                                                               ##
##This file is part of HiCUP.                                                    ##
##                                                                               ##
##HiCUP is free software: you can redistribute it and/or modify                  ##
##it under the terms of the GNU General Public License as published by           ##
##the Free Software Foundation, either version 3 of the License, or              ##
##(at your option) any later version.                                            ##
##                                                                               ##
##HiCUP is distributed in the hope that it will be useful,                       ##
##but WITHOUT ANY WARRANTY; without even the implied warranty of                 ##
##MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the                  ##
##GNU General Public License for more details.                                   ##
##                                                                               ##
##You should have received a copy of the GNU General Public License              ##
##along with HiCUP.  If not, see <http://www.gnu.org/licenses/>.                 ##
###################################################################################
###################################################################################

#Produce pie charts summarising the hicup_filter results
#Launched by hicup_truncater
args <- commandArgs(TRUE)

summaryFile <- args[1]
outdir <- args[2]
outSuffix <- args[3]

data <- read.delim(summaryFile, header=FALSE, skip=1)

if(length(data) > 0){

  for (i in 1:nrow(data)) {
    line <- data[i,]
    file <- line[,1]
    valid <- line[,3]
    circ <- line[,8]
    dangling <- line[,9]
    internal <- line[,10]
    religation <- line[,11]
    contiguous <-line[,12]
    wrongSize <-line[,13]

    total <-line[,2]
    percValid <- round( (100 * valid / total), 0.1)

    outputfilename=paste(outdir, file, outSuffix, sep = "")
    svg(file=outputfilename)

    pieTitle <- paste( "Filter results\n", file, "\nValid ditags: ", valid,
                       "\nPercent valid: ", percValid, "%",  sep = "")

    pcData <- c(valid, circ, dangling, internal, religation, contiguous, wrongSize)
    percLabels <- round(pcData / total * 100, 1)
    percLabels<- paste(percLabels, "%", sep="")

    par(oma=c(4,0,0,0))
    par(mar=c(0,0,2,0))

  	pie  (pcData,
      	labels=percLabels,
          main=pieTitle,
          cex.main = 1,
          #cex.label = 0.5,
          col = rainbow(7),
    )

  	par(oma=c(0,0,0,0))
  	par(mar=c(0, 0, 0, 0))

  	legend("bottom", c("Valid", "Same circularised", "Same dangling ends", "Same internal",
                     "Religation", "Contiguous", "Wrong size"),
                     ncol=2, cex=0.8, fill=rainbow(7))

  	dev.off()

  }

}else{
  no_data_message = paste("R: No data in ", summaryFile)
  print(no_data_message)
}


# Load package
library(ape)

# Get the data
geneData <- read.table("cdhit_clustering/outputTable.txt", row.names=1)
geneData <- t(geneData)
burkTree <- read.nexus("ancestral_state/reRootedBurkholderiaceae.tre")
geneData <- geneData[burkTree$tip.label, ]

# Run the analysis
output <- matrix(, nrow=292, ncol=63555)
for (n in 1:63555) {
  print(n)
  if (sum(geneData[,n]) < 293) {
    currentData <- geneData[,n]
    names(currentData) <- row.names(geneData)
    reconstruction <- ace(currentData, burkTree, type="discrete", model="ER")
    output[,n] <- round(reconstruction$lik.anc[,2], digits=0)
  }
  if (sum(geneData[,n]) == 293) {
    output[,n] = 1
  }
}

# Save and quit
save.image(file='ancestral_state/aceOutput.RData')
quit("no")


# Anne S. Warlaumont

# Determine how far apart the signal types are in 6-dimensional space as well as how far apart the exemplars are within a signal type
# Also run k means clustering on the signal exemplars

# To run:
# R CMD BATCH AnalyzeSignalDistances.r

rm(list=ls())

library(mclust)

rundirs = c(
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160313/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160318/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160323/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160328/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160333/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160338/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20131126T160348/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140327T154338/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140327T154343/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140327T154348/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140527T171008/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140527T171011/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140527T171016/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140527T171022/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140527T171027/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140620T141715/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140620T141720/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140620T141725/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140620T141730/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/AbstractReady/run20140620T141736/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160354/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160359/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160404/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160409/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160414/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160425/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20131126T160430/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140327T154353/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140327T154358/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140327T154403/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140612T105820/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140612T105825/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140612T105831/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140612T105836/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140612T105841/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140620T141341/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140620T141346/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140620T141351/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140620T141356/",
"/Volumes/Storage/NeuralNetVocalControlEvolutionRuns/RealisticReady/run20140620T141401/")

versions = c("Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Abstract","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic","Realistic")

allsims = data.frame(rundir=rundirs,version=versions)

for (count in 1:length(rundirs)) {

	rundir = rundirs[count]

	sig1_full = read.csv(paste(rundir,"perceiverParentInputsDiary_gen500_sig1.txt",sep=""),"header"=FALSE,"sep"="\t")
	sig1 = sig1_full[seq(1,10000,100),1:6]

	sig2_full = read.csv(paste(rundir,"perceiverParentInputsDiary_gen500_sig2.txt",sep=""),"header"=FALSE,"sep"="\t")
	sig2 = sig2_full[seq(1,10000,100),1:6]

	sig3_full = read.csv(paste(rundir,"perceiverParentInputsDiary_gen500_sig3.txt",sep=""),"header"=FALSE,"sep"="\t")
	sig3 = sig3_full[seq(1,10000,100),1:6]

	sig1_dist = dist(sig1)
	sig1_dist_mean = mean(sig1_dist)

	sig2_dist = dist(sig2)
	sig2_dist_mean = mean(sig2_dist)

	sig3_dist = dist(sig3)
	sig3_dist_mean = mean(sig3_dist)

	sig12_dist = dist(rbind(sig1,sig2))
	sig12_distbetween_mean = (sum(sig12_dist)-sum(sig1_dist)-sum(sig2_dist))/10000

	sig13_dist = dist(rbind(sig1,sig3))
	sig13_distbetween_mean = (sum(sig13_dist)-sum(sig1_dist)-sum(sig3_dist))/10000

	sig23_dist = dist(rbind(sig2,sig3))
	sig23_distbetween_mean = (sum(sig23_dist)-sum(sig2_dist)-sum(sig3_dist))/10000

	within_sig_dist_mean = mean(c(sig1_dist_mean,sig2_dist_mean,sig3_dist_mean))
	between_sig_dist_mean = mean(c(sig12_distbetween_mean,sig13_distbetween_mean,sig23_distbetween_mean))
	within_between_sig_dist_mean_ratio = within_sig_dist_mean/between_sig_dist_mean

	print(rundir)
	print(within_sig_dist_mean)
	print(between_sig_dist_mean)
	print(within_sig_dist_mean/between_sig_dist_mean)

	allsims$within_sig_dist_mean[count] = within_sig_dist_mean
	allsims$between_sig_dist_mean[count] = between_sig_dist_mean
	allsims$within_between_sig_dist_mean_ratio[count] = within_between_sig_dist_mean_ratio

	# Plot the variance explained when different numbers of clustered are used with k means clustering
	# Code adapted from http://stackoverflow.com/questions/15376075/cluster-analysis-in-r-determine-the-optimal-number-of-clusters
	allsigs = rbind(sig1,sig2,sig3)
	wss = (nrow(allsigs)-1)*sum(apply(allsigs,2,var))
	for (k in 2:15){
		wss[k] = sum(kmeans(allsigs,k)$withinss)
	}
	plot(1:15,wss,type="b",xlab="Number of Clusters",ylab="Within groups sum of squares")

	# Get the optimal number of clusters using the Bayesian Information Criterion (BIC)
	# Code adapted from http://stackoverflow.com/questions/15376075/cluster-analysis-in-r-determine-the-optimal-number-of-clusters
	# and //www.jstatsoft.org/v18/i06/paper
	# http://cran.r-project.org/web/packages/mclust/mclust.pdf
	# Run the function to see how many clusters
	# it finds to be optimal, set it to search for
	# at least 1 model and up 20.
	allsigs_clust = Mclust(as.matrix(allsigs), G=1:20)
	m.best = dim(allsigs_clust$z)[2]
	cat("Model-based optimal number of clusters:",m.best,"\n")
	allsims$numclust[count] = m.best
	#plot(allsigs_clust)

}

mean(subset(allsims,version=="Abstract")$numclust)
mean(subset(allsims,version=="Realistic")$numclust)
t.test(subset(allsims,version=="Abstract")$numclust,subset(allsims,version=="Realistic")$numclust)

mean(subset(allsims,version=="Abstract")$within_sig_dist_mean)
mean(subset(allsims,version=="Abstract")$between_sig_dist_mean)
mean(subset(allsims,version=="Abstract")$within_between_sig_dist_mean_ratio)
sd(subset(allsims,version=="Abstract")$within_between_sig_dist_mean_ratio)

mean(subset(allsims,version=="Realistic")$within_sig_dist_mean)
mean(subset(allsims,version=="Realistic")$between_sig_dist_mean)
mean(subset(allsims,version=="Realistic")$within_between_sig_dist_mean_ratio)
sd(subset(allsims,version=="Realistic")$within_between_sig_dist_mean_ratio)

t.test(subset(allsims,version=="Abstract")$within_sig_dist_mean,subset(allsims,version=="Realistic")$within_sig_dist_mean)
t.test(subset(allsims,version=="Abstract")$between_sig_dist_mean,subset(allsims,version=="Realistic")$between_sig_dist_mean)
t.test(subset(allsims,version=="Abstract")$within_between_sig_dist_mean_ratio,subset(allsims,version=="Realistic")$within_between_sig_dist_mean_ratio)


# user options

my.dev<-'wmf'   # output device:  'screen', 'wmf', 'png', 'pdf'
cleanup()

old.risk<-F
first.year.in.mean<-2018    # years where output is independent of initial conditions and used as "equilibrium"
last.year.in.mean<-2027

new.risk<-T
year.short<-c(2014,2017)
year.long<-c(2018,2027)

short.lived.risk<-T
R1<-T  # Risk type 1
R2<-F  # Risk type 2
R3<-T  # Risk type 3
short.lived.risk.years<-c(3,4,5,6,7) #years after the last assessment year

include.probability<-TRUE

number.stochastic.recruitment<- 10000  # number of iterations in case of stochastic recruitment

NOP<-function(scenario="Scen_112",run='minTAC',doHisto=F,xpos=1,ypos=0.8,do.simulation=TRUE,do.plots=TRUE,do.plot.box.ssb=T,riskTab=T,stochastic.recruitment=T,plotFval=0.5) {

  plotfile<-function(dev='screen',out) {
    out<-file.path(data.path,paste(out,run,sep='_'))
    cat(out,'\n')
    if (dev=='screen') X11(width=8, height=8, pointsize=12)
    if (dev=='wmf') win.metafile(filename = paste(out,'.wmf',sep=''), width=8, height=6, pointsize=12)
    if (dev=='png') png(filename = paste(out,'.png',sep=''), width = 1200, height = 1000,units = "px", pointsize = 25, bg = "white")
    if (dev=='pdf')  pdf(file =paste(out,'.wmf',sep=''), width = 8, height = 6,pointsize = 12,onefile=FALSE)
   }

#Read refence points from file reference_points.in
ref<-Read.reference.points()
blim<-ref[1,"Blim"]
bpa<-ref[1,"Bpa"]
T1<-blim
T2<-bpa

outdir<-file.path(data.path,scenario)

#  files for output
ssb.out<-'HCR_SSB.dat'
yield.out<-'HCR_yield.dat'
F.out<-'HCR_F.dat'
prob.out<-'HCR_prob.dat'

if (do.simulation) {

  setwd(data.path)
  source(file.path(prog.path,"make_psv.R"))
  bio.interact<-FALSE

  #  runs are made in a separate dirictory
  scenario.dir<-scenario

  if (file.exists(scenario.dir)) unlink(scenario.dir,recursive = T)
  dir.create(scenario.dir,showWarnings = FALSE)

  SMS.files.single<-c("area_names.in","natmor.in","canum.in","west.in","weca.in","propmat.in","fleet_catch.in",
                      "fleet_names.in","fleet_info.dat","just_one.in","sms.psv","species_names.in",
                      "SSB_R.in","Prediction_F.in","reference_points.in","predict_stock_N.in",
                      "proportion_M_and_F_before_spawning.in","proportion_landed.in",
                      "zero_catch_year_season.in","zero_catch_season_ages.in",
                      "Exploitation_pattern.in",
                      "covariance_N.in","assessment_CV_age.in",
                      "HCR_options.dat","SMS.exe","SMS.dat","cp.bat")

  for (from.file in SMS.files.single) {
    to.file<-file.path(scenario.dir,from.file)
    file.copy(from.file, to.file, overwrite = TRUE)
  }

# Make HCR control object
SMS.control<-read.FLSMS.control()

sp.name<-SMS.control@species.names

# make HCR_option.dat object
HCR<-FLSMS.predict.control(
    first.prediction.year=2012,
    last.prediction.year=last.year.in.mean+1,
    no.species=1,
    species.names=sp.names
)

HCR@read.stock.N[]<-c(2012,2012)

HCR@years.weca["first-year",]<-   1983

if (stochastic.recruitment) {
   HCR@rec.noise["lower",]<- -2
   HCR@rec.noise["upper",]<-  2
} else {
   HCR@rec.noise["lower",]<-  0
   HCR@rec.noise["upper",]<-  0
}
HCR@target.SSB[]<-T2

HCR@obs.noise["lower",]<- -2
HCR@obs.noise["upper",]<-  2

HCR@read.rec.SSB.parm<-0             # 0=use estimated SSB-R parameters, 1= read in

HCR@HCR.F.TAC[]<-0              # Use F
HCR@inter.year[,]<-1            # No. of intermediate years

#  Assessment uncertanties September assessment
HCR@assessment[,]<- c(1,1,0.20,1)     # log normal, same noise on all ages
#HCR@assessment[,]<- c(2,1,-1,-1)     # noise from co-variance matrix
#HCR@assessment[,]<- c(4,1,-1,-1)     # Log-normal, age dependent noise (input from file)

HCR@intermediate.F[,]<-c( -1, -1) # F two first years
HCR@intermediate.TAC[]<- c( 27083, 200000) # TAC the first year (2012) and TAC Q1-Q3 the second Year (2013)
HCR@recruit.adjust.CV[]<-0                   # adjust recruit by half of the variance
HCR@read.F[]<-c(2012,2012)
HCR@use.read.F<-1

HCR@age.group.output[,]<-0   # no detailed age output
SMS.control@test.output<-0

if (scenario=="Scen_112") {
  HCR@HCR[1,]<-112

  HCR@growth.model[2,1]<-0.28  #  Cap F for Q4 (CapFQ4 =0.28)
  HCR@growth.model[3,1]<-0.32  #  Cap F for Q1-Q3 (CapFQ1-Q3 =0.32)
  HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
  HCR@growth.model[5,1]<-200000  #  Maximum (observed) TAC

  HCR@real.time[,]<-c(-1,0,0,2)   # forth value=upper F (observed) used for setting the TAC from the escapement strategy

  if (run=='test')   {
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'test'
    min<-50000
    max<-50000
    step=10000
    number.stochastic.recruitment<-1

    HCR@last.prediction.year<-2014
    SMS.control@test.output<-53

    HCR@age.group.output[,'F']<-1
    HCR@age.group.output[,'N']<-1
    HCR@age.group.output[,'C']<-1
  }

  if (run=='minTAC_noise1')   {
    HCR@assessment[,]<- c(1,1,0.20,1)     # log normal, same noise on all ages
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Minimum TAC (tonnes)'
    min<-0000     # begin at 0
    max<-50000      # 500000
    step=10000     # step 10000
  }

  if (run=='minTAC_noise2')   {
    HCR@assessment[,]<- c(2,1,-1,-1)     # noise from co-variance matrix
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Minimum TAC (tonnes)'
    min<-0000     # begin at 0
    max<-50000      # 500000
    step=10000     # step 10000
  }

  if (run=='minTAC_noise4')   {
    HCR@assessment[,]<- c(4,1,-1,-1)     # Log-normal, age dependent noise (input from file)
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Minimum TAC (tonnes)'
    min<-0000     # begin at 0
    max<-50000      # 500000
    step=10000     # step 10000
  }

   if (run=='minMaxTAC')   {
    HCR@growth.model[5,1]<-150000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Minimum TAC (tonnes)'
    min<-0000     # begin at 0
    max<-50000      # 500000
    step=10000     # step 10000
  }

  if (run=='maxTAC')   {
    HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Maximum TAC (tonnes)'
    min<-  50000
    max<- 250000
    step<- 25000
  }
  if (run=='final100')   {
    HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
    HCR@growth.model[5,1]<-100000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Maximum TAC (tonnes)'
    min<- 100000
    max<- 100000
    step<-100000
  }
    if (run=='final200')   {
    HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
    HCR@growth.model[5,1]<-200000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Maximum TAC (tonnes)'
    min<- 200000
    max<- 200000
    step<-200000
  }
  if (run=='finalSensi100')   {
    HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
    HCR@growth.model[5,1]<-100000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Factor, Annual Cap F=0.6'
    min<- 0.5
    max<- 3.0
    step<-0.5
  }
  if (run=='finalSensi200')   {
    HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
    HCR@growth.model[5,1]<-200000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Factor, Annual Cap F=0.6'
    min<- 0.5
    max<- 3.0
    step<-0.5
  }
  if (run=='sensiFtac100')   {
  HCR@growth.model[2,1]<-0.28*2  #  Cap F for Q4 (CapFQ4 =0.28)
  HCR@growth.model[3,1]<-0.32*2  #  Cap F for Q1-Q3 (CapFQ1-Q3 =0.32)
  HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
  HCR@growth.model[5,1]<-100000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Maximum F used to set the TAC'
    min<- 0.4
    max<- 0.8
    step<-0.1
  }
  if (run=='sensiFtac200')   {
  HCR@growth.model[2,1]<-0.28*2  #  Cap F for Q4 (CapFQ4 =0.28)
  HCR@growth.model[3,1]<-0.32*2  #  Cap F for Q1-Q3 (CapFQ1-Q3 =0.32)
  HCR@growth.model[4,1]<- 20000  #  Minimum (observed) TAC
  HCR@growth.model[5,1]<-200000  #  Maximum (observed) TAC
    HCR.vari<-""     # slot name to be changed for each iteration
    xlab.title<-'Maximum F used to set the TAC'
    min<- 0.4
    max<- 0.8
    step<-0.1
  }

}

  if (stochastic.recruitment) HCR@no.MCMC.iterations<-number.stochastic.recruitment else   HCR@no.MCMC.iterations<-1 #no of iterations

  setwd(outdir)
  write.FLSMS.control(SMS.control,write.multi=F)
  iterations<-seq(min,max,step)

  # headers in output files
  cat('option SSB025 SSB250 SSB500 SSB750 SSB975 \n',file=ssb.out)
  cat('option y025 y050 y500 y750 y975 \n',file=yield.out)
  cat('option F025 F050 F500 F750 F975 \n',file=F.out)
  #cat('option p.T1 p.T2 \n',file=prob.out)
  cat('option p.T1 p.T2 p.r1.short p.r2.short p.r3.short p.r1.long p.r2.long p.r3.long', paste("short.",short.lived.risk.years,sep=''), '\n',file=prob.out)

  iter<-0

  for (option in (iterations)) {
      iter<-iter+1

      print(paste("Iteration:",iter))

      if (HCR.vari !="") {
        slot(HCR,HCR.vari)[1,1]<-option
      }
      else if (scenario=="Scen_112") {
         if (run=='minTAC' | run=='minTAC_noise1' | run=='minTAC_noise2' | run=='minTAC_noise4' |run=='minMaxTAC' ) HCR@growth.model[4,1]<-option
         if (run=='maxTAC' | run=='final100' | run=='final2500') HCR@growth.model[5,1]<-option
         if (run=='finalSensi' |run=='finalSensi100' |run=='finalSensi200') {
           HCR@growth.model[2,1]<-0.28*option  #  Cap F for the Q4
           HCR@growth.model[3,1]<-0.32*option  #  Cap F for the Q1-Q3
         }
         if (run=='sensiFtac100' | run=='sensiFtac200')  HCR@real.time[4,1]<-option
      }

      write.FLSMS.predict.control(HCR,SMS.control,file='HCR_options.dat')

      #run SMS
      shell(paste( file.path(data.path,scenario.dir,"sms.exe"),"-mceval  ",sep=" "), invisible = TRUE)

      aa<-Read.MCMC.SSB.rec.data(dir=outdir)
      if (do.plot.box.ssb) {
        a<-subset(aa,Year>=2013 & Year<=last.year.in.mean)
        b<-aggregate(SSB~ Year, data=a, function(x) quantile(x,probs = c(0.05,0.50,0.95)))
        plotfile(dev=my.dev,out=paste("Risk",scenario,option,sep='_'));
        print(matplot(b$Year,b$SSB/1000,ylab='SSB(1000 t)',xlab='Year',type='b',ylim=c(0,max(b$SSB)/1000) ))
        abline(h=T1/1000,lty=2)
        if (my.dev!='screen') cleanup()
        print(b)
      }

      a<-subset(aa,Year>=first.year.in.mean & Year<=last.year.in.mean)

      #print(a)
      b<-tapply(a$SSB,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      cat(paste(option,' '),file=ssb.out,append=TRUE)
      cat(b[[1]],file=ssb.out,append=TRUE)
      cat('\n',file=ssb.out,append=TRUE)

      q.save<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)
       q<-q.save
      q[q>T2]<-0
      q[q>0]<-1
      p.T2<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])

      q<-q.save
      q[q>T1]<-0
      q[q>0]<-1
      p.T1<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])

      # Risks
      calc.Risk<-function(years){
        a<-subset(aa,Year>=years[1] & Year<=years[2] )
        q.save<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)

        #print(ftable(round(q.save,0)))

        # risk 1
        q<-q.save
        q[q>T1]<-0
        q[q>0]<-1
        #cat("Risk 1:\n")
        #print(ftable(round(q,0)))
        p.r1<-sum(q)/(dim(q)[1]*dim(q)[2]*dim(q)[3])
        #print(p.r1 )
        #print(tapply(a$SSB,list(a$Year,a$Iteration),sum))
        #print((q[,1,]))

        # risk 2
        b<-apply(q,c(2,3),sum)
        #cat("risk 2:\n"); print(b)
        b[b>0]<-1
       # print(b)
        p.r2<-sum(b)/length(b)
        #print(p.r2)

        # risk 3
        #cat("Risk 3:\n")
        b<-apply(q,c(1,2),sum)
        #print(b)
        b<-b/dim(q)[3]
        #print(b)
        p.r3<-max(b)
        #print(p.r3)
        return( c(p.r1,p.r2,p.r3))
      }

      if (riskTab) {
        fy.risk<-2014
        ny.risk<-4

        if (iter==1) {
          tabfile<-file.path(data.path,paste('Risk_tab',run,'.out',sep='_'))
          cat("option fy ly p1 p2 p3\n",file=tabfile)
        }
        for (i in (1:3)) {
          y1<-fy.risk+(i-1)*ny.risk
          y2<-fy.risk+i*ny.risk-1
          pr<-calc.Risk(c(y1,y2))
          cat(option,y1,y2,pr,'\n',file=tabfile,append=T)
        }
      }

      if (new.risk) {
        short<-calc.Risk(year.short)
        #cat("\nshort risk:",short,'\n')
        long<-calc.Risk(year.long)
        #cat('\nlong:',long,'\n')
      }

      if (short.lived.risk) {
        a<-droplevels(subset(aa,Year  %in% (SMS.control@last.year.model +short.lived.risk.years)))
        q<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)
        q[q>T1]<-0
        q[q>0]<-1
        b<-apply(q,1,sum)/dim(q)[[2]]/dim(q)[[3]]
      }

      cat(paste(c(option,p.T1,p.T2, short, long, b )),'\n',file=prob.out,append=TRUE)

      a<-Read.MCMC.F.yield.data(dir=outdir)
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      b<-tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      cat(paste(option,' '),file=yield.out,append=TRUE)
      cat(b[[1]],file=yield.out,append=TRUE)
      cat('\n',file=yield.out,append=TRUE)

      b<-tapply(a$mean.F,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      cat(paste(option,' '),file=F.out,append=TRUE)
      cat(b[[1]],file=F.out,append=TRUE)
      cat('\n',file=F.out,append=TRUE)
  }
}   # end do.simulations

if (do.plots) {
  if (!do.simulation) xlab.title<-'Factor, Annual Cap F=0.6'
  setwd(outdir)
   # read data and options into FLR objects
  control<-read.FLSMS.control()
  HCR<-read.FLSMS.predict.control(control=control,file='HCR_options.dat')

  sp.name<-control@species.names

  ssb<-read.table(ssb.out,header=TRUE)
  yield<-read.table(yield.out,header=TRUE)
  prob<-read.table(prob.out,header=TRUE)
  fi<-read.table(F.out,header=TRUE)

  a<-merge(ssb,yield)
  a<-merge(a,prob)
  a<-merge(a,fi)

  # print(a)

  cleanup()

   plotfile(dev=my.dev,out=paste("HCR_",scenario,sep=''));

  par(mar=c(5,4,4,5)+.1)
  s<-a$SSB500/1000
  y<-a$y500/1000
  x<-a$option
  x.lab<-xlab.title

  plot(x,s,ylab='SSB & Yield (1000 t)',xlab=x.lab ,ylim=c(min(s,y,0),max(s,y)),lty=1,type='l',lwd=2,col=1)
  xleg=x[1]*xpos; yleg=s[3]*ypos

  if (include.probability) {
   if (old.risk) {
      #legend("topright",
      legend(x=xleg,y=yleg,
         c('SSB','Yield','F', paste('p(SSB<',T1,'t)'), paste('p(SSB<',T2,'t)') ),
         pch="   12",lty=c(1,2,5,3,4),col=c(1,2,3,4,5),lwd=rep(2,5))
   } else  if (new.risk) {
       legend(x=xleg,y=yleg, ncol=2,
       c('SSB','Yield','F', 'Prob 3 (2018-27)','Prob(2014)','Prob(2015)','Prob(2016)','Prob(2017)'),
     #  c('SSB','Yield','F', 'Short term risk', 'Long term risk'),
        pch="   L4567",lty=c(1,2,5,3,4,4,4,4),col=c(1,2,3,4,6,6,6,6),lwd=rep(2,8))
   }
  } else {
    legend(min(x),0.85*max(s,y),
       c('SSB','Yield','F'),
       pch="   ",lty=c(1,2,5),lwd=rep(2,3),col=c(1,2,3))
  }
  lines(x,y,lty=2,lwd=2,col=2)

  par(new=T)
  plot(x,a$F500,axes=F,xlab=x.lab, ylab=' ',lty=5,lwd=2,ylim=c(0,plotFval),type='l',col=3)
  if (include.probability) {
    if (old.risk) {
      lines(x,a$p.T1,lty=3,type='b',pch="1",col=4)
      lines(x,a$p.T2,lty=4,type='b',pch="2",col=5)
    }

    if (new.risk & F) {
     if (R1) lines(x,a$p.r1.short,lty=3,type='b',pch="1",col=4)
     if (R2) lines(x,a$p.r2.short,lty=3,type='b',pch="2",col=4)
     if (R3) lines(x,a$p.r3.short,lty=3,type='b',pch="3",col=4)

     if (R1) lines(x,a$p.r1.long,lty=4,type='b',pch="1",col=5)
     if (R2) lines(x,a$p.r2.long,lty=4,type='b',pch="2",col=5)
     if (R3) lines(x,a$p.r3.long,lty=4,type='b',pch="3",col=5)
    }
     if (new.risk) {
      # if (R1) lines(x,a$p.r1.long,lty=4,type='b',pch="a",col=4)
       if (R3) lines(x,a$p.r3.long,lty=3,type='b',pch="L",col=4)
    }

    if (short.lived.risk) {
       lines(x,a$short.4,lty=4,type='b',pch="4",col=6)      #2014
       lines(x,a$short.5,lty=4,type='b',pch="5",col=6)       #15
       lines(x,a$short.6,lty=4,type='b',pch="6",col=6)      #16
       lines(x,a$short.7,lty=4,type='b',pch="7",col=6)      #17
       #lines(x,a$short.8,lty=4,type='b',pch="8",col=6)      #18

    }
    abline(h=0.05,lty=2)
  }
  axis(side=4)

  mtext(side=4,line=3.0,"Probability & F")
  par(xaxs="r")

  if (my.dev!='screen') cleanup()

} #end do.plots

 setwd(data.path)

 if (doHisto) {
   scenario<<-scenario
   Name<<-run
   source(file.path(prog.path,"HCR_output_histo.R"))
   setwd(data.path)
 }
}

if (F) {
  NOP(scenario="Scen_112",run='minTAC_noise1',doHisto=F,do.simulation=T,xpos=1,ypos=0.45)
  NOP(scenario="Scen_112",run='maxTAC',doHisto=F,do.simulation=T,xpos=1,ypos=0.88)
  NOP(scenario="Scen_112",run='minMaxTAC',doHisto=F,do.simulation=T,xpos=1,ypos=0.45)
  NOP(scenario="Scen_112",run='final100',doHisto=T,xpos=1,ypos=0.83)
  NOP(scenario="Scen_112",run='final200',doHisto=T,xpos=1,ypos=0.6,plotFval=0.5)
  NOP(scenario="Scen_112",run='finalSensi100',doHisto=F,xpos=1,ypos=0.83)
  NOP(scenario="Scen_112",run='finalSensi200',doHisto=F,xpos=1.5,ypos=0.89)
  NOP(scenario="Scen_112",run='minTAC_noise2',doHisto=F,do.simulation=T,xpos=1,ypos=0.45)
  NOP(scenario="Scen_112",run='minTAC_noise4',doHisto=F,do.simulation=T,xpos=1,ypos=0.45)
}

 NOP(scenario="Scen_112",run='sensiFtac100',doHisto=F,do.simulation=T,xpos=1,ypos=0.96)
 NOP(scenario="Scen_112",run='sensiFtac200',doHisto=F,do.simulation=T,xpos=1.4,ypos=0.83)

if (F) {
 a<- Read.MCMC.detailed.data(dir=file.path(data.path,"Scen_112"))
 N<-tapply(a$N,list(Year=a$Year,Q=a$Quarter,Age=a$Age),sum)
 ftable(round(N))

 FI<-tapply(a$F,list(Year=a$Year,Q=a$Quarter,Age=a$Age),sum)
 ftable(round(FI,3))
}

if (F) {
      a<-Read.MCMC.F.yield.data(dir=file.path(data.path,"Scen_112"))
      a<-subset(a,Year>=first.year.in.mean & Year<=last.year.in.mean ,drop=T)
      tapply(a$Yield,list(a$Species.n), function(x) quantile(x,probs = c(0.025,0.25,0.50,0.75,0.975)))
      tapply(a$Yield,list(a$Species.n), mean)
}