# first lets define some functions, so that the compiler knows what to do ^^

resources <- function()
{
  library(readxl)
  library(dplyr)
  library(xlsx)
}

# data must be passed as excel, or equivalent vector list.
DATA_INPUT <- read_excel("SOURCE_FILE.xlsx", sheet = "SHEET(optional)")

#### functions ####

# despite Main function call others, its important to have all functions in your environment

# main() creates data frame for results to be inserted onto
# @dimensions = multidimensional
main <- function(s){

  # How many rows there are
  totRows <- as.integer(nrow(s))

  # +1 for titles (needed to be able to include all results)
  rw <- sum(totRows + 1)

  # lenght of column-wise document
  len <- length(s)

  # result is declared inside of the scope at this moment,
  # so that the interacions can be sucessifully saved to the global environment
  result <- data.frame(x = rep(NA,rw), stringsAsFactors = F)

  # @param while iterator
  a <- 1
  while (a < (len * 2)) {
    # len*2 since it goes by |Title|%%%|Title|%%%|...

    # operational scope variable
    x <- rep(NA, rw)
    # commit iteration to global scope
    result <<- data.frame(result, x)
    # increment a
    a <- a+1

  } # while END

  stepInCols(s, result, len)

} # function END

# @dimensions = 3
stepInCols <- function(s, result, len) {

  # s = sheet;
  # result = empty data.frame;
  # len = lenght of sheet (cols)

  # increment i to skip columns
  i <- 1

  # Entering Column
  while (i <= len) {

    Sys.sleep(0.3)

    # titles ... name|"%"
    # declared globally not to interfere with while scopes
    x <<- 1 # inc 2,2
    y <<- 2 # inc 2,2
    z <<- 1 # inc 1,1

    # appending "title" information to result data.frame
    result[1,x] <<- colnames(s[i])
    # improves confiability on slower processors, can be altered/removed on faster processors
    Sys.sleep(0.3)
    # adds this string to standarize serialization
    result[1,y] <<- " % % % "

    # get column
    cc <- select(s,i)
    # sort + table occurencies
    ss <- as.data.frame(sort(table(cc), decreasing = T))
    # How many rows there are
    ll <- as.integer(nrow(ss))

    Sys.sleep(0.3)
    appender(s,x,y,ss,ll,z)

    x <- x+2
    y <- y+2
    z <- z+1

    i <- i+1
  } # while END

} # function END

# @dimensions = [ multi -> bidimensional ]
appender <- function(s,x,y,ss,ll,z){

  # (s) reffers to the main sheet, as it is needed to compute 100% results
  # (x) should be passed right before incrementation
  # (y) is alike x, a iterator
  # (ss) is the column being passed as a paramenter
  # (ll) lenght of passed column
  # (z) uni-dimensional integer for sheet to column refference

  Sys.sleep(0.3)

  #names
  k <<- 2
  i <<- 1

  while (i<=ll) {

    # when a result is equal to 100%
    if(length(ss) <= 1){
      Sys.sleep(0.3)
      # since the compiler tries to sum two atomic vectors to culminate 100,
      # but can't find two, since there is just one, the input is manual
      result[k,y] <<- 100 # percentage
      print("100%")
    } else {
      # when result is not == 100%
      result[k,x] <<- as.character(ss[i,1]) # strings
      Sys.sleep(0.3)
      result[k,y] <<- sum(ss[i,2]/percent(ss)) # percentage
      print("appended successfully")
    }

    k <- k+1
    i <- i+1
  }
  print('outside of the fucking while loop')
}

# CUSTOM FUNCTIONS

# calculate the percentual operator
percent <- function(obj){
  sum(obj[,2]/100)
}

# *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*


    convert.to.vector = function(Q, nodes, type="default") {

      x = data.frame( id=as.vector(nodes))
      x$order = seq(1:length(nodes))

      x$id = as.character(x$id)

      if (type=="default")  {
        v = as.data.frame(as.table(Q))
        names(v) = c("r","c","n")
        v$id = paste(v$c, v$r, sep=".")
      } else if (type=="observer.data") {
        v = Q
        names(v) = c("yr", "id", "n")
      }

      x = merge(x, v[,c("id", "n")], by="id", all.x=T, all.y=F, sort=F)
      x = x[order(x$order),]
      rn = x$id
      x = as.vector(x$n)
      x[ !is.finite(x) ] = 0
      x[ x<0.0001 ] = 0
      names(x) = rn

      return(x)
    }


#!/usr/bin/env Rscript

# support batch
#./plot.r -i ../result/10262016/ -m default -c repFamilySINE==\'Alu\' -x log10\(Coverage\) -y sqrt\(Frequency\)

#-m default use x,y
#-m nlog10flog2c
#-m nlog10csqrtf

# ./plot.r -i ../result/10262016/ -m default -c repFamilySINE==\'Alu\' -x Frequency -y Coverage -p clustername_
# ./plot.r -i ../result/10262016/ -m nlog10csqrtf -c repFamilySINE==\'Alu\' -p clustername_

# _result
library('stringr');
library("tools");
library("optparse");
option_list = list(
    make_option(
        c('-i',"--input"),
        type = "character",
        default = NULL,
        help ="input directory",
        metavar = "character"
    ),
    make_option(
        c('-m',"--mode"),
        type = "character",
        default = 'default',
        help ="plot model data",
        metavar = "character"
    ),
    make_option(
        c('-c',"--condition"),
        type = "character",
        default = "repFamilySINE==\'Alu\'",
        help ="subset condition",
        metavar = "character"
    ),
    make_option(
        c('-x',"--xcolumn"),
        type = "character",
        default = NULL,
        help ="x column name",
        metavar = "character"
    ),
    make_option(
        c('-y',"--ycolumn"),
        type = "character",
        default = NULL,
        help ="y column name",
        metavar = "character"
    ),
    make_option(
        c('-p',"--perfix"),
        type = "character",
        default = NULL,
        help ="prefix file name of result ",
        metavar = "character"
    )
);
opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser)

opt_i = opt$i
opt_c = opt$c;
opt_x = opt$x;
opt_y = opt$y;
opt_m = tolower(opt$m);
opt_p = tolower(opt$p);

APP_TOOLS_DIRNAME = 'tools'
APP_TOOLS_DATA_DIRNAME = '_data'
APP_TOOLS_RESULT_DIRNAME = '_result'
APP_DATA_DIRNAME = 'data'
APP_RESULT_DIRNAME = 'result'

if (is.null(opt_i)) {
    print_help(opt_parser)
    stop("at least one argument must be supplied (input directory).n", call.=FALSE);
}

generateResultFilePath <- function(dataFilePath,prefix=""){

    initial.options =  commandArgs(trailingOnly = FALSE)
    file.arg.name = "--file="
    script.name = sub(file.arg.name, "", initial.options[grep(file.arg.name, initial.options)])

    filename = basename(dataFilePath);
    fileext = file_ext(dataFilePath);
    if (prefix==''){
       resultFileName = paste('r_',filename,'.pdf',sep="");
    }else{
       resultFileName = paste('r_',prefix,filename,'.pdf',sep='');
    }
    dataFileAbsPath =file_path_as_absolute(dataFilePath);

    app_root_dir = dirname(dirname(file_path_as_absolute(script.name)))
    app_data_dir = file.path(app_root_dir,APP_DATA_DIRNAME);
	app_result_dir =file.path(app_root_dir , APP_RESULT_DIRNAME);

	result_tmp_dirstr = str_replace_all(dirname(dataFileAbsPath),app_data_dir,'');
	result_tmp_dirstr = str_replace_all(dirname(dataFileAbsPath),app_result_dir,'');

	resultFileDir =file.path(app_result_dir,result_tmp_dirstr);
    if (!dir.exists(resultFileDir)){
        dir.create(path=resultFileDir,recursive=TRUE);
    }

    resultFilePath =file.path(resultFileDir,resultFileName);

    return(resultFilePath);
}

rplot <- function(opt_i,opt_c,opt_x,opt_y,opt_m,opt_p){

    fls = list.files(opt_i,pattern='\\.csv$',full.names=TRUE,recursive=TRUE);

    img_main = ""
    img_xlab = ""
    img_ylab = ""

    for (fl in fls){
        res_fl = generateResultFilePath(fl,opt_p);
        #res = read.table(fl, header=TRUE);
        res = read.csv(fl, sep='\t',header=TRUE);
        print(res_fl);
        head(res);
        pdf(res_fl,width=60,height=40);
    # mgp = c(3,4,0):4->xlab(ylab) and x(y) axes distance
    # mai image margin pdf
        par(mai=c(5,5,5,5),mgp=c(3, 3, 0));

        if (opt_m=='nlog10csqrtf') {
        ## -x -log10  the negative - can not work with -x
            opt_x = '-log10(Coverage)';
            opt_y = 'sqrt(Frequency)';
        } else if (opt_m=='nlog10flog2c'){
            opt_x = "-log10(Frequency)";
            opt_y = "log2(Coverage)";
        } else {

        }

        #with(subset(res, eval(parse(text=opt_c))),plot(eval(parse(text=opt_x)),eval(parse(text=opt_y)),pch=19,cex=2,cex.axis=4,main="",xlab="",ylab=""));
        #with(subset(res, eval(parse(text=opt_c))), points(eval(parse(text=opt_x)),eval(parse(text=opt_y)), pch=19,cex=2,col="red"));

        #with(res,plot(eval(parse(text=opt_x)),eval(parse(text=opt_y)),pch=19,cex=2,cex.axis=4,main="",xlab="",ylab=""));
        #with(subset(res, eval(parse(text=opt_c))),points(eval(parse(text=opt_x)),eval(parse(text=opt_y)),pch=19,cex=2,cex.axis=4,main="",xlab="",ylab="",col="red"));
        with(subset(res, eval(parse(text=opt_c))),plot(eval(parse(text=opt_x)),eval(parse(text=opt_y)),pch=19,cex=2,cex.axis=4,main="",xlab="",ylab="",col="red"));

        #label point
        with(subset(res, eval(parse(text=opt_c))),text(eval(parse(text=opt_x)),eval(parse(text=opt_y)),labels=Index, cex= 0.7, pos=3));

        img_xlab = opt_x;
        img_ylab = opt_y;

        img_main = basename(fl);
        mtext(img_main,side=3,line=8,cex=6);
        mtext(img_xlab,side=1,line=8,cex=6);
        mtext(img_ylab,side=2,line=8,cex=6);

        dev.off();
    }

}
#generateResultFilePath(opt_i);
rplot(opt_i,opt_c,opt_x,opt_y,opt_m,opt_p);


#' @importFrom dismo maxent
#' @export
fit_maxent_model <-
  function(sp, data, bg, preds, coords = c("longitude", "latitude"),
           maxent_args = c("hinge=FALSE", "threshold=FALSE"),
           sp_col = "species", sp_grp_col = "species_group",
           bg_sp_grp_col = "species_group") {
    data <- as.data.frame(data)
    bg <- as.data.frame(bg)
    data_sp <- data[, sp_col]
    data_spp_grp <- unique(data[, sp_grp_col])
    bg_spp_grp <- bg[, bg_sp_grp_col]
    maxent(
      x = preds,
      p = data[grepl(gsub(" ", ".*", sp), data_sp), coords],
      a = bg[bg_spp_grp == data_spp_grp, coords],
      args = maxent_args
    )
  }


suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(ggplot2))
suppressPackageStartupMessages(library(patchwork))

source("viz_themes.R")
source("plotting_functions.R")
source("data_functions.R")

results_dir <- file.path("../1.Data-exploration/Profiles_level4/results/")

# First, obtain the threshold to consider strong phenotype
cell_painting_pr_df <- load_percent_strong(assay = "cellpainting", results_dir = results_dir)
l1000_pr_df <- load_percent_strong(assay = "l1000", results_dir = results_dir)

pr_df <- dplyr::bind_rows(cell_painting_pr_df, l1000_pr_df)
pr_df$dose <- factor(pr_df$dose, levels = dose_order)

threshold_df <- pr_df %>%
    dplyr::filter(type == 'non_replicate') %>%
    dplyr::group_by(assay, dose) %>%
    dplyr::summarise(threshold = quantile(replicate_correlation, 0.95))

threshold_plot_ready_df <- threshold_df %>% reshape2::dcast(dose ~ assay, value.var = "threshold")

# Next, get the median pairwise correlations and determine if they pass the threshold
cell_painting_comp_df <- load_median_correlation_scores(assay = "cellpainting", results_dir = results_dir)
l1000_comp_df <- load_median_correlation_scores(assay = "l1000", results_dir = results_dir)

# Note that the variable significant_compounds contains ALL compounds and a variable indicating if they pass the threshold
significant_compounds_df <- cell_painting_comp_df %>%
    dplyr::left_join(l1000_comp_df, by = c("dose", "compound"), suffix = c("_cellpainting", "_l1000")) %>%
    tidyr::drop_na() %>%
    dplyr::left_join(threshold_df %>% dplyr::filter(assay == "Cell Painting"), by = "dose") %>%
    dplyr::left_join(threshold_df %>% dplyr::filter(assay == "L1000"), by = "dose", suffix = c("_cellpainting", "_l1000")) %>%
    dplyr::mutate(
        pass_cellpainting_thresh = median_replicate_score_cellpainting > threshold_cellpainting,
        pass_l1000_thresh = median_replicate_score_l1000 > threshold_l1000
    ) %>%
    dplyr::mutate(pass_both = pass_cellpainting_thresh + pass_l1000_thresh) %>%
    dplyr::mutate(pass_both = ifelse(pass_both == 2, TRUE, FALSE)) %>%
    dplyr::select(
        compound,
        dose,
        median_replicate_score_cellpainting,
        median_replicate_score_l1000,
        pass_cellpainting_thresh,
        pass_l1000_thresh,
        pass_both
    )

# Count in how many doses the particular compound was reproducible
cp_reprod_count_df <- significant_compounds_df %>%
    dplyr::filter(pass_cellpainting_thresh) %>%
    dplyr::group_by(compound) %>%
    dplyr::count() %>%
    dplyr::rename(cell_painting_num_reproducible = n)

l1000_reprod_count_df <- significant_compounds_df %>%
    dplyr::filter(pass_l1000_thresh) %>%
    dplyr::group_by(compound) %>%
    dplyr::count() %>%
    dplyr::rename(l1000_num_reproducible = n)

significant_compounds_df <- significant_compounds_df %>%
    dplyr::left_join(cp_reprod_count_df, by = "compound") %>%
    dplyr::left_join(l1000_reprod_count_df, by = "compound") %>%
    tidyr::replace_na(list(l1000_num_reproducible = 0, cell_painting_num_reproducible = 0)) %>%
    dplyr::mutate(total_reproducible = cell_painting_num_reproducible + l1000_num_reproducible)

significant_compounds_df$dose <- factor(significant_compounds_df$dose, levels = dose_order)
significant_compounds_df$compound <- tolower(significant_compounds_df$compound)

print(length(unique(significant_compounds_df$compound)))

# Output file for further use
output_file <- file.path("data", "significant_compounds_by_threshold_both_assays.tsv.gz")
significant_compounds_df %>% readr::write_tsv(output_file)

print(dim(significant_compounds_df))
head(significant_compounds_df, 3)


#' @title calcLLAF
#'
#' @description Creates a data table of low load adjustment factors (unitless)
#' for the given parameters.
#'
#'@param engineType Engine type (vector of strings) (see
#'\code{\link{calcEngineType}}). Valid values are: \itemize{
#'\item "SSD"
#'\item "MSD"
#'\item "MSD-ED"
#'\item "GT"
#'\item "GT-ED"
#'\item "ST"
#'\item "LNG"
#'\item "HSD" (auxiliary only)
#'\item "Boiler" (boiler only)
#'}
#'@param location Location of vessel (vector of strings). Valid values are:
#'\itemize{
#'   \item "ECA"
#'   \item "OutsideECA"
#'   \item "GreatLakes"
#' }
#'@param loadFactor Fractional percentage (between 0 and 1) of main engine
#' required to propel vessel at given speed (vector of numericals) (see
#' ShipPowerModel library)
#'@param ECAfuelSulfurPercentage Fuel sulfur cap (percentage by weight) for the
#'Emissions Control Area (ECA). Default = 0.1\% (in effect Jan. 1, 2015)
#'@param GlobalfuelSulfurPercentage Fuel sulfur cap (percentage by weight) for
#'outside the Emissions Control Area (ECA). Default = 0.5\% (in effect Jan. 1,
#'2020)
#'@param pollutants Select pollutants (default = "ALL"). Options: \itemize{
#'\item "co"
#'\item "hc"
#'\item "co2"
#'\item "so2"
#'\item "pm10"
#'\item "pm2.5"
#'\item "nox"
#'}
#' @param inputTableLocation File path (optional). Used to specify a
#' user-supplied set of adjustment factors. See details for formatting
#' requirements
#'
#'@details
#'Location is important for determining the fuel being used, as type of fuel
#'typically used varies by location. This impacts the calculation of LLAF
#'for SO2.
#'
#'For more information about the default low load adjustment factors, see
#'Section 3.7 of the Port Emissions Inventory Guidance.
#'
#'If user-supplied adjustment factors are used, the file should be
#'in .csv format with a header row. The headers should be "load" and one or more
#'pollutants listed in the \code{pollutants} argument. The load column should
#'contain numerical values in percentage space (i.e., it can range between 0 and
#'100). The pollutant columns should contain the specific adjustment factors for
#'that pollutant, corresponding to the load values. Note: This function will
#'linearly interpolate between the nearest values for any given load factor, and
#'will return an adjustment factor of 1 for load factors outside the range of
#'the table (i.e., it will not extrapolate).
#'
#'@return
#' a data.table of low load adjusted emission factors the given parameters. Each
#' pollutant selected in the \code{pollutants} argument will be a column in the
#' table.
#'
#' @references
#' \href{https://nepis.epa.gov/Exe/ZyPDF.cgi?Dockey=P10102U0.pdf}{EPA. 2020.
#' "Ports Emissions Inventory Guidance: Methodologies for Estimating
#' Port-Related and Goods Movement Mobile Source Emissions." Ann Arbor, MI:
#' Office of Transportation and Air Quality. US Environmental Protection Agency.}
#'
#'@examples
#'calcLLAF(engineType=c("SSD","MSD","MSD-ED","GT"),
#'         location = "ECA",
#'         loadFactor=c(0.8,0.5,0.14,0.03),
#'         pollutants="co2")
#'calcLLAF(engineType=c("SSD","MSD","MSD-ED","GT"),
#'         location = c("ECA","GreatLakes","ECA","OutsideECA"),
#'         loadFactor=c(0.8,0.5,0.14,0.03))
#'calcLLAF(engineType=c("HSD","MSD","LNG"),
#'         location = c("ECA","GreatLakes","ECA","OutsideECA"),
#'         loadFactor=c(0.8,0.5,0.14),
#'         ECAfuelSulfurPercentage=0.1,
#'         GlobalfuelSulfurPercentage=2.7,
#'         pollutants="ALL")
#'
#'@import data.table
#'@importFrom stats spline
#'@export

calcLLAF <- function(engineType, location, loadFactor,
                     ECAfuelSulfurPercentage=0.1,GlobalfuelSulfurPercentage=0.5,
                     pollutants="ALL",
                     inputTableLocation=NULL)
{

  #bind variables to make devtools::check() happy
  so2<-.<-NULL

  if(is.element("ALL",pollutants)){
    pollutants<-c("hc",
                  "co2",
                  "co",
                  "nox",
                  "pm2.5",
                  "so2",
                  "pm10")
  }

  #get low-load adjustments if an input table is given
  if(is.null(inputTableLocation) == FALSE)
    {
     tbl<-fread(inputTableLocation)

     # convert load from percent space to fractional space to make it consistent with loadFactor
     tbl[,load:=load/100]

     # only include the selected pollutants
     tbl<-subset(tbl, select=c("load", pollutants) )

     # linear interpolate the table for each given load factor
     LLAF<-tbl[, lapply(.SD, function(y) spline(load, y, xout = loadFactor)[['y']])]

     # Excluding electric drive oil engines (MSD-ED & GT-ED) who can switch off engines instead of operating at low loads.
     LLAF[engineType %in% c("MSD-ED","GT-ED")]<-LLAF[, lapply(.SD, function(y) 1)]

     # Excluding load factors that fall outside the range of this table
     LLAF[is.na(load)]<-LLAF[, lapply(.SD, function(y) 1)]

     # drop load column so we are just returning the results
     LLAF[, load:=NULL]
     return(LLAF)
    }

  #calculate low-load adjustments
  LLAFCoeff<-ShipEF::LLAFCoeff
  #initialize PollutantsLLAF====================================
  LLAF<- lapply(pollutants, function(x) data.table::data.table(matrix(nrow=length(engineType))))

  names(LLAF)<-pollutants

  #assign FuelSulfurFraction according to ECA constraints=======

  for(pol in pollutants){

    #Equation 3-26 C3RIA pg.3-27
    #Normalized to 20% load
    if(pol=="so2") {
       # create data table of location and load factor so that we can calculate SO2 LLAF from loadFactor differently depending on location
       dt <- data.table::data.table(location, loadFactor)

       dt[location %in% c("ECA", "GreatLakes"),
          so2 := (LLAFCoeff$a[LLAFCoeff$pollutant=="so2"]*((14.1205*(1/loadFactor)+205.7169) * ECAfuelSulfurPercentage)
                             +LLAFCoeff$b[LLAFCoeff$pollutant=="so2"])/(LLAFCoeff$a[LLAFCoeff$pollutant=="so2"]*((14.1205*(1/0.2)+205.7169)
                                                                                * ECAfuelSulfurPercentage)+LLAFCoeff$b[LLAFCoeff$pollutant=="so2"])]

       dt[!(location %in% c("ECA", "GreatLakes")),
          so2 := (LLAFCoeff$a[LLAFCoeff$pollutant=="so2"]*((14.1205*(1/loadFactor)+205.7169) * GlobalfuelSulfurPercentage)
                  +LLAFCoeff$b[LLAFCoeff$pollutant=="so2"])/(LLAFCoeff$a[LLAFCoeff$pollutant=="so2"]*((14.1205*(1/0.2)+205.7169)
                                                                                * GlobalfuelSulfurPercentage)+LLAFCoeff$b[LLAFCoeff$pollutant=="so2"])]
       # LLAF is a list containing data.table columns
       LLAF[paste(pol)] <- dt[, .(so2)]
       rm(dt)

    } else { # All other pollutants

       LLAF[paste(pol)]<-data.table::as.data.table(
         (LLAFCoeff$a[LLAFCoeff$pollutant==pol]*(loadFactor^-LLAFCoeff$x[LLAFCoeff$pollutant==pol])+LLAFCoeff$b[LLAFCoeff$pollutant==pol])/(
           LLAFCoeff$a[LLAFCoeff$pollutant==pol]*(0.2^-LLAFCoeff$x[LLAFCoeff$pollutant==pol])+LLAFCoeff$b[LLAFCoeff$pollutant==pol])
       )

    } #end SO2 vs other pollutants if/else
  }

  #Excluding electric drive oil engines (MSD-ED & GT-ED) who can switch off engines instead of operating at low loads.
  #Excluding Auxiliary Engines
  #Excluding Non-Low Load Operations (>20% or 0% (Hotelling))
  LLAF<-lapply(LLAF, function(x){
    x[which(loadFactor>0.2|loadFactor==0)]<-1
    x
  })

  LLAF<-lapply(LLAF, function(x){
    x[which(engineType%in%c("MSD-ED","GT-ED"))]<-1
    x
  })

  LLAF<-data.table::as.data.table(do.call(cbind,LLAF))

  return(LLAF)
}


#!/usr/bin/env Rscript

options(stringAsfactors = FALSE, useFancyQuotes = FALSE)

# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for dilution filtering!\n")
require(xcms)
inputPeakML<-NA
output<-NA
dilutionTrend<-NA
pvalueCutoff<-1
corCutoff<-0
absolute<-T
Corto<-NA
phenoFile<-NA
phenoDataColumn<-NA
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="dilution")
  {
    dilutionTrend=strsplit(split = ",",x = as.character(value),fixed = T)[[1]]
  }
  if(argCase=="Corto")
  {
    Corto=strsplit(split = ",",x = as.character(value),fixed = T)[[1]]
    Corto<-as.numeric(Corto)
  }
  if(argCase=="pvalue")
  {
    pvalueCutoff=as.numeric(value)
  }
  if(argCase=="corcut")
  {
    corCutoff=as.numeric(value)
  }
  if(argCase=="abs")
  {
    absolute=as.logical(value)
  }
  if(argCase=="phenoFile")
  {
    phenoFile=as.character(value)
  }
  if(argCase=="phenoDataColumn")
  {
    phenoDataColumn=as.character(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }
}

if(is.na(previousEnv) | is.na(output) | any(is.na(dilutionTrend))) stop("All input, output and dilution need to be specified!\n")

load(file = previousEnv)
inputXCMS<-get(varNameForNextStep)
if(!is.na(phenoDataColumn) && !is.na(phenoFile))
{
fileNameMap<-read.csv(phenoFile,stringsAsFactors = F,header = T)

for(i in 1:nrow(inputXCMS@phenoData))
{
massTracesXCMSSet@phenoData[i]<-fileNameMap[fileNameMap[,1]==rownames(massTracesXCMSSet@phenoData)[i],phenoDataColumn]
}
}

SpecificCorrelation<-function(x,d=c(1:length(x)))
{
  if(length(na.omit(x))<=1)return(data.frame(pvalue=1,cor=as.numeric(-1.1)))
  if(sd(x)==0)return(data.frame(pvalue=1.1,cor=as.numeric(-1.1)))
  y<-d
  tmpToCor<-cbind(x,y)
  tmpToCor<-na.omit(tmpToCor)
  tmp<-cor.test(tmpToCor[,1],tmpToCor[,2])
  return(data.frame(pvalue=tmp$p.value,cor=as.numeric(tmp$estimate)))
}
xset<-inputXCMS
idx <- xcms:::groupidx(xset)
removeGR<-c()
removePk<-c()

for( i in seq_along(idx)){
  peak_select <- xcms::peaks(xset)[idx[[i]], ]
  peaks<-rep(NA,nrow(xset@phenoData))
  if(class(peak_select)=="numeric")
  {
  	peaks[peak_select["sample"]]<-peak_select["into"]
  }else if (class(peak_select)=="matrix")
  {
	peaks[peak_select[,"sample"]]<-peak_select[,"into"]
  }
  names(peaks)<-c(as.character(xset@phenoData[,1]))
  co<-SpecificCorrelation(peaks[dilutionTrend],Corto)
  if(absolute)
    co$cor<-abs(co$cor)
  if(!co$cor<corCutoff & co$pvalue<pvalueCutoff)
  {

    removeGR<-c(removeGR,i)
    removePk<-c(removePk,idx[[i]])
  }
}

for(i in removeGR)
{
  xset@groupidx[[i]]<-NULL
  xset@groups<-xset@groups[-i,]
}

preprocessingSteps<-c(preprocessingSteps,"dilutionFilter")

varNameForNextStep<-as.character("xset")

save(list = c("xset","preprocessingSteps","varNameForNextStep"),file = output)


import_package('ggplot2', attach=TRUE)

#' Plot transition probabilities for model
#'
#' @param model  Chromstar model object
transitions = function(model) {
    chromstaR::heatmapTransitionProbs(model) +
        ggtitle('Transition probabilities')
}


#scenario<-'T1-T2_stoc_rec_assess_run01'
#scenario<-'T1-T2_stoc_rec_assess_run01_0pctConstraints'
#scenario<-'T1-T2_stoc_rec_assess_run01-Icelandic'
#scenario<-'T1-T2_stoc_rec_assess_run01_15pctConstraints'

scenario.dir<-file.path(data.path,scenario)
#scenario.dir<-data.path

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

run.ID<-scenario
species.in.title<-F

# Year range for data included in the plot
first.year.on.plot<-first.year.in.mean    #2025    # years where output is independent of initial conditions and used as "equilibrium"
last.year.on.plot<-last.year.in.mean      #2037

do.change.from.year.to.year<-T

max.cl<-10         # max closure years
min.yield<-2000   # yield used as minimum yield in the variation plot

logAxis<-FALSE

incl.sp<-seq(1)  # species number to be included
incl.sp<-"all"

new_plot<-T           # start with a blank output screen
nox<-3; noy<-2;

do.plot.forecast2<-function(sp.plot=c(1),dir=data.path,do.closure.plot=FALSE) {
#########################################
control<-read.FLSMS.control(dir=dir)
HCR<-read.FLSMS.predict.control(control=control,file=file.path(dir,'HCR_options.dat'))

ref.points<-Read.reference.points(dir=dir)
ssb.r<-Read.MCMC.SSB.rec.data(dir=dir)
ssb.r<-subset(ssb.r,Year>=first.year.on.plot & Year<=last.year.on.plot,drop=T)

F.yield<-Read.MCMC.F.yield.data(dir=dir)
F.yield<-subset(F.yield,Year>=first.year.on.plot & Year<=last.year.on.plot,drop=T)

if (is.character(incl.sp)) if (incl.sp=="all") {
   info<-control@species.info
   n.pred<-0; n.oth<-0
   for (s in (1:control@no.species)) {
     if(info[s,'predator']>=1) n.pred<-n.pred+1;
     if(info[s,'predator']==2) n.oth<-n.oth+1;
   }
   first.VPA<-n.oth+1
   n.VPA<-control@no.species-first.VPA+1

   sp.plot<-seq(first.VPA,length(unique(ssb.r$Species))+n.oth)
}

if (any(HCR@HCR>=20) & any(HCR@HCR<40) & do.closure.plot) {
    cl <-Read.MCMC.closure.data(dir=dir)
    cl1<-tapply(cl$closure,list(cl$Year),mean)

    cl2<-subset(cl,Year>=first.year.on.plot & Year<=last.year.on.plot,drop=T)
    cl2<-mean(cl2$closure)
}

if (do.closure.plot) {

  closure <-Read.MCMC.closure.data(dir=dir)
  cl<-subset(closure,Year>=first.year.on.plot & Year<=last.year.on.plot,drop=T)

  cl$closure[cl$closure==1]<-0
  cl$closure[cl$closure>=2]<-1
  mean.cl<-tapply(cl$closure,list(cl$Species.n),mean)

  a<-by(cl,list(cl$Species.n,cl$Repetion,cl$Iteration),function(x) {
   key<-rank(x$Year)
   x<-x[key,]
   res<-rep(0,max.cl)
   ii<-dim(x)[1]
   closed<-FALSE
   n<-0
   for (i in (1:ii)) {
     if (x[i,"closure"]==1) {
       if (closed) n<-n+1 else {closed<-TRUE; n<-1;}
     } else {
       if (closed) {res[min(n,max.cl)]<-res[min(n,max.cl)]+1; closed<-FALSE; }
     }
   }
   if (closed) res[min(n,max.cl)]<-res[min(n,max.cl)]+1
  res
  })

  a<-matrix(unlist(a),ncol=max.cl,byrow=T)
  closure<-apply(a,2,sum)
}

if (last.year.on.plot>first.year.on.plot) {

    # change in SSB from year to year
    a<-tapply(ssb.r$SSB,list(ssb.r$Species.n,ssb.r$Repetion,ssb.r$Iteration,ssb.r$Year),sum)
    SSB.change<-a
    SSB.change[,,,]<-0
    for (i in (2:dim(a)[4])) SSB.change[,,,i]<-a[,,,i]/a[,,,i-1]

    # change in yield from year to year
    a<-tapply(F.yield$Yield,list(F.yield$Species.n,F.yield$Repetion,F.yield$Iteration,F.yield$Year),sum)
    a[a<min.yield]<-min.yield
    yield.change<-a
    yield.change[,,,]<-0
    for (i in (2:dim(a)[4])) yield.change[,,,i]<-a[,,,i]/a[,,,i-1]

    # change in mean F from year to year
    a<-tapply(F.yield$mean.F,list(F.yield$Species.n,F.yield$Repetion,F.yield$Iteration,F.yield$Year),sum)
    F.change<-a
    F.change[,,,]<--1
    for (i in (2:dim(a)[4])) F.change[,,,i]<-a[,,,i]/a[,,,i-1]

}

loc.name<-control@species.names
if (!species.in.title) loc.name[]<-'';

cleanup()
  plotfile<-function(dev='screen',out) {
    print(out)
    if (dev=='screen') X11(width=8, height=8, pointsize=12)
    if (dev=='wmf') win.metafile(filename = paste(out,'.wmf',sep=''), width=6, height=8, 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)
   }

# do the plots

for (sp in (sp.plot)) {
    print(sp)
    #if (new_plot) newplot(dev,noy,nox,filename=paste("Histo_",run.ID,'_',loc.name[sp],sep=''),Portrait=TRUE);
    if (new_plot) plotfile(dev=my.dev,out=paste("Histo_",run.ID,'_',Name,'_',loc.name[sp],sep=''));
    par(mar=c(3,5,3,2))
    par(mfcol=c(nox,noy))

    blim<-ref.points[sp,3]
    bpa<-ref.points[sp,4]

    x.lab<-"SSB (1000 t)"
    par(mar=c(5,4,4,5)+.1)

    a<-subset(ssb.r,Species.n==sp)
    min.y<-min(a$SSB)/1000
    max.y<-max(a$SSB)/1000
    med<-trunc(median(a$SSB/1000))

    hist(a$SSB/1000,main=paste(loc.name[sp], "SSB, (median=",med,")"),xlim=c(min.y,max.y),xlab=x.lab,axes=FALSE,ylab='frequency')
    axis(1)
    axis(2)

    par(new=T)
    x<-sort(a$SSB/1000)
    y<-seq(1,length(x))
    y<-y/length(y)
    plot(x,y,col=1,lwd=2,type='l',axes=FALSE,xlab=x.lab,ylab='')
    axis(side=4)
    mtext(side=4,line=3.0,"probability",cex=0.75)
    abline(h=0.05,col="red")
    par(xaxs="r")

    x.lab<-"Yield (1000 t)"
    par(mar=c(5,4,4,5)+.1)
    a<-subset(F.yield,Species.n==sp)
    min.y<-min(a$Yield)/1000
    max.y<-max(a$Yield)/1000
    med<-trunc(median(a$Yield/1000))
    print(paste("mean TAC:",mean(a$Yield/1000)))
    hist(a$Yield/1000,main=paste("Yield, (median=",med,")"),xlim=c(min.y,max.y),xlab=x.lab,axes=F,ylab='frequency') #,nclass=50)
    axis(1)
    axis(2)
    #print(sort(a$Yield/1000))
    par(new=T)
    x<-sort(a$Yield/1000)
    y<-seq(1,length(x))
    y<-y/length(y)
    plot(x,y,col=1,lwd=2,type='l',axes=FALSE,xlab=x.lab,ylab='')
    axis(side=4)
    mtext(side=4,line=3.0,"probability",cex=0.75)
    par(xaxs="r")

    x.lab<-"mean F"
    par(mar=c(5,4,4,5)+.1)
    a<-subset(F.yield,Species.n==sp)

    min.y<-min(a$mean.F)
    max.y<-max(a$mean.F)

    med<-round(median(a$mean.F),digits=2)
    hist(a$mean.F,main=paste("F (median=",med,")"),axes=F,xlim=c(min.y,max.y),xlab=x.lab,ylab='frequency') #,nclass=50)
    axis(1)
    axis(2)
    par(new=T)
   if (T) {
    x<-sort(a$mean.F)
    y<-seq(1,length(x))
    y<-y/length(y)
    plot(x,y,col=1,lwd=2,type='l',axes=FALSE,xlab=x.lab,ylab='')
    axis(side=4)
    mtext(side=4,line=3.0,"probability",cex=0.75)
    par(xaxs="r")
   }

    a<-subset(ssb.r,Species.n==sp)
    q<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)

    T1<-blim    # snyd
    T2<-bpa

    q[q>T2]<-0
    q[q>0]<-1
    q<-apply(q,c(1),sum)/(dim(q)[2]*dim(q)[3])

 if (F) {
  y<-as.numeric(names(q))
  plot(y,q,main=paste("Probability, SSB below", T2/1000,"&", T1/1000),xlab="",ylab='probability',
        type='l',lwd=2,ylim=c(0,1))
   q<-tapply(a$SSB,list(a$Year,a$Repetion,a$Iteration),sum)
  q[q>T1]<-0
  q[q>0]<-1
  q<-apply(q,c(1),sum)/(dim(q)[2]*dim(q)[3])
  y<-as.numeric(names(q))
  lines(y,q,lty=2)
 }

 if (last.year.on.plot>first.year.on.plot & do.change.from.year.to.year ) {
    # Change in SSB
    x.lab<-"factor"
    par(mar=c(5,4,4,5)+.1)
    a<-SSB.change[sp,,,]
    a<-a[,-1]  # exclude first column =0
    med<-round(median(a),digits=2)
    if (logAxis) a<-log(a)
    h<-hist(a,plot=FALSE)
    hist(a,main=paste("SSB change(median=",med,")"),xlim=c(min(a),max(a)),xlab=x.lab,axes=FALSE,ylab='frequency')
    if (logAxis) axis(1,h$mids, round(exp(h$mids),digits=2)) else axis(1,h$mids, round(h$mids,digits=2))
    axis(2)
    par(new=T)
    x<-sort(a)
    y<-seq(1,length(x))
    y<-y/length(y)
    plot(x,y,col=1,lwd=2,type='l',axes=FALSE,xlab=x.lab,ylab='')
    axis(side=4)
    mtext(side=4,line=3.0,"probability",cex=0.75)
    par(xaxs="r")

    # Change in yield
    x.lab<-"factor"
    par(mar=c(5,4,4,5)+.1)
    a<-yield.change[sp,,,]
    a<-a[,-1]  # exclude first column =0
    #print(loc.name[sp])
    #print(a[a>1.15])

    med<-round(median(a),digits=2)
     if (logAxis) a<-log(a)
    h<-hist(a,plot=FALSE)
    hist(a,main=paste("Yield change(median=",med,")"),xlim=c(min(a),max(a)),xlab=x.lab,axes=FALSE,ylab='frequency')
    if (logAxis) axis(1,h$mids, round(exp(h$mids),digits=2)) else axis(1,h$mids, round(h$mids,digits=2))
    axis(2)
    par(new=T)
    x<-sort(a)
    y<-seq(1,length(x))
    y<-y/length(y)
    plot(x,y,col=1,lwd=2,type='l',axes=FALSE,xlab=x.lab,ylab='')
    axis(side=4)
    mtext(side=4,line=3.0,"probability",cex=0.75)
    par(xaxs="r")

    # Change in F
    if (!do.closure.plot) {
      x.lab<-"factor"
      par(mar=c(5,4,4,5)+.1)
      a<-F.change[sp,,,]
      a<-a[,-1]  # exclude first column =0

      med<-round(median(a),digits=2)
      if (logAxis) a<-log(a)

      h<-hist(a,plot=FALSE)

      hist(a,main=paste("F change(median=",med,")"),xlim=c(min(a),max(a)),xlab=x.lab,axes=FALSE,ylab='frequency')
    if (logAxis) axis(1,h$mids, round(exp(h$mids),digits=2)) else axis(1,h$mids, round(h$mids,digits=2))
      axis(2)
      par(new=T)
      x<-sort(a)
      y<-seq(1,length(x))
      y<-y/length(y)
      plot(x,y,col=1,lwd=2,type='l',axes=FALSE,xlab=x.lab,ylab='')
      axis(side=4)
      mtext(side=4,line=3.0,"probability",cex=0.75)
      par(xaxs="r")
    }
    if (do.closure.plot) {
      x.lab<-"years"
      par(mar=c(5,4,4,5)+.1)
      space<-0.1
      barplot(closure,names=seq(1,max.cl),
      main=paste("Number of years in a closure\nprob. closure:",round(mean.cl[[sp]],2)),
      space=space,xlab=x.lab,axes=FALSE,ylab='frequency',col=0)

      #axis(1)
      axis(2)
      par(new=T)

      x<-seq(1,max.cl)+0.5
      y<-cumsum(closure)/sum(closure)
      plot(x,y,col=1,lwd=2,type='b',axes=FALSE,ylim=c(0,1),xlim=c(1,max.cl*(1+space)),xlab=x.lab,ylab='')
      axis(side=4)
      mtext(side=4,line=3.0,"probability",cex=0.75)
      par(xaxs="r")
    }

  }

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

}
}

 #do.plot.forecast2(sp.plot=incl.sp,dir="TAC_stable",do.closure.plot=TRUE)
 do.plot.forecast2(sp.plot=incl.sp,do.closure.plot=FALSE,dir=scenario.dir)


nox<-2; noy<-3;
paper<-F        # graphics on paper=file (TRUE) or on screen (FALSE)
cleanup()

first.year.on.plot<-1974
last.year.on.plot<-2016
doGrid<-T

first.pch<-1    # first pch symbol
first.color<-1   # first color

palette("default")                # good for clolorfull plots
#palette(gray(seq(0,.9,len=6)))  # gray scale for papers, use len =500 to get black only

dirs<-c("NS_63-10-sep-2014","NS_key-2014-ver15_codage3","NS_key-2014-ver17")
labels<-c("2011", "2014-key","2015-key")

dirs<-c("NS_key-2011","NS_key-2014-ver13-final-key-run", "NorthSeaKeyRun")
labels<-c("2011-run", "2014-run","2015-run")

dirs<-c("NS_key-2014-ver17","NS_key-2017-ver02")
labels<-c("2014-run", "2017-run")

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

for (dir in dirs) {
   Init.function(dir=file.path(root,dir)) # get SMS.contol object  including sp.names
   a<-Read.summary.data(dir=file.path(root,dir),read.init.function=F)
   a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot & Z>0))
   a<-data.frame(scenario=labels[which(dirs==dir)],Variable="M2",Year=a$Year, quarter=a$Quarter,Species=a$Species, Age=a$Age,west=a$west)
   if (dir==dirs[1]) alld<-a else alld<-rbind(alld,a)
}

head(a)
all<-subset(a,Species=='Cod' & quarter==1)
by(all,list(all$Species),function(x ) {
trellis.device(device = "windows",
               color = T, width=5, height=9,pointsize = 2,
               new = T, retain = FALSE)

print(xyplot( west~Year|paste('Age:',Age),groups=paste(quarter,scenario), data=x,
  type='b',lwd=1 , layout=c(3,3),   ylab='Weight in the stock',
   strip = strip.custom( bg='white'),par.strip.text=list(cex=1, lines=1.5),
   auto.key = list(space = "bottom", points = T, lines = F,cex=0.9, columns = 2) ,
     xlim=c(1976,2017),
    scales = list(x = list( cex=0.8), y= list(cex=0.8),alternating = 1,relation='free')
))
})
###################
# more species per plot

cleanup()
all$age<-paste(all$Species,", age ",all$Age,sep='')
all$ageRev<-paste("age ",all$Age,", ",all$Species,sep='')
all<-all[order(all$label,all$Age,all$Species.n,all$Year),]

all1<-subset(all,Species %in% c('Cod','Whiting','Haddock'))

trellis.device(device = "windows",
               color = F, width=9, height=9,pointsize = 2,
               new = T, retain = FALSE)

print(xyplot( M2~Year|age,groups=label, data=all1,
  type='b',lwd=1 , layout=c(3,3), as.table=F,  ylab='Predation mortality',
   strip = strip.custom( bg='white'),par.strip.text=list(cex=1, lines=1.5),
   auto.key = list(space = "bottom", points = T, lines = F,cex=0.9, columns = 3) ,
     xlim=c(1976,2000),
    scales = list(x = list( cex=0.8), y= list(cex=0.8),alternating = 1,relation='free')
))

 ###################
# more species per plot, used for paper
cleanup()
trellis.device(device = "windows",
               color = F, width=10, height=11,pointsize = 2,
               new = T, retain = FALSE)

#all1<-subset(all,Species %in% c('Cod','Whiting','Haddock'))
all1<-subset(all,Species %in% c('Herring','Nor. pout','Sandeel'))

xyplot( M2~Year|ageRev,groups=label, data=all1,
 as.table=T,   ylab='Predation mortality',
   layout=c(3,3),
   strip = strip.custom( bg='white'),par.strip.text=list(cex=1, lines=0),
   auto.key = list(space = "bottom", points = T, lines = T,cex=1, columns = 2,title='Prey size selection', pch=c(1,2,3,4,5)) ,
     xlim=c(1976,2000),   # to allow relation='free' and having (0,0) included
    scales = list(x = list( cex=0.8), y= list(cex=0.8),alternating = 1,relation='free'),
        panel = function(x, y, subscripts, groups) {
                 ltext(x=1976,y=0,labels=all1[subscripts,'age'],pos=4,cex=1.1)
         panel.superpose(x, y,subscripts=subscripts, groups=groups,type='b')
         }
)

 ###################
# same as previous, but in color
cleanup()
trellis.device(device = "windows",
               color = T, width=12, height=12,pointsize = 12,
               new = T, retain = FALSE)

myCol<- c(1,2,3,4,5)
myLwd<-rep(3,5)
myLty<-c(1,2,3,4,5)

all1<-subset(all,Species %in% c('Cod','Whiting','Haddock'))
all1<-subset(all,Species %in% c('Herring','Nor. pout','Sandeel'))
all1<-subset(all,Species %in% c('Cod','Herring','Sandeel'))

print(xyplot( M2~Year|ageRev,groups=label, data=all1,
 as.table=T,   ylab='Predation mortality',
   layout=c(3,3),      between = list(y = c(1, 1),x = c(1, 1)),
   strip = strip.custom( bg='white'),par.strip.text=list(cex=0, lines=0), main=NA,
   key = list(space = "bottom", points = F, lines = T,cex=1, columns = 2,title='Prey size selection',col=myCol, lwd=myLwd*1.5,pch=NA,
               text = list(lab = as.character(unique(all1$label)),col=1) ),
   xlim=c(1976,2000),   # to allow relation='free' and having (0,0) included
   scales = list(x = list( cex=0.8), y= list(cex=0.8),alternating = 1,relation='free'),

        panel = function(x, y, subscripts, groups) {
                 ltext(x=1976,y=0,labels=all1[subscripts,'age'],pos=4,cex=1.0 ,col=1,font=2)
         panel.superpose(x, y,subscripts=subscripts, groups=groups,type='l',
                          col=myCol,lwd=myLwd)
         }
))

}


  habitat.usage = function( usevar, covariate, outdir, p ) {

    b = snowcrab.db("set.biologicals")
    logbook = logbook.db(DS="fisheries.complete")

    logbook$landings = logbook$landings / 1000  # convert kg to t
    L = logbook[ which(logbook$depth<500 & logbook$depth > 20),]

    if (usevar == "totno.all")     ylab=expression(paste("Number of all crab (1000 / ",km^2, ")"))
    if (usevar == "totno.male.com")   ylab=expression(paste("Number of commercial males (1000/ ",km^2, ")"))
    if (usevar == "totmass.male.com")   ylab=expression(paste("Mass of commercial males (kg / ",km^2, ")"))
    if (usevar == "totno.male.mat")     ylab=expression(paste("Number of mature males (1000 / ",km^2, ")"))
    if (usevar == "totno.male.imm")   ylab=expression(paste("Number of immature males (1000 / ",km^2, ")"))
    if (usevar == "totmass.male.mat")     ylab=expression(paste("Number of mature males (1000 / ",km^2, ")"))

    if (covariate=="depth") {
      # survey densities
      freq1 = errorbars( b=b, v=c("z", usevar), br=30, nfilter=10, lowess=0.25, trim=0.1,
          xlab="Depth (m)", ylab=ylab, p=p)
      Pr(dev="png", dname=outdir, fname=paste("survey.depth", usevar, sep=".") )

      # dockside landings
      usevar = "landings"
      freq1 = errorbars( b=L, v= c("depth", usevar), br=50, nfilter=10, lowess=0.25,  trim=0.1,
          xlab="Depth (m)", ylab="Landings (t)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("landings.depth", usevar, sep="."))

      # logbook cpue
      usevar = "cpue"
      freq1 = errorbars( b=L, v= c("depth", usevar), br=50, nfilter=10, lowess=0.25,  trim=0.1,
          xlab="Depth (m)", ylab="CPUE (kg/trap haul)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("cpue.depth", usevar, sep="."))
    }

    if (covariate=="temperature") {
      # survey densities
      freq1 = errorbars( b=b, v=c("t", usevar), br=50, nfilter=10, lowess=0.25, trim=0.1,
          xlab="Temperature (C)", ylab=ylab , p=p)
      Pr(dev="png", dname=outdir, fname=paste("survey.temperatures", usevar, sep=".") )
    }

    if (covariate=="bottom.slope") {
      # survey densities
      freq1 = errorbars( b=b, v=c("dZ", usevar), br=50, nfilter=10, lowess=0.25, trim=0.1,
          xlab="ln (abs( Slope; m/m) )", ylab=ylab, p=p)
      Pr(dev="png", dname=outdir, fname=paste("survey.slope", usevar, sep=".") )

      # dockside landings
      usevar = "landings"
      freq1 = errorbars( b=L, v= c("dZ", usevar), br=50, nfilter=10, lowess=0.25,  trim=0.1,
          xlab="ln (abs( Slope; m/m) )", ylab="Landings (t)", p=p )
      Pr(dev="png", dname=outdir, fname=paste("landings.slope", usevar, sep="."))

      # logbook cpue
      usevar = "cpue"
      freq1 = errorbars( b=L, v= c("dZ", usevar), br=50, nfilter=10, lowess=0.25,  trim=0.1,
          xlab="ln (abs( Slope; m/m) )", ylab="CPUE (kg/trap haul)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("cpue.slope", usevar, sep="."))
    }

    if (covariate=="bottom.curvature") {
      # survey densities
      freq1 = errorbars( b=b, v=c("ddZ", usevar), br=50, nfilter=10, lowess=0.25, trim=0.1,
          xlab="ln (abs ( Curvature; m/m2) ) )", ylab=ylab, p=p)
      Pr(dev="png", dname=outdir, fname=paste("survey.curvature", usevar, sep=".") )

      # dockside landings
      usevar = "landings"
      freq1 = errorbars( b=L, v= c("ddZ", usevar), br=50, nfilter=10, lowess=0.25,  trim=0.1,
          xlab="ln (abs ( Curvature; m/m2) ) )", ylab="Landings (t)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("landings.curvature", usevar, sep="."))

      # logbook cpue
      usevar = "cpue"
      freq1 = errorbars( b=L, v= c("ddZ", usevar), br=30, nfilter=3, lowess=0.3,  trim=0.1,
          xlab="ln (abs ( Curvature; m/m2) ) )", ylab="CPUE (kg/trap haul)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("cpue.curvature", usevar, sep="."))

    }

    if (covariate=="substrate") {
      # survey densities
      freq1 = errorbars( b=b, v=c("substrate.grainsize", usevar), br=50, nfilter=10, lowess=0.25, trim=0.1,
          xlab="ln ( substrate grainsize; mm )", ylab=ylab, p=p)
      Pr(dev="png", dname=outdir, fname=paste("survey.curvature", usevar, sep=".") )

      # dockside landings
      usevar = "landings"
      freq1 = errorbars( b=L, v= c("substrate.grainsize", usevar), br=50, nfilter=10, lowess=0.25,  trim=0.1,
          xlab="ln ( substrate grainsize; mm )", ylab="Landings (t)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("landings.curvature", usevar, sep="."))

      # logbook cpue
      usevar = "cpue"
      freq1 = errorbars( b=L, v= c("substrate.grainsize", usevar), br=30, nfilter=3, lowess=0.3,  trim=0.1,
          xlab="ln ( substrate grainsize; mm )", ylab="CPUE (kg/trap haul)", p=p)
      Pr(dev="png", dname=outdir, fname=paste("cpue.curvature", usevar, sep="."))

    }

  }


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(scales)
library(stringr)
library(abind)
library(scales)
library(matrixStats)
library(optparse)

simulate_scenarios <- function(JOBID, StanModel, scenario_type, plots = FALSE,
                               len_forecast = 0, subdir='Italy', simulate_code='Italy/code/stan-models/simulate.stan',
                               mobility_vars, mobility_vars_partial=mobility_vars,
                               compliance_vars, compliance_vars_partial=compliance_vars,
                               mobility_increase = 0, compliance_decrease = 0, ext = ".png"){

  load(paste0(subdir, '/results/', StanModel, '-', JOBID, '-stanfit.Rdata'))

  old_dates <- dates
  print(sprintf("Length of forecast: %s", len_forecast))
  total_sim<- stan_data$N2 + len_forecast
  N3=total_sim-stan_data$N2
  # adjust SI
  stan_data$SI <- c(stan_data$SI,rep(stan_data$SI[stan_data$N2],N3))
  # adjust f
  stan_data$f2 <- matrix(NA, nrow=total_sim, ncol=dim(stan_data$f)[2])
  for(i in 1:dim(stan_data$f)[2]){
    stan_data$f2[,i] <- c(stan_data$f[,i],rep(stan_data$f[stan_data$N2,i],N3))
  }

  for(i in 1:length(dates)){
    dates_tmp = as.Date(dates[[i]],format='%Y-%m-%d')
    new_dates = dates_tmp[length(dates_tmp)]
    how_many_days = total_sim-length(dates[[i]])
    pad_dates <- new_dates + days(1:how_many_days)
    dates_tmp  =c(dates_tmp, pad_dates)
    dates[[i]] = dates_tmp
  }
  for(i in 1:length(reported_cases)){
    how_many_days = total_sim-length(reported_cases[[i]])
    reported_cases[[i]] = c(reported_cases[[i]],rep(0,how_many_days))
  }
  for(i in 1:length(reported_deaths)){
    how_many_days = total_sim-length(reported_deaths[[i]])
    reported_deaths[[i]] = c(reported_deaths[[i]],rep(0,how_many_days))
  }

  if (scenario_type == "constant-com"){
    print("Constant compliance simulation")
    # use this is you want compliance to stay as the last day
    stan_data$X2 <- array(NA, c(dim(stan_data$X)[1], total_sim, dim(stan_data$X)[3]))
    for(i in 1:dim(stan_data$X)[1]){
      for(j in 1:dim(stan_data$X)[3]){
        last7 = stan_data$X[i,(stan_data$N[i]-7):stan_data$N[i],j]
        remaining = dim(stan_data$X2)[2] - length(stan_data$X[i,1:stan_data$N[i],j])
        scenario = rep(last7, ceiling(remaining/7))[1:remaining]
        stan_data$X2[i,,j] = c(stan_data$X[i,1:stan_data$N[i],j], scenario)
      }
    }
    stan_data$X2_partial <- array(NA, c(dim(stan_data$X_partial)[1], total_sim, dim(stan_data$X_partial)[3]))
    for(i in 1:dim(stan_data$X_partial)[1]){
      for(j in 1:dim(stan_data$X_partial)[3]){
        stan_data$X2_partial[i,,j] = c(stan_data$X_partial[i,,j], rep(stan_data$X_partial[i,,j][stan_data$N2], N3))
      }
    }
  } else if (scenario_type ==  "decrease-com-current"){
    print("Decrease compliance simulation from current")
    compliance_choice=0.2 # 20 % compliance for example
    stan_data$X2<-array(NA,c(dim(stan_data$X)[1], total_sim,dim(stan_data$X)[3]))
    for(i in 1:dim(stan_data$X)[1]){
      for(j in 1:dim(stan_data$X)[3]){
        if (j %in% compliance_vars){
          last7 = stan_data$X[i,(stan_data$N[i]-7):stan_data$N[i],j]
          remaining = dim(stan_data$X2)[2] - length(stan_data$X[i,1:stan_data$N[i],j])
          scenario = rep(last7*((100-compliance_decrease)/100), ceiling(remaining/7))[1:remaining]
          stan_data$X2[i,,j] = c(stan_data$X[i,1:stan_data$N[i],j], scenario)
        } else {
          last7 = stan_data$X[i,(stan_data$N[i]-7):stan_data$N[i],j]
          remaining = dim(stan_data$X2)[2] - length(stan_data$X[i,1:stan_data$N[i],j])
          scenario = rep(last7, ceiling(remaining/7))[1:remaining]
          stan_data$X2[i,,j] = c(stan_data$X[i,1:stan_data$N[i],j], scenario)
        }
      }
    }

    stan_data$X2_partial <-array(NA,c(dim(stan_data$X_partial)[1], total_sim,dim(stan_data$X_partial)[3]))
    for(i in 1:dim(stan_data$X_partial)[1]){
      for(j in 1:dim(stan_data$X_partial)[3]){
        if (j %in% compliance_vars_partial){
          last7 = stan_data$X_partial[i,(stan_data$N[i]-7):stan_data$N[i],j]
          remaining = dim(stan_data$X2_partial)[2] - length(stan_data$X_partial[i,1:stan_data$N[i],j])
          scenario = rep(last7*((100-compliance_decrease)/100), ceiling(remaining/7))[1:remaining]
          stan_data$X2_partial[i,,j] = c(stan_data$X_partial[i,1:stan_data$N[i],j], scenario)
        } else {
          last7 = stan_data$X_partial[i,(stan_data$N[i]-7):stan_data$N[i],j]
          remaining = dim(stan_data$X2_partial)[2] - length(stan_data$X_partial[i,1:stan_data$N[i],j])
          scenario = rep(last7, ceiling(remaining/7))[1:remaining]
          stan_data$X2_partial[i,,j] = c(stan_data$X_partial[i,1:stan_data$N[i],j], scenario)
        }

      }
    }
  }

  # update stan_data
  stan_data$N2 = total_sim
  stan_data$X = stan_data$X2
  stan_data$X_partial = stan_data$X2_partial
  stan_data$f = stan_data$f2

  m2 <- stan_model(simulate_code)

  fit <- gqs(m2, data=stan_data, draws = as.matrix(fit))

  out <- rstan::extract(fit)
  estimated_cases_raw <- out$prediction
  estimated_deaths_raw <- out$E_deaths
  estimated_deaths_cf <- out$E_deaths0

  print(paste0("saving: ", subdir,'/results/sim-', scenario_type, '-',StanModel,'-',len_forecast, '-', compliance_decrease,
               '-',JOBID,'-standata.Rdata'))
  save(fit, dates, reported_cases, reported_deaths, states,
      estimated_cases_raw, estimated_deaths_raw, estimated_deaths_cf, out,
        file=paste0(subdir,'/results/sim-', scenario_type, '-',StanModel,'-',len_forecast, '-', compliance_decrease, '-', JOBID,'-stanfit.Rdata'))

  #------------------------------------------------------------------------------------------
  print(sprintf("Last date forecast: %s", max(old_dates[[1]]) + len_forecast))
  # Does plotting
  if (plots == TRUE){
    source(paste0(subdir, "/code/plotting/make-plots.r"))
    if (scenario_type =="decrease-com-baseline"){
      print("Making decreased compliance from baseline simulation plots ")
      label = paste0("sim_decrease_com_",  len_forecast, "_", compliance_decrease, '_')
      make_plots_all(paste0(subdir, '/results/sim-decrease-com-baseline-',StanModel,'-', len_forecast, '-', compliance_decrease, '-',
                            JOBID,'-stanfit.Rdata'), SIM=TRUE, label=label,
                     last_date_data =max(old_dates[[1]]) + len_forecast)
    } else if (scenario_type == "decrease-com-current"){
        print("Making decreased compliance from current simulation plots")
        label = paste0("sim_decrease_com_",  len_forecast, "_", compliance_decrease)
        make_plots_all(paste0(subdir, '/results/sim-decrease-com-current-',StanModel,'-', len_forecast, '-' , compliance_decrease, '-',
                              JOBID,'-stanfit.Rdata'), SIM=TRUE, label=label,
                       last_date_data =max(old_dates[[1]]) + len_forecast, ext = ext)
    } else if (scenario_type == "constant-com"){
      label = paste0("sim_constant_com_",  len_forecast, "_", compliance_decrease)
      make_plots_all(paste0(subdir, '/results/sim-constant-com-',StanModel,'-', len_forecast, '-', compliance_decrease, '-',
                            JOBID,'-stanfit.Rdata'), SIM=TRUE, label=label,
                     last_date_data = max(old_dates[[1]]) + len_forecast, ext = ext)
    }
  }
}


# Positions of barometers

locations <- read.csv('./../../data/meta/inbo/Baro_Position_Lambert72.csv',
                      dec = ',', sep = ';', na.strings = 'NULL', stringsAsFactors = FALSE)

CONST_PROJ_LAMBERT72 <- '+proj=lcc +lat_1=51.16666723333333 +lat_2=49.8333339 +lat_0=90 +lon_0=4.367486666666666 +x_0=150000.013 +y_0=5400088.438 +ellps=intl +towgs84=-106.8686,52.2978,-103.7239,0.3366,-0.457,1.8422,-1.2747 +units=m +no_defs'
CONST_PROJ_WGS84 <- '+proj=longlat +datum=WGS84 +no_defs'

geom = sf::st_as_sf(locations, coords = c("Lambert72_X", "Lambert72_Y"),
                    crs = CONST_PROJ_LAMBERT72, agr = "constant", na.fail = FALSE)
geom <- sf::st_transform(geom, crs = CONST_PROJ_WGS84)
geom

ggplot2::ggplot(data = geom) +
    ggplot2::geom_sf() + ggplot2::theme_light()

map <- leaflet::leaflet()
map <- leaflet::addProviderTiles(map, provider = leaflet::providers$Stamen.Terrain)
map <- leaflet::addMarkers(map, data = geom)
map

map.path <- './drifts/analysis_09/barometer_location.html'
dir.create(dirname(map.path), recursive = TRUE, showWarnings = FALSE)

htmlwidgets::saveWidget(map, file = normalizePath(map.path, mustWork = FALSE),
                        selfcontained = TRUE,
                        libdir = tools::file_path_sans_ext(basename(map.path)),
                        knitrOptions = list())


#' @title U2F
#' @description exploitation rate to fishing mortality
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
U2F <- function(U){
	return(-log(1-U))
}


##' Plot figure 6
##'
##' @return plot
##' @param posterior a \code{libbi} object containing posterior samples
##' @param posterior_no_mvc a \code{libbi} object containing posterior predictions without a mass-vaccination campaign
##' @importFrom rbi bi_read flatten
##' @importFrom rbi.helpers numeric_to_time
##' @importFrom dplyr %>% select rename mutate bind_rows left_join inner_join group_by summarise arrange
##' @importFrom tibble enframe
##' @importFrom tidyr unnest spread
##' @importFrom ggplot2 ggplot aes geom_line geom_ribbon geom_point geom_rect facet_wrap xlab ylab scale_color_manual scale_fill_manual theme
##' @importFrom cowplot theme_cowplot
##' @importFrom magrittr add %<>%
##' @export
##' @author Sebastian Funk
figure6 <- function(posterior, posterior_no_mvc)
{

    min_date <- posterior$supplement$min_date

    ## identify contiguous periods of mass-vaccination campaigns
    mvc <- posterior$supplement$mvc %>%
        select(-time) %>%
        rename(time=debutsem) %>%
        mutate(type="MVC", value=0)

    mvc_contiguous <- list()

    for (mvc_health_zone in unique(mvc$health_zone))
    {
        mvc_dates <- apply(mvc %>% dplyr::filter(health_zone == mvc_health_zone), 1, function(x)
        {
            seq(as.Date(x[["min_date"]]),as.Date(x[["max_date"]]), by="day") %>%
                as.character()
        }) %>%
            unlist() %>%
            as.Date() %>%
            unique() %>%
            sort()

        mvc_date_diffs <- mvc_dates %>%
            diff() %>%
            as.integer()
        mvc_date_rle <- mvc_date_diffs %>%
            rle()

        mvc_date_cl <- mvc_date_rle$lengths %>%
            cumsum() %>%
            add(1) %>%
            c(1, .)

        contiguous <- which(mvc_date_rle$values==1)

        contiguous_mvc <- lapply(contiguous, function(x) {
            c(min_date=mvc_dates[mvc_date_cl[x]],
              max_date=mvc_dates[mvc_date_cl[x+1]])
        })

        min_dates <- vapply(contiguous_mvc, function(x) {
            as.character(x[["min_date"]])
        }, "") %>%
            as.Date()
        max_dates <- vapply(contiguous_mvc, function(x) {
            as.character(x[["max_date"]])
        }, "") %>%
            as.Date()

        mvc_contiguous[[mvc_health_zone]] <-
            data.frame(min_date=min_dates, max_date=max_dates, health_zone=mvc_health_zone,
                       stringsAsFactors = FALSE)
    }

    mvc_contiguous %<>%
        bind_rows()

    obs <- bi_read(posterior, file="obs") %>%
        numeric_to_time(origin=min_date, unit="2 weeks") %>%
        flatten()

    res <- bi_read(posterior, type=c("state", "obs", "noise")) %>%
        numeric_to_time(origin=min_date, unit="2 weeks") %>%
        flatten()

    cases_summary <- res %>%
        group_by(health_zone, time, var) %>%
        summarise(value =
                      list(enframe(my_quantile(value,
                                               probs=c(0.05, 0.25, 0.5, 0.75, 0.95))))) %>%
        unnest %>%
        spread(name, value) %>%
        arrange(health_zone, var, time) %>%
        ungroup

    incidence <- cases_summary %>%
        inner_join(obs %>% rename(data=value), by=c("health_zone", "time", "var")) %>%
        mutate(type="With MVC",
               time=time-7) %>%
        filter(time < "2016-01-01")

    inp_no_mvc <- bi_read(posterior_no_mvc, file="input")
    inp_no_mvc$start_data %<>% rename(time=value)
    inp_no_mvc %<>%
        numeric_to_time(origin=min_date, unit="2 weeks")

    res_no_mvc <- bi_read(posterior_no_mvc, type=c("state", "obs", "noise")) %>%
        numeric_to_time(origin=min_date, unit="2 weeks") %>%
        flatten()

    cases_no_mvc_summary <- res_no_mvc %>%
        group_by(health_zone, time, var) %>%
        summarise(value =
                      list(enframe(my_quantile(value,
                                               probs=c(0.05, 0.25, 0.5,
                                                       0.75, 0.95))))) %>%
        unnest %>%
        spread(name, value) %>%
        arrange(health_zone, var, time) %>%
        ungroup

    incidence_no_mvc <- cases_no_mvc_summary %>%
        left_join(inp_no_mvc$start_data %>% rename(start_time=time),
                  by="health_zone") %>%
        filter(time >= start_time) %>%
        select(-start_time) %>%
        inner_join(obs %>% select(health_zone, var) %>% unique,
                   by=c("health_zone", "var")) %>%
        left_join(obs %>% rename(data=value), by=c("health_zone", "time", "var")) %>%
        mutate(type="Without MVC",
               time=time-7) %>%
        filter(time < "2016-01-01")

    incidence_all <- rbind(incidence, incidence_no_mvc)

    p <- ggplot(incidence_all) +
        geom_line(aes(x=time, y=`50%`, group=type, color=type)) +
        geom_ribbon(aes(x=time, ymin=`25%`, ymax=`75%`, group=type, fill=type),
                    alpha=0.5) +
        geom_ribbon(aes(x=time, ymin=`5%`, ymax=`95%`, group=type, fill=type),
                    alpha=0.25) +
        geom_point(aes(x=time, y=data)) +
        geom_rect(data=mvc_contiguous,
                  mapping=aes(xmin=min_date, xmax=max_date),
                  ymin=0, ymax=max(incidence_all$`95%`),
                  alpha=0.3, fill="blue") +
        facet_wrap(~health_zone, scales="free_y") +
        xlab("") +
        ylab("Observed Incidence") +
        scale_color_manual("", values=c("black", "red")) +
        scale_fill_manual("", values=c("black", "red")) +
        theme_cowplot() +
        theme(legend.position="top",
              axis.text.x=element_text(angle=45, hjust=1))

    return(p)
}


source("tools.r", chdir=T)

## Setup for parallell simulations
nSim <- 1000
values <- 1:nSim
numWorkers <- 8

## Read data
dataList <- readCancerData()

## Select start and stop times that will be used for selecting time periods
selStartStopTimes <- dataList$followUpTime[dataList$withSpread]

## === Analyses that compares cases with and without spread ===
caseStr <- "Weight"
caseN <- "N1"
periodLength <- 30
curDataList <- selectDataset(dataList, caseN, dataList$withSpread)
curDataList0 <- selectDataset(dataList, caseN, dataList$withoutSpread)
analyseData("Res/Weight/", selStartStopTimes, periodLength, caseStr,
            curDataList$data, curDataList$followUpTime,
            data0=curDataList0$data, followUpTime0=curDataList0$followUpTime,
            weights=curDataList$weights, weights0=curDataList0$weights)

## === Analyses for case-ctrl pairs with spread ===
caseN <- "N1"
for (caseStr in c("Sd", "Exp1", "Exp2")) {
  periodLength <- 30
  if (caseStr=="Sd")
    periodLength <- 35
  curDataList <- selectDataset(dataList, caseN, dataList$withSpread)
  analyseData(paste("Res/", caseStr, "/", sep=""), selStartStopTimes, periodLength,
              caseStr, curDataList$data, curDataList$followUpTime,
              weights=curDataList$weights)
}

## ===== Predict diagnosis, make gene list and plots =====
nofGenes <- c(50, 100, 200, 500, 1000, 2000)
periodLength <- 30
nofPeriods <- length(selStartStopTimes)-periodLength+1
selPeriodStr <- "year 4"
selPeriodInterval <- c(3*365,4*365)
selPeriodFromWith <- TRUE
hasInsitu <- FALSE
m <- 182
m2 <- 365
predictDiagnosis(dataList, periodLength, nofGenes,
                 "Res/followUpTimesWithPredRes", "Res/plotFracCorr", "Res/predResMat",
                 m, m2, selPeriodStr, selPeriodInterval, selPeriodFromWith, hasInsitu)

## Make gene list
selYear <- 3.5
makeGeneList(nofPeriods, periodLength, selStartStopTimes, selYear, "Res/genelist.txt")