cat('-----PrediXcan-R----- \n-----2021-07-14---- \n')

library(optparse)
library(glmnet)
library(RSQLite)
library(data.table)  #new added
library(foreach)   #new added
library(doParallel)   #new added

option_list = list(
  #general
  make_option("--main_dir", action="store", default=NA, type='character'),
  make_option("--plink_file_name", action="store", default=NA, type='character'),
  make_option("--expression_file_name", action="store", default=NA, type='character'),
  make_option("--annotation_file_name", action="store", default=NA, type='character'),
  make_option("--parallel", action="store_true", default=FALSE,
              help="max(n-1,1) core(s) will be used for parallel model training / association test, where n is the number of available cores"),

  #model training
  make_option("--model_training", action="store_true", default=FALSE),
  make_option("--subjob_id", action="store", default=1, type='integer'),
  make_option("--n_folds", action="store", default=5, type='integer',
              help="Number of cross-validation folds"),
  make_option("--n_genes_for_each_subjob", action="store", default=200, type='integer',
              help="Number of cross-validation folds"),
  make_option("--cis_window_size", action="store", default=1e6, type='integer'),
  make_option("--include_all_gene_types", action="store_true", default=FALSE,
              help = "otherwise, only protein_coding lincRNA, and miRNA will be included"),
  make_option("--only_include_variant_with_a_rsid", action="store_true", default=FALSE,
              help = "only variants with a name start with 'rs' will be included"),

  #generate db and cov
  make_option("--generate_db_and_cov", action="store_true", default=FALSE),
  make_option("--output_file_name", action="store", default=NA, type='character'),
  make_option("--clean_tmp", action="store_true", default=FALSE),

  #association test
  make_option("--asso_test", action="store_true", default=FALSE),
  make_option("--db_path", action="store", default=NA, type='character',
              help="Path to the weight file (.db) [required]"),
  make_option("--cov_path", action="store", default=NA, type='character',
              help="Path to the covariance file [required]"),
  make_option("--gwas_path", action="store", default=NA, type='character',
              help="Path to the GWAS summary statistics [required]"),
  make_option("--gene_list_path_for_asso_test", action="store", default=NA, type='character',
              help="Path to a file to specify a list of geneids need to run."),
  make_option("--asso_out_path", action="store", default=NA, type='character',
              help="Path to result file [required]"),
  make_option("--gwas_variant_col", action="store", default=NA, type='character',
              help="column name of gwas variant id [required]"),
  make_option("--gwas_beta_col", action="store", default=NA, type='character',
              help="column name of gwas beta [required, if OR is not provided]"),
  make_option("--gwas_or_col", action="store", default=NA, type='character',
              help="column name of gwas OR [required, if beta is not provided]"),
  make_option("--gwas_se_col", action="store", default=NA, type='character',
              help="column name of gwas se(beta) [required, if pvalue is not provided]"),
  make_option("--gwas_p_col", action="store", default=NA, type='character',
              help="column name of gwas pval [required, if se is not provided]"),
  make_option("--gwas_eff_allele_col", action="store", default=NA, type='character',
              help="column name of gwas effect allele [required]"),
  make_option("--gwas_ref_allele_col", action="store", default=NA, type='character',
              help="column name of gwas reference allele [required]")

)

opt = parse_args(OptionParser(option_list=option_list))

if(opt$model_training+opt$generate_db_and_cov+opt$asso_test != 1){
  stop('Please choose one of the three options "--model_training", "--generate_db_and_cov", or "--asso_test"')
}

#functions

model_training<-function(main_dir,
                         plink_file_name,
                         expression_file_name,
                         annotation_file_name,
                         cis_window_size=1e6,
                         i,
                         n_genes_for_each_subjob){

  #main_dir<-'/data/coxvgi/zhoud2/tools/predixcan'
  #cis_window_size=1e6
  #plink_file_name<-'geuvadis421'
  #expression_file_name<-'geuvadis_residual.txt'
  #annotation_file_name<-'gencode.v32.GRCh37.txt'
  #i=1

  #mkdir
  if(!dir.exists(paste0(main_dir,'/gene/'))){
    dir.create(paste0(main_dir,'/gene/'))
  }
  if(!dir.exists(paste0(main_dir,'/weights/'))){
    dir.create(paste0(main_dir,'/weights/'))
  }
  if(!dir.exists(paste0(main_dir,'/cov/'))){
    dir.create(paste0(main_dir,'/cov/'))
  }

  #load annotation
  print('INFO loading annotation ...')
  anno<-read.table(paste0(annotation_file_name),header = T,stringsAsFactors = F) #keeps the colnames consistant with the example file

  if(!opt$include_all_gene_types){
    anno<-anno[(anno$genetype %in% c('protein_coding','lincRNA','miRNA')),]
  }
  anno<-anno[(anno$chr %in% paste0('chr',seq(1,22))),]

  #load expression data
  print('INFO loading expression data ...')
  exp_all<-read.table(paste0(expression_file_name),header = T,stringsAsFactors = F, check.names = FALSE)  #keeps IID in genotype file match with IID in expression data
  #gene_list
  gene_list<-intersect(exp_all$geneid,anno$geneid)

  i_start<-(i-1)*n_genes_for_each_subjob+1
  i_end<-min(i*n_genes_for_each_subjob,length(gene_list))

  if (i_start<=length(gene_list)){
    print(paste0('INFO total gene no ',length(gene_list),', for this subjob, from ',i_start,' to ',i_end,' ...'))

    if(opt$parallel){

      registerDoParallel(cores = max(detectCores()-1, 1))

      foreach(i = i_start:i_end) %dopar% {

        geneid=gene_list[i] #geneid='ENSG00000003402'
        print(paste0('INFO processing gene no.',i,' ',geneid))

        #get gene position  #use same build
        chr=sub('^...','',anno$chr[which(anno$geneid==geneid)])
        pos_l=max(anno$left[which(anno$geneid==geneid)]-cis_window_size,1)
        pos_r=anno$right[which(anno$geneid==geneid)]+cis_window_size

        #generate expression df
        exp<-data.frame('IID'=as.character(colnames(exp_all)[-1]),'exp'=as.numeric(exp_all[exp_pos<-which(exp_all[,1]==geneid),][-1]))

        each_gene(main_dir=main_dir,plink_file_name=plink_file_name,chr=chr,pos_l=pos_l,pos_r=pos_r,geneid=geneid,exp=exp)

      }

      stopImplicitCluster()

    }else{

      for (i in i_start:i_end){
        geneid=gene_list[i] #geneid='ENSG00000003402'
        print(paste0('INFO processing gene no.',i,' ',geneid))

        #get gene position  #use same build
        chr=sub('^...','',anno$chr[which(anno$geneid==geneid)])
        pos_l=max(anno$left[which(anno$geneid==geneid)]-cis_window_size,1)
        pos_r=anno$right[which(anno$geneid==geneid)]+cis_window_size

        #generate expression df
        exp<-data.frame('IID'=as.character(colnames(exp_all)[-1]),'exp'=as.numeric(exp_all[exp_pos<-which(exp_all[,1]==geneid),][-1]))

        each_gene(main_dir=main_dir,plink_file_name=plink_file_name,chr=chr,pos_l=pos_l,pos_r=pos_r,geneid=geneid,exp=exp)

      }

    }

  }else{
    print('start_i > N of genes')
  }

}

snpid_helper = function(str){
  elements = strsplit(str,"[_]")[[1]]
  snpid = list()
  snpid$id = paste(elements[-length(elements)],collapse = '_')
  snpid$allele = elements[length(elements)]
  return(snpid)
}

each_gene<-function(main_dir,plink_file_name,chr,pos_l,pos_r,geneid,exp){
  #generate genotype dosage file for each gene
  #extract from plink
  cmd<-paste0('plink --bfile ',plink_file_name,' --chr ',chr,' --from-bp ',pos_l,' --to-bp ',pos_r,' --recodeA --out ',main_dir,'/gene/',geneid)
  system(cmd,ignore.stdout=T,ignore.stderr=T,wait=T)

  #load dosage
  dosage_raw<-try(read.table(paste0(main_dir,'/gene/',geneid,'.raw'),header = T,stringsAsFactors = F))

  if(opt$only_include_variant_with_a_rsid){
    dosage_raw<-dosage_raw[,c(seq(1,6),which(substr(colnames(dosage_raw),1,2)=='rs'))]
  }

  if(!('try-error' %in% class(dosage_raw))){
    #rm raw file
    cmd<-paste0('rm ',main_dir,'/gene/',geneid,'*'); system(cmd,wait = T)
    #del useless cols
    dosage<-dosage_raw[,-c(1,3:6)]

    #check if there is a '-' to '.' issue in colnames
    if(length(intersect(exp$IID, dosage$IID))==0){
      #if so, replace all the . with -
      exp$IID = gsub('\\.','-',exp$IID)
    }

    #merge genotype and expression
    df<-merge(exp,dosage,by='IID')

    #run elastic net
    y<-as.matrix(df[,2])
    x<-as.matrix(df[,c(3:ncol(df))])
    rm(df)

    #skip genes with only one SNP
    if(ncol(x)>=2){

      set.seed(as.numeric(sub('^....','',geneid)))
      fit<-try(cv.glmnet(x=x,y=y, nfolds = 5,keep = T,alpha=0.5,nlambda=50,pmax=200))
      if(!('try-error' %in% class(fit))){
        beta=as.numeric(fit$glmnet.fit$beta[,which(fit$lambda==fit$lambda.min)])

        performance<-cor.test(y,fit$fit.preval[,which(fit$lambda == fit$lambda.min)])
        r<-as.numeric(performance$estimate)
        p<-as.numeric(performance$p.value)

        #generate weight df
        weights_df<-data.frame('rsid'=colnames(dosage)[-1],'weights'=beta,stringsAsFactors = F,'r2'=r^2,'p'=p)
        weights_df$effect_allele<-sapply(weights_df$rsid, function(x) snpid_helper(x)[['allele']])
        weights_df$rsid<-sapply(weights_df$rsid, function(x) snpid_helper(x)[['id']])

        #rm weight=0 rows
        weights_df<-weights_df[weights_df$weights!=0,]

        if (nrow(weights_df)>0 & r>0.1 & p<0.05){

          #generate covariance matrix
          colnames(dosage)[-1]<-sapply(colnames(dosage)[-1], function(x) snpid_helper(x)[['id']])
          dosage<-dosage[,c(which(colnames(dosage) %in% weights_df$rsid))]
          cov_df<-as.data.frame(matrix(data=NA,ncol=4,nrow=1))
          colnames(cov_df)<-c('GENE','RSID1','RSID2','VALUE')

          #calculate covariance
          if(nrow(weights_df)>1){
            snp_list<-colnames(dosage)
            o_i=1
            for (k in 1:length(snp_list)){
              for (j in k:length(snp_list)){
                cov_df[o_i,2]<-snp_list[k]
                cov_df[o_i,3]<-snp_list[j]
                cov_df[o_i,4]<-round(cov(dosage[,which(colnames(dosage)==snp_list[k])],dosage[,which(colnames(dosage)==snp_list[j])]),3)
                o_i=o_i+1
              }
            }
          }else{
            cov_df[,'RSID1']=cov_df[,'RSID2']=weights_df[1,'rsid']
            cov_df[,'VALUE']=cov(dosage,dosage)
          }

          cov_df[,1]<-geneid

          #output cov
          write.table(cov_df,paste0(main_dir,'/cov/',geneid,'.txt'),sep='\t',quote = F,row.names = F)
          #output weights
          write.table(weights_df,paste0(main_dir,'/weights/',geneid,'.txt'),sep='\t',quote = F,row.names = F)
        }

      }else{
        print('INFO failed to build the model')
      }
    }else{
      print('INFO only one SNP available for the gene')
    }
  }else{
    print('INFO no genotype data for this gene')
  }
}

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

weights_cov<-function(main_dir,plink_file_name,expression_file_name,output_file_name,annotation_file_name){

  #mkdir
  if(!dir.exists(paste0(main_dir,'/output/'))){
    dir.create(paste0(main_dir,'/output/'))
  }

  #load annotation
  anno<-read.table(paste0(annotation_file_name),header = T,stringsAsFactors = F)

  #gene list
  gene_list<-sub('....$','',dir(paste0(main_dir,'/cov/')))

  #load weights
  print('INFO loading weights...')
  print(paste0('INFO totally ',length(gene_list),' imputable genes'))
  db_weights<-list()
  n_rows=0
  for (i in 1:length(gene_list)){
    if(i %in% c(seq(1,1000)*100,length(gene_list))){
      print(paste0('     ',i,' loaded'))
    }
    geneid<-gene_list[i]
    db_weights[[i]]<-read.table(paste0(main_dir,'/weights/',geneid,'.txt'),header = T,stringsAsFactors = F)
    n_rows=n_rows+nrow(db_weights[[i]])

    #cleaning tmp files
    if(opt$clean_tmp){
      file.remove(paste0(main_dir,'/weights/',geneid,'.txt'))
    }

  }

  #db.weight
  print('INFO generating db file...')
  weights<-as.data.frame(matrix(data=NA,ncol=4,nrow=n_rows))
  colnames(weights)<-c('rsid','gene','weight','eff_allele')

  #db.sample_info
  n_sample<-read.table(paste0(expression_file_name),header = T,nrows=1,stringsAsFactors = F)
  sample_info<-data.frame('n.samples'=ncol(n_sample)-1)

  #db.extra
  extra<-as.data.frame(matrix(data=NA,ncol=6,nrow=length(gene_list)))
  colnames(extra)<-c('gene','genename','pred.perf.R2','n.snps.in.model','pred.perf.pval','pred.perf.qval')

  n_rows=0
  for (i in 1:length(gene_list)){
    #extra.gene
    extra[i,1]<-gene_list[i]
    #extra.genename
    extra[i,2]<-anno[which(anno$geneid==gene_list[i]),'genename']
    #extra.r2
    extra[i,3]<-db_weights[[i]][1,3]
    #extra.n.snps
    extra[i,4]<-nrow(db_weights[[i]])
    #extra.n.snps
    extra[i,5:6]<-db_weights[[i]][1,4]

    weights[(n_rows+1):(n_rows+nrow(db_weights[[i]])),]<-as.matrix(data.frame('rsid'=db_weights[[i]]$rsid,'gene'=gene_list[i],'weight'=db_weights[[i]]$weights,'effect_allele'=db_weights[[i]]$effect_allele))
    n_rows=n_rows+nrow(db_weights[[i]])

  }

  extra$pred.perf.qval=p.adjust(extra$pred.perf.pval,method = 'BH')

  #load bim to get ref allele
  bim<-read.table(paste0(plink_file_name,'.bim'),header = F,stringsAsFactors = F)
  bim<-bim[bim[,2]!='.',];bim<-bim[!duplicated(bim[,2]),]
  bim<-bim[which(bim[,2] %in% weights[,1]),-1]

  weights<-merge(weights,bim,by=1)
  weights$ref_allele<-ifelse(weights$eff_allele==weights$V5,weights$V6,weights$V5)
  weights<-weights[,c(1,2,3,9,4)]

  #output db file
  print('INFO write db file...')

  if(file.exists(paste0(main_dir,"/output/",output_file_name,".db"))){
    file.remove(paste0(main_dir,"/output/",output_file_name,".db"))
  }

  db<-dbConnect(RSQLite::SQLite(), paste0(main_dir,"/output/",output_file_name,".db"))
  dbWriteTable(db, "weights", weights)
  dbWriteTable(db, "extra", extra)
  dbWriteTable(db, "sample_info", sample_info)
  dbDisconnect(db)

  #load cov
  print('INFO loading cov files...')
  cov<-list()
  n_rows=0
  for (i in 1:length(gene_list)){
    if(i %in% c(seq(1,1000)*100,length(gene_list))){
      print(paste0('     ',i,' loaded'))
    }
    geneid<-gene_list[i]
    cov[[i]]<-read.table(paste0(main_dir,'/cov/',geneid,'.txt'),header = T,stringsAsFactors = F)
    n_rows=n_rows+nrow(cov[[i]])

    #cleaning tmp files
    if(opt$clean_tmp){
      file.remove(paste0(main_dir,'/cov/',geneid,'.txt'))
    }

  }
  cov_df<-as.data.frame(matrix(data=NA,ncol=4,nrow=n_rows))
  colnames(cov_df)<-c('GENE','RSID1','RSID2','VALUE')
  #combine cov
  print('INFO combining cov file...')
  n_rows=0
  for (i in 1:length(gene_list)){
    cov_df[(n_rows+1):(n_rows+nrow(cov[[i]])),]<-cov[[i]]
    n_rows=n_rows+nrow(cov[[i]])
  }

  #output cov
  print('INFO writing cov file...')
  write.table(cov_df,paste0(main_dir,'/output/',output_file_name,'.cov'),sep='\t',row.names = F,quote = F)

  print('INFO finished')
}

#asso test func
asso<-function(gene_id){

  df = weights[weights$gene == gene_id, ]
  df$weight = as.numeric(df$weight)
  df$id = seq(1,nrow(df))

  cov_tmp = cov_all[cov_all$GENE == gene_id, ]
  cov_tmp = merge(cov_tmp, df[,c('rsid','id')], by.x = 'RSID1', by.y = 'rsid')
  cov_tmp = merge(cov_tmp, df[,c('rsid','id')], by.x = 'RSID2', by.y = 'rsid')

  cov_matrix = matrix(data = NA, nrow = nrow(df), ncol = nrow(df))

  for(i in 1:nrow(cov_tmp)){
    cov_matrix[cov_tmp[i,'id.x'], cov_tmp[i,'id.y']] = cov_tmp[i, 'VALUE']
    cov_matrix[cov_tmp[i,'id.y'], cov_tmp[i,'id.x']] = cov_tmp[i, 'VALUE']
  }

  #var(GReX)
  var_GReX = as.numeric(t(df$weight) %*% cov_matrix %*% df$weight)

  #beta
  effect_size = sum(df$weight * df[,gwas_beta_col] * diag(cov_matrix) / var_GReX)

  #z-score
  zscore = sum(df$weight * sqrt(diag(cov_matrix)) * df[,gwas_beta_col] / sqrt(var_GReX) / df[,gwas_se_col])
  ans = list()
  ans[['effect_size']] = effect_size
  ans[['zscore']] = zscore
  ans[['n_snps_used']] = nrow(df)
  return(ans)

}

#model training
if(opt$model_training){
  print('INFO model training')
  print(paste0('INFO subjob id: ',opt$subjob_id))

  model_training(main_dir=opt$main_dir,
                 cis_window_size=opt$cis_window_size,
                 plink_file_name=opt$plink_file_name,
                 expression_file_name=opt$expression_file_name,
                 annotation_file_name=opt$annotation_file_name,
                 i=opt$subjob_id,
                 n_genes_for_each_subjob=opt$n_genes_for_each_subjob
  )
}

#generate db cov
if(opt$generate_db_and_cov){
  print('INFO generating db and cov files')

  weights_cov(main_dir=opt$main_dir,
              plink_file_name=opt$plink_file_name,
              expression_file_name=opt$expression_file_name,
              annotation_file_name=opt$annotation_file_name,
              output_file_name=opt$output_file_name
  )
}

#association test
if(opt$asso_test){
  db_path = opt$db_path
  cov_path = opt$cov_path
  gwas_path = opt$gwas_path
  gwas_variant_col = opt$gwas_variant_col
  gwas_beta_col = opt$gwas_beta_col
  gwas_or_col = opt$gwas_or_col
  gwas_se_col = opt$gwas_se_col
  gwas_p_col = opt$gwas_p_col
  gwas_eff_allele_col = opt$gwas_eff_allele_col
  gwas_ref_allele_col = opt$gwas_ref_allele_col
  gene_list_path = opt$gene_list_path_for_asso_test
  asso_out_path = opt$asso_out_path
  parallel = opt$parallel

  #load data
  cat('INFO loading weight file ...\n')
  con <- dbConnect(RSQLite::SQLite(), dbname=db_path) #establish connections
  weights = dbReadTable(con,"weights")
  colnames(weights) = c('rsid', 'gene', 'weight', 'model_ref_allele', 'model_eff_allele')
  extra_info = dbReadTable(con,"extra")
  dbDisconnect(con) #disconnect

  cat('INFO loading covariance ...\n')
  cov_all = data.frame(fread(cov_path))

  cat('INFO loading GWAS results ...\n')
  gwas <- data.frame(fread(gwas_path))

  #convert beta, or, se, pval
  gwas <- gwas[!duplicated(gwas[,gwas_variant_col]),]
  if(is.na(gwas_beta_col)){
    gwas$beta = log(gwas[,gwas_or_col],2.718)
    gwas_beta_col = 'beta'
  }
  if(is.na(gwas_se_col)){
    gwas$z_score = qnorm(1-gwas_p_col/2)
    gwas$se = gwas[,gwas_beta_col] / gwas[,'z_score']
    gwas_se_col = 'se'
  }

  #get the list of snps both available from gwas and prediction model
  weights <- merge(weights, gwas, by.x = 'rsid', by.y = gwas_variant_col)

  #strand check
  cat('INFO strand check and allele flipping ...\n')
  weights$allele_idx1 = weights[,'model_eff_allele'] == weights[,gwas_eff_allele_col]
  weights$allele_idx2 = weights[,'model_eff_allele'] == weights[,gwas_ref_allele_col]

  same_strand_pos = which(weights$allele_idx1 | weights$allele_idx2)
  num_of_variants_have_same_strand = length(same_strand_pos)

  if (num_of_variants_have_same_strand / nrow(weights) <0.9){
    stop('More than 10% of the variants in GWAS summary statistics have different strand, please check')
  }

  weights = weights[same_strand_pos,]

  #flip alleles
  weights[,gwas_beta_col] = ifelse(weights$allele_idx1, weights[,gwas_beta_col], weights[,gwas_beta_col]*-1)

  gene_list <- unique(weights$gene)

  if(!is.na(gene_list_path)){
    specified_gene_list = read.table(gene_list_path, header = T,stringsAsFactors = F)
    gene_list = intersect(gene_list, specified_gene_list[,1])
  }

  cat(paste0('INFO Association test for ',length(gene_list),' imputable genes ...\n'))

  if(parallel){
    registerDoParallel(cores = max(detectCores()-1, 1))

    trials <- length(gene_list)

    #system.time({
      result <- foreach(i = 1:trials, .combine=rbind) %dopar% {
        gene_id = gene_list[i]
        asso_ans = asso(gene_id)
        cat(paste0('INFO ',gene_id,' completed \n'))
        unlist(asso_ans)
      }
    #})

    stopImplicitCluster()

  }else{
    #The non-parallele way
    result <- as.data.frame(t(sapply(gene_list, function(x) asso(x))))
    result$effect_size = as.numeric(result$effect_size)
    result$zscore = as.numeric(result$zscore)
    result$n_snps_used = as.numeric(result$n_snps_used)
  }

  #output
  result = as.data.frame(result, stringsAsFactors = F)
  result$gene = gene_list
  result$pvalue = (1-pnorm(abs(result$zscore)))*2  #two sided

  result = merge(result, extra_info, by='gene')

  result = result[,c('gene','genename','zscore','effect_size','pvalue','pred.perf.R2','pred.perf.pval','n_snps_used','n.snps.in.model')]
  colnames(result) = c('gene','genename','zscore','effect_size','pvalue','pred_perf_R2','pred_perf_pval','n_snps_used','n_snps_in_model')

  result = result[order(abs(result$zscore),decreasing=T),]
  write.table(result, asso_out_path, quote = F, row.names = F, sep = '\t')

  cat('INFO done\n')

}


#' Import user daily data for EGRET analysis
#'
#' Imports data from a user-supplied file, and converts it to a Daily data frame, appropriate for WRTDS calculations.
#'
#' @param filePath character specifying the path to the file
#' @param fileName character name of file to open
#' @param hasHeader logical true if the first row of data is the column headers
#' @param separator character character that separates data cells
#' @param qUnit number 1 is cubic feet per second, 2 is cubic meters per second, 3 is 10^3 cubic feet per second, and 4 is 10^3 cubic meters per second
#' @param interactive logical Option for interactive mode.  If true, there is user interaction for error handling and data checks.
#' @keywords data import file
#' @keywords data import USGS WRTDS
#' @export
#' @return A data frame 'Daily' with the following columns:
#' \tabular{lll}{
#' Name \tab Type \tab Description \cr
#' Date \tab Date \tab Date \cr
#' Q \tab numeric \tab Discharge in m^3/s\cr
#' Julian \tab integer \tab Number of days since Jan. 1, 1850\cr
#' Month \tab integer \tab Month of the year [1-12] \cr
#' Day \tab integer \tab Day of the year [1-366] \cr
#' DecYear \tab numeric \tab Decimal year \cr
#' MonthSeq \tab integer \tab Number of months since January 1, 1850 \cr
#' Qualifier \tab character \tab Qualifying code \cr
#' i \tab integer \tab Index of days, starting with 1 \cr
#' LogQ \tab numeric \tab Natural logarithm of Q  \cr
#' Q7 \tab numeric \tab 7 day running average of Q \cr
#' Q30 \tab numeric \tab 30 day running average of Q \cr
#' }
#' @examples
#' filePath <- system.file("extdata", package="EGRET")
#' fileName <- "ChoptankRiverFlow.txt"
#' Daily <- readUserDaily(filePath,fileName,separator="\t")
readUserDaily <- function (filePath,fileName,hasHeader=TRUE,separator=",",qUnit=1,interactive=TRUE){
  data <- readDataFromFile(filePath,fileName,hasHeader=hasHeader,separator=separator)
  convertQ<-c(35.314667,1,0.035314667,0.001)
  qConvert<-convertQ[qUnit]
  if (interactive){
    if(qUnit==1) cat("\n the input discharge are assumed to be in cubic feet per second\nif they are in cubic meters per second, then the call to readUserDaily should specify qUnit=2\n")
  }
  names(data) <- c("dateTime", "value")
  localDaily <- populateDaily(data,qConvert, interactive=interactive)
  localDaily <- localDaily[!is.na(localDaily$Q),]
  return(localDaily)
}


#' @title
#' Transform web matrix to expanded data frame
#'
#' @description
#'  Transform a web matrix to an expanded data frame which is needed as input
#'  for the bootstrap functions. Each row (interaction) is repeated as many
#'  times as it was observed. This is important for the sampling procedure. Rows
#'  are shuffled.
#'
#' @param web
#'  A web matrix, e.g. `Safariland` from \code{\link{bipartite}}.
#'
#' @param seed
#'  Passed to `set.seed()`. Used for shuffling rows in a reproducible way.
#'
#' @return
#'  Returns an expanded data frame needed as input for the bootstrap functions.
#'  Rows are shuffled.
#'
#' @examples
#'
#' library(bootstrapnet)
#' library(bipartite)
#' data(Safariland)
#'
#' Safariland_df <- web_matrix_to_df(Safariland)
#'
#' @importFrom magrittr %>%
#' @importFrom tibble rownames_to_column
#' @importFrom tidyr gather
#' @importFrom dplyr filter slice n sample_frac
#' @importFrom methods is
#'
#' @export
#'
#' @md
web_matrix_to_df <- function(web, seed = 42){
  if (! is(web, "matrix")) stop("`web` must be a matrix, e.g. `bipartite::Safariland`")

  set.seed(seed)
  web %>%
    as.data.frame %>%
    tibble::rownames_to_column(var = "lower") %>%
    tidyr::gather(key = "higher", value = "counts", -"lower") %>%
    dplyr::filter(counts != 0) %>%
    dplyr::slice(rep(1:n(), times = counts)) %>%
    dplyr::sample_frac()
}

#' @title
#' Prepare bootstrapped results of a single network for `ggplot` friendly data
#' format.
#'
#' @description
#'  Helper to prepare the bootstrapped metric output of a single web/network
#'  from \code{\link[bootstrapnet]{boot_networklevel_n}} or
#'  \code{\link[bootstrapnet]{boot_specieslevel_n}} in a format ready for
#'  \code{\link[ggplot2]{ggplot}}.
#'
#' @param x
#'  A bootstrap matrix or an array of matrices from
#'  \code{\link[bootstrapnet]{boot_networklevel_n}} or
#'  \code{\link[bootstrapnet]{boot_specieslevel_n}}.
#'
#' @param probs
#'  A numeric vector of two probabilities in `[0, 1]`. Passed to
#'  \code{\link[matrixStats]{rowQuantiles}} and used for building the lower and
#'  upper bounds of the confidence intervals. Defaults to `c(0.025, 0.975)`,
#'  which corresponds to a 95\\% confidence interval.
#'
#' @return
#'  A list of two data frames to be used with \code{\link[ggplot2]{ggplot}}.
#'  First one, `stats_df` is a 4 columns data frame, containing the sample size
#'  (`spl_size`) at each iteration and the corresponding mean metric (`mean`)
#'  together with its bootstrap confidence interval limits (`ci_low`, `ci_up`).
#'  The second one, `lines_df`, contains all the bootstrapped values (`value`) of
#'  a given network metric at each iteration (`simulation_id`) and its
#'  corresponding sample size (`spl_size`). Can be used for enhancing visual
#'  effect when plotting the mean bootstrap values.
#'
#' @examples
#' library(bootstrapnet)
#' library(bipartite)
#' library(magrittr)
#' data(Safariland)
#'
#' stats_d_lower <- Safariland %>%
#'   web_matrix_to_df() %>%
#'   boot_specieslevel_n(col_lower = "lower", # column name for plants
#'                         col_higher = "higher", # column name for insects
#'                         index = "d",
#'                         level = "both",
#'                         start = 100,
#'                         step = 100,
#'                         n_boot = 10,
#'                         n_cpu = 2) %>%
#'   .[["lower_level"]] %>%
#'   get_stats_single()
#'
#' @importFrom magrittr %>%
#' @importFrom data.table melt rbindlist
#' @importFrom dplyr mutate inner_join
#' @importFrom tibble rownames_to_column
#' @importFrom purrr reduce
#' @importFrom matrixStats rowMeans2 rowQuantiles
#'
#' @export
#'
#' @md
get_stats_single <- function(x, probs = c(0.025, 0.975)){
  if (! is.array(x) ) stop("Expecting a matrix or a 3 dimensions array")

  if (is.matrix(x)) {
    stats_df <- data.frame(spl_size = as.integer(rownames(x))) %>%
      dplyr::mutate(mean   = matrixStats::rowMeans2(x, na.rm = TRUE),
                    ci_low = matrixStats::rowQuantiles(x, probs = probs[1], na.rm = TRUE) %>% unname,
                    ci_up  = matrixStats::rowQuantiles(x, probs = probs[2], na.rm = TRUE) %>% unname)

    lines_df <- x %>%
      as.data.frame %>%
      tibble::rownames_to_column(var = "spl_size") %>%
      setDT() %>%
      data.table::melt(id.vars = "spl_size",
                       variable.name = "simulation_id") %>%
      dplyr::mutate(spl_size = as.integer(spl_size),
                    simulation_id = as.integer(simulation_id))

    return(list(stats_df = stats_df,
                lines_df = lines_df))

  } else if (length(dim(x)) == 3) {
    means <- x %>%
      apply(MARGIN = 1:2, FUN = mean, na.rm = TRUE) %>%
      as.data.frame %>%
      tibble::rownames_to_column(var = "sp") %>%
      setDT() %>%
      data.table::melt(id.vars = "sp", variable.name = "spl_size", value.name = "mean")

    quantiles_low <- x %>%
      apply(MARGIN = 1:2, FUN = quantile, na.rm = TRUE, probs = probs[1]) %>%
      as.data.frame %>%
      tibble::rownames_to_column(var = "sp") %>%
      setDT() %>%
      data.table::melt(id.vars = "sp", variable.name = "spl_size", value.name = "ci_low")

    quantiles_up <- x %>%
      apply(MARGIN = 1:2, FUN = quantile, na.rm = TRUE, probs = probs[2]) %>%
      as.data.frame %>%
      tibble::rownames_to_column(var = "sp") %>%
      setDT() %>%
      data.table::melt(id.vars = "sp", variable.name = "spl_size", value.name = "ci_up")

    stats_df <- list(means, quantiles_low, quantiles_up) %>%
      purrr::reduce(dplyr::inner_join, by = c("sp", "spl_size")) %>%
      dplyr::mutate(spl_size = as.integer(as.character(spl_size)))

    lines_df <- x %>%
      apply(MARGIN = 3, FUN = as.data.frame) %>%
      lapply(rownames_to_column, var = "sp") %>%
      data.table::rbindlist(idcol = "simulation_id") %>%
      setDT() %>%
      data.table::melt(id.vars = c("sp", "simulation_id"), variable.name = "spl_size") %>%
      dplyr::mutate(spl_size = as.integer(as.character(spl_size)))

    return(list(stats_df = stats_df,
                lines_df = lines_df))
  }
}

#' @title
#'  Prepare bootstrapped results of one or more networks for `ggplot2` friendly
#'  data format.
#'
#' @description
#'  Helper to prepare the bootstrapped metric output of one or more
#'  webs/networks from \code{\link[bootstrapnet]{boot_specieslevel}},
#'  \code{\link[bootstrapnet]{boot_networklevel_n}} or
#'  \code{\link[bootstrapnet]{boot_specieslevel_n}} in a format ready for
#'  \code{\link[ggplot2]{ggplot}}. See the examples section of
#'  \code{\link[bootstrapnet]{boot_specieslevel}}.
#'
#' @param webs_stats
#'  A list of bootstrap results from
#'  \code{\link[bootstrapnet]{boot_specieslevel}}, or from multiple runs of
#'  \code{\link[bootstrapnet]{boot_networklevel_n}} or
#'  \code{\link[bootstrapnet]{boot_specieslevel_n}}.
#'
#' @return
#'  A list of two data frames to be used with \code{\link[ggplot2]{ggplot}}.
#'  First one, `stats_df` is a 5 columns data frame, containing for each network
#'  (`web`) the sample size (`spl_size`) at each iteration and the corresponding
#'  mean metric (`mean`), together with its bootstrap confidence interval limits
#'  (`ci_low`, `ci_up`). The second one, `lines_df`, contains all the
#'  bootstrapped values (`value`) of a given network metric at each iteration
#'  (`simulation_id`) and its corresponding sample size (`spl_size`). Can be
#'  used for enhancing visual effect when plotting the mean bootstrap values.
#'
#' @examples
#'  # See example section of ?boot_specieslevel
#'
#' @export
#'
#' @md
get_stats_multi <- function(webs_stats){

  metric_names <- names(webs_stats[[1]])
  n <- length(metric_names)

  metrics_stats <- vector(mode = "list", length = n)
  names(metrics_stats) <- metric_names

  for (i in 1:n){
    temp <- webs_stats %>%
      lapply("[[", metric_names[i])

    temp_stats_df <- temp %>%
      lapply("[[", "stats_df") %>%
      data.table::rbindlist(idcol = "web") %>%
      data.table::setDF()

    temp_lines_df <- temp %>%
      lapply("[[", "lines_df") %>%
      data.table::rbindlist(idcol = "web") %>%
      data.table::setDF()

    metrics_stats[[i]] <- list(stats_df = temp_stats_df,
                               lines_df = temp_lines_df)

    rm(temp, temp_stats_df, temp_lines_df)
  }

  return(metrics_stats)
}

# Hidden helper functions -------------------------------------------------

#' @title
#' Splits a vector of indices `x` in `n` chunks.
#'
#' @description
#'  Splits a vector of indices `x` in `n` chunks. Inspired from
#'  https://stackoverflow.com/a/16275428/5193830
#'
#' @param x
#'  A vector of indices.
#'
#' @param n
#'  Number of chunks.
#'
#' @return
#'  A list of `n` vectors of indices.
#'
#' @noRd
split_in_chunks <- function(x, n) {
  split(x = x,
        f = cut(x = seq_along(x),
                breaks = n,
                labels = FALSE))
}

#' @title
#' Prepare a list of interaction indices for bootstrapping.
#'
#' @description
#'  Prepares a list of row indices from `data`. The first vector of indices (the
#'  first element of the list) has the length given by `start`. This stands for
#'  the smallest network of interactions sampled from `data`. Then the next
#'  vector of indices grows by `step`. The final vector contains all the
#'  interactions.
#'
#' @param data
#'  `data.table` of interactions from which to build and sample web matrices.
#'
#' @param start
#'  Integer. The sample size (number of interactions) of the first sampled
#'  network.
#'
#' @param step
#'  Integer. Sample size (number of interactions) used to increase gradually the
#'  sampled network until all interactions are sampled.
#'
#' @param seed
#'  Set seed to get reproducible random results. Passed to `set.seed()`.
#'
#' @return
#'  A list of vectors containing interaction indices.
#'
#' @noRd
sample_indices <- function(data, start, step, seed){
  set.seed(seed)
  # Shuffle the ids to sample from
  ids_shuffle <- sample(1:nrow(data))
  # Draw the start sample; set.seed() from above has effect here as well
  start_sample <- tryCatch(
    {
      sample(ids_shuffle, start)
    },
    error = function(cond){
      message(cond, "\n")
      stop("\nPossibly because your `start` value, ", start,
           ", is bigger than the number of interactions in data, ",
           unique(data) %>% dplyr::select(counts) %>% sum(),
           ".\nIf this is the case, then consider to reduce `start` to maybe 10 % of your interactions.")
    }
  )
  # Remove the already sampled ids used for the start sample
  ids_remaining <- ids_shuffle[! ids_shuffle %in% start_sample]

  # Build the list of growing sampled indices. The first element (first vector
  # of indices) was already sampled above (the start sample). Then add gradually
  # a new chunk of indices until all indices are used.
  ids_remaining_chunks <- tryCatch(
    {
      split_in_chunks(ids_remaining, length(ids_remaining)/step)
    },
    error = function(cond){
      message(cond, "\n")
      stop("\nPossibly because your `step` value, ", step,
           ", is bigger than the number of interactions in data, ",
           unique(data) %>% dplyr::select(counts) %>% sum(),
           ".\nIf this is the case, then consider to reduce `step` to maybe 5-10 % of your interactions.")
    }
  )
  ids_lst <- vector(mode = "list", length = (length(ids_remaining_chunks) + 1))
  ids_lst[[1]] <- start_sample
  for (i in 2:length(ids_lst)){
    ids_lst[[i]] <- c(ids_lst[[i-1]], ids_remaining_chunks[[i-1]])
  }

  return(ids_lst)
}

#' @title
#'  Helper function used in `boot_specieslevel_once()`. Gathers results in
#'  matrices.
#'
#' @description
#'  Prepares a list of matrices with the bootstrapped network metrics at species
#'  level.
#'
#' @param data
#'  `data.table` of interactions.
#'
#' @param col
#'  Quoted column name in `data` for lower trophic level species (plants) or for
#'  higher trophic level species (insects). See `boot_specieslevel_n()`.
#'
#' @param metric_lst
#'  A list of bootstrap outputs (data frames) from `bipartite::specieslevel`.
#'
#' @param level
#'  For which level should the level-specific indices be computed: 'both'
#'  (default), 'lower' or 'higher'?
#'
#' @return
#'  A list of matrices.
#'
#' @noRd
boot_specieslevel_lower_or_higher <- function(data, col, metric_lst, level){
  # Get species names from the web
  sp <- data[[col]] %>% unique %>% sort
  # Allocate memory for the matrix that will store bootstrap results. Rows
  # correspond to each species and columns correspond to each bootstrap
  # iteration. The last column will store metric results for the entire web.
  # Allocate memory also for a matrix that can contain the weighted version of
  # the metric if such a case is applicable (e.g. for index = "betweenness"
  # the output returned by bipartite::specieslevel is a two columns data
  # frame)
  n <- length(metric_lst)
  if (dim(metric_lst[[n]])[2] == 1) {
    boot_mat <- matrix(nrow = length(sp), ncol = length(metric_lst))
    rownames(boot_mat) <- sp
    # Because the first iterations most probably do not include all species
    # from the web, then must match species names in the matrix when storing
    # results.
    for (j in 1:n){
      indices_logical <- rownames(boot_mat) %in% rownames(metric_lst[[j]])
      boot_mat[indices_logical, j] <- metric_lst[[j]][, 1]
    }

    if (level == "lower") {
      return(list(lower_level = boot_mat))
    } else if (level == "higher") {
      return(list(higher_level = boot_mat))
    }

    # In case of weighted indices:
  } else if (dim(metric_lst[[n]])[2] == 2) {
    boot_mat <- boot_mat_weighted <- matrix(nrow = length(sp), ncol = length(metric_lst))
    rownames(boot_mat) <- rownames(boot_mat_weighted) <- sp
    for (j in 1:n){
      indices_logical <- rownames(boot_mat) %in% rownames(metric_lst[[j]])
      boot_mat[indices_logical, j] <- metric_lst[[j]][, 1]
      boot_mat_weighted[indices_logical, j] <- metric_lst[[j]][, 2]
    }

    if (level == "lower") {
      return(list(lower_level = boot_mat,
                  lower_level_weighted = boot_mat_weighted))
    } else if (level == "higher") {
      return(list(higher_level = boot_mat,
                  higher_level_weighted = boot_mat_weighted))
    }
  }
}

#' @title
#'  Helper function used in `boot_specieslevel_once()`. Gathers results in
#'  matrices.
#'
#' @description
#'  Similar to `boot_specieslevel_lower_or_higher` above, but with the extra
#'  layer of complexity of dealing with both levels at once.
#'
#' @param data
#'  `data.table` of interactions.
#'
#' @param col_lower
#'  Quoted column name in `data` for lower trophic level species (plants).
#'
#' @param col_higher
#'  Quoted column name in `data` for higher trophic level species (insects).
#'
#' @param metric_lst
#'  A list of bootstrap outputs (data frames) from `bipartite::specieslevel`.
#'
#' @return
#'  A list of matrices.
#'
#' @noRd
boot_specieslevel_both_levels <- function(data, col_lower, col_higher, metric_lst){
  # Get species names from the web
  sp_low <- data[[col_lower]] %>% unique %>% sort
  sp_high <- data[[col_higher]] %>% unique %>% sort

  n <- length(metric_lst)
  if (dim(metric_lst[[n]][[1]])[2] == 1) {
    boot_mat_lower_level <- matrix(nrow = length(sp_low), ncol = length(metric_lst))
    rownames(boot_mat_lower_level) <- sp_low

    boot_mat_higher_level <- matrix(nrow = length(sp_high), ncol = length(metric_lst))
    rownames(boot_mat_higher_level) <- sp_high

    for (j in 1:n){
      low_indices_logical <- rownames(boot_mat_lower_level) %in% rownames(metric_lst[[j]]$`lower level`)
      boot_mat_lower_level[low_indices_logical, j] <- metric_lst[[j]]$`lower level`[, 1]

      high_indices_logical <- rownames(boot_mat_higher_level) %in% rownames(metric_lst[[j]]$`higher level`)
      boot_mat_higher_level[high_indices_logical, j] <- metric_lst[[j]]$`higher level`[, 1]
    }

    return(list(higher_level = boot_mat_higher_level,
                lower_level = boot_mat_lower_level))

    # In case of weighted indices:
  } else if (dim(metric_lst[[n]][[1]])[2] == 2) {
    boot_mat_lower_level <- boot_mat_lower_level_weighted <- matrix(nrow = length(sp_low), ncol = length(metric_lst))
    rownames(boot_mat_lower_level) <- rownames(boot_mat_lower_level_weighted) <- sp_low

    boot_mat_higher_level <- boot_mat_higher_level_weighted <- matrix(nrow = length(sp_high), ncol = length(metric_lst))
    rownames(boot_mat_higher_level) <-  rownames(boot_mat_higher_level_weighted) <- sp_high

    for (j in 1:n){
      low_indices_logical <- rownames(boot_mat_lower_level) %in% rownames(metric_lst[[j]]$`lower level`)
      boot_mat_lower_level[low_indices_logical, j] <- metric_lst[[j]]$`lower level`[, 1]
      boot_mat_lower_level_weighted[low_indices_logical, j] <- metric_lst[[j]]$`lower level`[, 2]

      high_indices_logical <- rownames(boot_mat_higher_level) %in% rownames(metric_lst[[j]]$`higher level`)
      boot_mat_higher_level[high_indices_logical, j] <- metric_lst[[j]]$`higher level`[, 1]
      boot_mat_higher_level_weighted[high_indices_logical, j] <- metric_lst[[j]]$`higher level`[, 2]
    }

    return(list(higher_level = boot_mat_higher_level,
                higher_level_weighted = boot_mat_higher_level_weighted,
                lower_level = boot_mat_lower_level,
                lower_level_weighted = boot_mat_lower_level_weighted))
  }
}

#' @title
#'  Helper function used in `boot_specieslevel_n()`. Gathers results in an array
#'  of matrices.
#'
#' @description
#'  Simplifies the results from the parallel processing into a list of arrays.
#'
#' @param boot_lst
#'  A list of matrices. Is the output of the `foreach` loop from
#'  `boot_specieslevel_n`.
#'
#' @param metric_names
#'  The name(s) of the network metric. There can be multiple names, depending on
#'  the `index` and `level` values.
#'
#' @param n
#'  Number of metric names.
#'
#' @param iter_spl_size
#'  Sample size at each iteration/bootstrap step.
#'
#' @return
#'  A list of arrays of matrices.
#'
#' @noRd
get_list_of_arrays <- function(boot_lst, metric_names, n, iter_spl_size){
  array_lst <- vector(mode = "list", length = n)
  for (i in 1:n) {
    array_lst[[i]] <- boot_lst %>%
      lapply("[[", metric_names[i]) %>%
      simplify2array
    colnames(array_lst[[i]]) <- iter_spl_size
  }
  names(array_lst) <- metric_names
  return(array_lst)
}

#' @title
#'  Helper function used in `boot_networklevel_n()`. Gathers results in a list
#'  of matrices.
#'
#' @description
#'  Simplifies the results from the parallel processing into a list of matrices.
#'
#' @param boot_lst
#'  A list of matrices. Is the output of the `foreach` loop from
#'  `boot_networklevel_n`.
#'
#' @param metric_names
#'  The name(s) of the network metric. There can be multiple names, depending on
#'  the `index` and `level` values.
#'
#' @param n
#'  Number of metric names.
#'
#' @param iter_spl_size
#'  Sample size at each iteration/bootstrap step.
#'
#' @return
#'  A list of matrices.
#'
#' @noRd
get_list_of_matrices <- function(boot_lst, metric_names, n, iter_spl_size){
  mat_lst <- vector(mode = "list", length = n)
  for (i in 1:n) {
    mat_lst[[i]] <- boot_lst %>%
      lapply("[[", metric_names[i]) %>%
      do.call(what = "cbind")
    rownames(mat_lst[[i]]) <- iter_spl_size
  }
  names(mat_lst) <- metric_names
  return(mat_lst)
}

#' @title
#'  Helper used in `gg_specieslevel_web_by_web` and
#'  `gg_specieslevel_compare_webs`
#'
#' @description
#'  Filters `stats_df` and `lines_df` by the proper lower and higher level
#'  species names.
#'
#' @noRd
filter_species <- function(lst, sp_lower, sp_higher, name_metric, name_plot) {

  is_lower <- grepl(pattern = "lower", x = name_metric)
  is_higher <- grepl(pattern = "higher", x = name_metric)

  if (is_lower & is.null(sp_lower)) {
    warning("`sp_lower` not provided, all lower level species will be used!")
    sp_filter <- lst[["stats_df"]][["sp"]] %>% unique()
    stats_df <- lst[["stats_df"]] %>% dplyr::filter(sp %in% sp_filter)
    lines_df <- lst[["lines_df"]] %>% dplyr::filter(sp %in% sp_filter)

  } else if (is_lower & !is.null(sp_lower)) {
    sps <- lst[["stats_df"]][["sp"]] %>% unique()
    sp_test <- ! sp_lower %in% sps
    if (any(sp_test))
      warning("At case ", name_plot, ", ",
              "these species are not in the lower level species of the network:\n",
              paste(sp_lower[sp_test], collapse = "\n"))
    stats_df <- lst[["stats_df"]] %>% dplyr::filter(sp %in% sp_lower)
    lines_df <- lst[["lines_df"]] %>% dplyr::filter(sp %in% sp_lower)

  } else if (is_higher & is.null(sp_higher)) {
    warning("`sp_higher` not provided, all higher level species will be used!")
    sp_filter <- lst[["stats_df"]][["sp"]] %>% unique()
    stats_df <- lst[["stats_df"]] %>% dplyr::filter(sp %in% sp_filter)
    lines_df <- lst[["lines_df"]] %>% dplyr::filter(sp %in% sp_filter)

  } else if (is_higher & !is.null(sp_higher)) {
    sps <- lst[["stats_df"]][["sp"]] %>% unique()
    sp_test <- ! sp_higher %in% sps
    if (any(sp_test))
      warning("At case ", name_plot, ", ",
              "these species are not in the higher level species of the network:\n",
              paste(sp_higher[sp_test], collapse = "\n"))
    stats_df <- lst[["stats_df"]] %>% dplyr::filter(sp %in% sp_higher)
    lines_df <- lst[["lines_df"]] %>% dplyr::filter(sp %in% sp_higher)
  }

  return(list(stats_df = stats_df,
              lines_df = lines_df))
}

#' @title
#'  Helper used in `gg_specieslevel_compare_webs`.
#'
#' @description
#'  Checks if the values for `sp_lower` and `sp_higher` parameters are ok and
#'  throws errors otherwise.
#'
#' @noRd
test_species_filter_compare_webs <- function(metric_names, sp_lower, sp_higher){
  if (is.null(sp_lower) & is.null(sp_higher))
    stop("Please provide a species name to compare in `sp_lower` and/or `sp_higher`")

  if (!is.null(sp_lower) & length(sp_lower) != 1)
    stop("Please provide a single common species name in `sp_lower` to compare across the networks")

  if (!is.null(sp_higher) & length(sp_higher) != 1)
    stop("Please provide a single common species name in `sp_higher` to compare across the networks")

  has_lower <- grepl(pattern = "lower", x = metric_names) %>% any()
  has_higher <- grepl(pattern = "higher", x = metric_names) %>% any()

  if (has_lower & is.null(sp_lower))
    stop("Please provide a lower species name in `sp_lower`")

  if (has_higher & is.null(sp_higher))
    stop("Please provide a higher species name in `sp_higher`")
}

#' @title
#'  Helper used in `boot_networklevel_n()` and `boot_specieslevel_n()`.
#'
#' @description
#'  Checks if the row and column values of `data` are ok and throws errors
#'  otherwise.
#'
#' @noRd
test_data_species_names <- function(data, col_lower, col_higher) {
  if (any(c("", "NA", "na", NA) %in% unique(data[[col_lower]])))
    stop("You have undefined/empty species names. Check the lower level species names for NA-s or empty strings.")

  if (any(c("", "NA", "na", NA) %in% unique(data[[col_higher]])))
    stop("You have undefined/empty species names. Check the higher level species names for NA-s or empty strings.")
}

#' @title
#'  Helper used in `boot_networklevel_n()` and `boot_specieslevel_n()`.
#'
#' @description
#'  Checks if:
#'  - the `data` argument is a non-empty `data.frame` or `data.table` class,
#'  - data should have at least 3 columns (e.g.: plants, insects, counts),
#'  - the columns names should match the user input for `col_lower` and `col_higher`,
#'  - each interaction (row) was repeated as many times as it was observed
#'
#' @noRd
test_data <- function(data, col_lower, col_higher) {
  if ( ! inherits(data, what = c("data.frame", "data.table")) )
    strwrap('`data` must be a data.frame or data.table.
             Maybe check out the function web_matrix_to_df() for examples.',
            prefix = " ", initial = "") %>% stop()

  if ( dim(data)[1] == 0 )
    strwrap('Your `data` has no rows.
             Maybe check out the function web_matrix_to_df() for examples.',
            prefix = " ", initial = "") %>% stop()

  if ( dim(data)[2] < 3 )
    strwrap('`data` must have at least 3 columns, e.g: plants, insects, counts.
             Maybe check out the function web_matrix_to_df() for examples.',
            prefix = " ", initial = "") %>% stop()

  if ( ! col_lower %in% colnames(data) )
    paste0('Cannot find the column name provided in `col_lower` as a column of `data`.
            Maybe a typo? You gave: <', col_lower, '>, but columns in data are: ',
           paste(colnames(data), collapse = ", ")) %>%
    strwrap(prefix = " ", initial = "") %>% stop()

  if ( ! col_higher %in% colnames(data) )
    paste0('Cannot find the column name provided in `col_higher` as a column of `data`.
            Maybe a typo? You gave: <', col_higher, '>, but columns in data are: ',
           paste(colnames(data), collapse = ", ")) %>%
    strwrap(prefix = " ", initial = "") %>% stop()

  if ( nrow(data) == unique(data) %>% nrow() )
    strwrap('Each interaction (row) should be repeated as many times as it was observed.
             If you indeed observed each interaction just once, then carry on.
             Maybe check out the function web_matrix_to_df() for examples.',
            prefix = " ", initial = "") %>% warning()
}

#' @title
#'  Helper used in `boot_networklevel_n()` and `boot_specieslevel_n()`.
#'
#' @description
#'  Checks if the user gave correct values for `level`.
#'
#' @noRd
test_level_value <- function(level) {
  if (length(level) != 1)
    stop('Provide a single value for `level`: "both", "lower" or "higher"')

  if (! level %in% c("both", "lower", "higher"))
    stop('The value provided for `level` must be one of the following: "both", "lower" or "higher"')
}

#' @title
#'  Helper used in `boot_networklevel_n()`.
#'
#' @description
#'  Checks if the user gave correct values for `index`.
#'
#' @noRd
test_index_networklevel <- function(index) {
  if (length(index) != 1) stop('Provide a single value for `index`')

  # As given in https://github.com/biometry/bipartite/blob/master/bipartite/R/networklevel.R at 2019-11-07
  allindex <- c(
    # descriptive:
    "number of species",
    "connectance",
    "web asymmetry",
    # binary based and related:
    "links per species",
    "number of compartments",
    "compartment diversity",
    "cluster coefficient",
    "degree distribution",
    "mean number of shared partners",
    "togetherness",
    "C score",
    "V ratio",
    "discrepancy",
    "nestedness",
    "NODF",
    "weighted nestedness",
    # miscelleneous:
    "ISA",
    "SA",
    "extinction slope",
    "robustness",
    "niche overlap",
    # quantitative series:
    "weighted cluster coefficient",
    "weighted NODF",
    "partner diversity",
    "generality",
    "vulnerability",
    "linkage density",
    "weighted connectance",
    "Fisher alpha",
    "interaction evenness",
    "Alatalo interaction evenness",
    "Shannon diversity",
    "functional complementarity",
    "H2"
  )

  if (! index %in% allindex)
    stop('Your index is not recognised. Typo? Did you mean one of these?:\n',
         agrep(pattern = index,
               x = allindex,
               ignore.case = TRUE,
               value = TRUE,
               fixed = FALSE) %>%
           paste(collapse = "\n"))
}

#' @title
#'  Helper used in `boot_specieslevel_n()`.
#'
#' @description
#'  Checks if the user gave correct values for `index`.
#'
#' @noRd
test_index_specieslevel <- function(index) {
  if (length(index) != 1) stop('Provide a single value for `index`')

  # As given in https://github.com/biometry/bipartite/blob/master/bipartite/R/specieslevel.R at 2019-11-07
  allindex <- c(
    "degree",
    "normalised degree",
    "species strength",
    "nestedrank",
    "interaction push pull",
    "PDI",
    "resource range",
    "species specificity",
    "PSI",
    "NSI",
    "betweenness",
    "closeness",
    "Fisher alpha",
    "partner diversity",
    "effective partners",
    "d",
    "dependence",
    "proportional generality",
    "proportional similarity"
  )

  if (! index %in% allindex)
    stop('Your index is not recognised. Typo? Did you mean one of these?:\n',
         agrep(pattern = index,
               x = allindex,
               ignore.case = TRUE,
               value = TRUE,
               fixed = FALSE) %>%
           paste(collapse = "\n"))
}


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

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

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

  OP<-read.FLOP.control(file=file.path(data.path,dirs[1],"op.dat"),n.VPA=11,n.other.pred=17,n.pred=21)
  n.years<-OP@last.year - OP@first.year.out +1

  b<-NULL; n<-1
  for (dir in dirs) {
     if (useCondensed) load(file=file.path(data.path,dir, "condensed.RData")) else {
       load(file=file.path(data.path,dir, altCondensed[n]),verbose=T)
       print(altCondensed[n])
       if ("condensed.RData"!=altCondensed[n]) {
          condensed<-subset(aa,select=c(value,yield,CWsum,Fcomb,Fbar,SSB,TSB,recruit,belowBlim,belowBpa,Species.n, run,iteration,COD,WHG,HAD,POK,HER,NSA,SSA,NOR,SPR,PLE,SOL))
          rm(aa)
       }
     }
     a<-data.frame(scen=labels[n],condensed)
     b<-rbind(b,a)
     n<-n+1
  }
  b$Species<-sp.names[b$Species.n]
 print(dim(b))
  a<-aggregate(cbind(Fbar,yield,CWsum,value,SSB)~scen+Species.n+Species,mean,data=b)
  asd<-aggregate(cbind(yield,value,SSB)~scen+Species.n+Species,sd,data=b)
  hh<-dimnames(asd)[[2]]
  hh<-sub('yield', 'yieldSD',hh)
  hh<-sub('value', 'valueSD',hh)
  hh<-sub('SSB', 'SSBSD',hh)
  dimnames(asd)[[2]]<-hh
  a2<-aggregate(list(Fbarmax=b$Fbar),list(scen=b$scen,Species.n=b$Species.n,Species=b$Species),max)

  b$belowBlim<-b$belowBlim*100/n.years
  b$belowBpa<-b$belowBpa*100/n.years
  risk<-aggregate(cbind(belowBlim,belowBpa)~scen+Species.n+Species,mean,data=b)

  aa<-merge(a,a2)
  aa<-merge(aa,asd)
  aa<-merge(aa,risk)

  aa<-subset(aa,Species !='Plaice' & Species !='Sole')

  label<-data.frame(scen=dirs,labels)
  #aa<-merge(aa,label)
  aa$labels<-aa$scen
  aa$Species<-paste(aa$Species.n-first.VPA+1,'. ',aa$Species,sep='')
  a<-tapply(aa$Fbarmax,list(aa$Species,aa$labels),sum)

  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_Fmax",'.html',sep='')),
             dec=rep(2,dim(a)[[2]]), width='"100%"',units='FMSY (max)')

  if (addFbar) {
    a2<-tapply(aa$Fbar,list(aa$Species,aa$labels),sum)

  xtab(a, caption='', cornername='  ',
       file=file.path(paste(out.file,"_Fbar",'.html',sep='')),
       dec=rep(2,dim(a2)[[2]]), width='"100%"',units='FMSY (bar)')
  }

  a<-tapply(aa$belowBlim ,list(aa$Species,aa$labels),mean)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_blim",'.html',sep='')),
             dec=rep(1,dim(a)[[2]]), width='"100%"',units=' ')

  a<-tapply(aa$belowBpa ,list(aa$Species,aa$labels),mean)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_bpa",'.html',sep='')),
             dec=rep(1,dim(a)[[2]]), width='"100%"',units=' ')

    a<-tapply(aa$yield ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$yield ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
   xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_yield",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

     a<-tapply(aa$CWsum-aa$yield ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$CWsum-aa$yield ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
   xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_discard",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

     a<-tapply(aa$yield ,list(aa$Species,aa$labels),sum)
     a2<-tapply(aa$yieldSD ,list(aa$Species,aa$labels),sum)
     a<-a2/a*100
     xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_yield_CV",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

     a<-tapply(aa$value ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$value ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_value",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

      a<-tapply(aa$SSB ,list(aa$Species,aa$labels),sum) /1000
      All<-tapply(aa$SSB ,list(aa$labels),sum) /1000
    a<-rbind(a,All)
  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_SSB",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

    a<-tapply(aa$SSB ,list(aa$Species,aa$labels),sum)
    a2<-tapply(aa$SSBSD ,list(aa$Species,aa$labels),sum)
    a<-a2/a*100

  xtab(a, caption='', cornername='  ',
             file=file.path(paste(out.file,"_SSB_CV",'.html',sep='')),
             dec=rep(0,dim(a)[[2]]), width='"100%"',units=' ')

if (tableIndicators) {

  b<-NULL; n<-1
  for (dir in dirs) {
    if (useCondensed) load(file=file.path(data.path,dir, "indicators.RData")) else {
      load(file=file.path(data.path,dir, altIndi[n]),verbose=T)
      if ("indicators.RData"!=altIndi[n]) {
        indi<-indiNew
        rm(indiNew)
      }
    }
    a<-data.frame(scen=labels[n],indi)
    b<-rbind(b,a)
    n<-n+1
  }
  b$labels<-b$scen

  a<-aggregate(cbind(bio.demer,bio.small,bio.pelag,bio.forage,comm.Fland,comm.Fall,comm.M,comm.M2,comm.life.expec ,LFI) ~ labels,data=b,mean)

  b<-cbind(a$comm.M2*100,a$comm.Fall*100,a$LFI*100,a$comm.life.expec ,a$bio.forage/1000,a$bio.pelag/a$bio.demer)
  b<-t(b)

  dimnames(b)[[1]]<-c("Community M2 (%)","Community F (%)","LFI (%)","life expectancy (years)","Biomass forage (kt)","Biomass ratio pelagic:demersal")
  dimnames(b)[[2]]<-as.vector(a$labels)

   xtab3(b, caption='', cornername='  ',
             file=file.path(paste(out.file,"_sys_Indicators",'.html',sep='')),
             dec=c(0,0,0,2,0,2), width='"100%"',units=' ')
 }
}

if (TRUE) {    # from simulation
  useCondensed<-FALSE
  altCondensed<-c("option1.RData","option2.RData","option3.RData","option3.RData","option4.RData")
  altIndi<-c('indi1.RData','indi2.RData','indi3.RData','indi3.RData','indi4.RData')
  opt.table(out.file='option1_4_compare',first.y=2043,last.y=2043,stochastic=F, test=F,addFbar=T,tableIndicators=T,useCondensed=useCondensed,altCondensed=altCondensed,altIndi=altIndi,
            dirs=c( "HCR_1_deter_had_adjust_wide_01_HCR1_0_Rec0_Recadj_2043",
                    "HCR_1_deter_had_adjust_wide_01_HCR1_0_Rec0_Recadj_2043",
                    "HCR_1_deter_had_adjust_wide_01_HCR1_0_Rec0_Recadj_2043",
                    "HCR_1_deter_had_adjust_narrow_01_HCR1_0_Rec0_Recadj_2043",
                    "HCR_1_deter_had_adjust_narrow_01_HCR1_0_Rec0_Recadj_2043"),
            labels=c("1. SSB above Blim",
                     "2. 95% MSY with SSB above Blim",
                     "3. 95% MSY with SSB above Bpa",
                     "4. 95% MSY with SSB above Bpa, small step",
                     "5. MSY with SSB above Bpa, small step" ))
}

#

if (F) {    # from simulation
   opt.table(out.file='det_compare_HCR12_stock',first.y=2022,last.y=2211,stochastic=T, test=F,addFbar=T,tableIndicators=T,
   dirs=c("HCR_1_deter_adjust_point_01_HCR1_0_Rec0_Recadj_2051",
          "HCR_1_deter_adjust_proposed_range_03_HCR1_0_Rec0_Recadj_2051",
          "HCR_1_deter_adjust_narrow_01_HCR1_0_Rec0_Recadj_2051", "HCR_1_deter_adjust_wide_01_HCR1_0_Rec0_Recadj_2051"),
   labels=c("1)FMSY point estimate","2) 95% MSY range", "3)narrow F range", "4) wide F range" ))
}
if (FALSE) {
  dirs<-c(
    "S1a_HCR_1_1_Rec3__atAgeW____limF_110",
    "S1b_HCR_1_1_Rec3_penBlim_atAgeW____limF_110",
    "S1c_HCR_1_1_Rec3_penBpa_atAgeW____limF_110",
    "S1d_HCR_1_1_Rec3______limF_110",
    "S1e_HCR_1_1_Rec3_penBlim_____limF_110")

  opt.table(out.file='det_compare_HCR12_stock',first.y=2022,last.y=2204,stochastic=T, test=F,addFbar=T,tableIndicators=T,
            dirs=dirs,
            labels=dirs)
}


geemMod <- function(formula, id, waves=NULL, data = parent.frame(),
                 family = gaussian, corstr = "independence", Mv = 1,
                 weights = NULL, corr.mat = NULL, init.beta=NULL,
                 init.alpha=NULL, init.phi = 1, scale.fix = FALSE, nodummy = FALSE,
                 sandwich = TRUE, useP = TRUE, maxit = 20, tol = 0.00001, fullmat=FALSE){
  call <- match.call()

  famret <- getfam(family)

  if(inherits(famret, "family")){
    LinkFun <- famret$linkfun
    InvLink <- famret$linkinv
    VarFun <- famret$variance
    InvLinkDeriv <- famret$mu.eta
  }else{
    LinkFun <- famret$LinkFun
    VarFun <- famret$VarFun
    InvLink <- famret$InvLink
    InvLinkDeriv <- famret$InvLinkDeriv
  }

  if(scale.fix & is.null(init.phi)){
    stop("If scale.fix=TRUE, then init.phi must be supplied")
  }

  useP <- as.numeric(useP)

  ### First, get all the relevant elements from the arguments
  dat <- model.frame(formula, data, na.action=na.pass)
  nn <- dim(dat)[1]

  if(typeof(data) == "environment"){
    id <- id
    weights <- weights
    if(is.null(call$weights)) weights <- rep(1, nn)
    waves <- waves
  }
  else{
    if(length(call$id) == 1){
      subj.col <- which(colnames(data) == call$id)
      if(length(subj.col) > 0){
        id <- data[,subj.col]
      }else{
        id <- eval(call$id, envir=parent.frame())
      }
    }else if(is.null(call$id)){
      id <- 1:nn
    }

    if(length(call$weights) == 1){
      weights.col <- which(colnames(data) == call$weights)
      if(length(weights.col) > 0){
        weights <- data[,weights.col]
      }else{
        weights <- eval(call$weights, envir=parent.frame())
      }
    }else if(is.null(call$weights)){
      weights <- rep.int(1,nn)
    }

    if(length(call$waves) == 1){
      waves.col <- which(colnames(data) == call$waves)
      if(length(waves.col) > 0){
        waves <- data[,waves.col]
      }else{
        waves <- eval(call$waves, envir=parent.frame())
      }
    }else if(is.null(call$waves)){
      waves <- NULL
    }
  }
  dat$id <- id
  dat$weights <- weights
  dat$waves <- waves

  if(!is.numeric(dat$waves) & !is.null(dat$waves)) stop("waves must be either an integer vector or NULL")

  # W is diagonal matrix of weights, sqrtW = sqrt(W)
  # included is diagonal matrix with 1 if weight > 0, 0 otherwise
  # includedvec is logical vector with T if weight > 0, F otherwise
  # Note that we need to assign weight 0 to rows with NAs
  # in order to preserve the correlation structure
  na.inds <- NULL

  if(any(is.na(dat))){
    na.inds <- which(is.na(dat), arr.ind=T)
  }

  #SORT THE DATA ACCORDING TO WAVES
  if(!is.null(waves)){
    dat <- dat[order(id, waves),]
  }else{
    dat <- dat[order(id),]
  }

  # Figure out the correlation structure
  cor.vec <- c("independence", "ar1", "exchangeable", "m-dependent", "unstructured", "fixed", "userdefined")
  cor.match <- charmatch(corstr, cor.vec)

  if(is.na(cor.match)){stop("Unsupported correlation structure")}

  if(!is.null(dat$waves)){
    wavespl <- split(dat$waves, dat$id)
    idspl <- split(dat$id, dat$id)

    maxwave <- rep(0, length(wavespl))
    incomp <- rep(0, length(wavespl))

    for(i in 1:length(wavespl)){
      maxwave[i] <- max(wavespl[[i]]) - min(wavespl[[i]]) + 1
      if(maxwave[i] != length(wavespl[[i]])){
        incomp[i] <- 1
      }
    }

    #If there are gaps and correlation isn't independent or exchangeable
    #then we'll add some dummy rows
    if( !is.element(cor.match,c(1,3)) & (sum(incomp) > 0) & !nodummy){
      dat <- dummyrows(formula, dat, incomp, maxwave, wavespl, idspl)
      id <- dat$id
      waves <- dat$waves
      weights <- dat$weights
    }
  }

  if(!is.null(na.inds)){
    weights[unique(na.inds[,1])] <- 0
    for(i in unique(na.inds)[,2]){
      if(is.factor(dat[,i])){
        dat[na.inds[,1], i] <- levels(dat[,i])[1]
      }else{
        dat[na.inds[,1], i] <- median(dat[,i], na.rm=T)
      }
    }
  }

  includedvec <- weights>0

  inclsplit <- split(includedvec, id)

  dropid <- NULL
  allobs <- T
  if(any(!includedvec)){
    allobs <- F
    for(i in 1:length(unique(id))){
      if(all(!inclsplit[[i]])){
        dropid <- c(dropid, unique(id)[i])
      }
    }
  }

  dropind <- c()

  if(is.element(cor.match, c(1,3))){
    dropind <- which(weights==0)
  }else if(length(dropid)>0){
    dropind <- which(is.element(id, dropid))
  }
  if(length(dropind) > 0){
    dat <- dat[-dropind,]
    includedvec <- includedvec[-dropind]
    weights <- weights[-dropind]

    id <- id[-dropind]
  }
  nn <- dim(dat)[1]
  K <- length(unique(id))

  modterms <- terms(formula)

  X <- model.matrix(formula,dat)
  Y <- model.response(dat)
  offset <- model.offset(dat)

  p <- dim(X)[2]

  ### if no offset is given, then set to zero
  if(is.null(offset)){
    off <- rep(0, nn)
  }else{
    off <- offset
  }

  # Is there an intercept column?
  interceptcol <- apply(X==1, 2, all)

  ## Basic check to see if link and variance functions make any kind of sense
  linkOfMean <- LinkFun(mean(Y[includedvec])) - mean(off)

  if( any(is.infinite(linkOfMean) | is.nan(linkOfMean)) ){
    stop("Infinite or NaN in the link of the mean of responses.  Make sure link function makes sense for these data.")
  }
  if( any(is.infinite( VarFun(mean(Y))) | is.nan( VarFun(mean(Y)))) ){
    stop("Infinite or NaN in the variance of the mean of responses.  Make sure variance function makes sense for these data.")
  }

  if(is.null(init.beta)){
    if(any(interceptcol)){
      #if there is an intercept and no initial beta, then use link of mean of response
      init.beta <- rep(0, dim(X)[2])
      init.beta[which(interceptcol)] <- linkOfMean
    }else{
      stop("Must supply an initial beta if not using an intercept.")
    }
  }

  # Number of included observations for each cluster
  includedlen <- rep(0, K)
  len <- rep(0,K)
  uniqueid <- unique(id)

  tmpwgt <- as.numeric(includedvec)
  idspl <-ifelse(tmpwgt==0, NA, id)
  includedlen <- as.numeric(summary(split(Y, idspl, drop=T))[,1])
  len <- as.numeric(summary(split(Y, id, drop=T))[,1])

  W <- Diagonal(x=weights)
  sqrtW <- sqrt(W)
  included <- Diagonal(x=(as.numeric(weights>0)))

  # Get vector of cluster sizes... remember this len variable
  #len <- as.numeric(summary(split(Y, id, drop=T))[,1])

  # Set the initial alpha value
  if(is.null(init.alpha)){
    alpha.new <- 0.2
    if(cor.match==4){
      # If corstr = "m-dep"
      alpha.new <- 0.2^(1:Mv)
    }else if(cor.match==5){
      # If corstr = "unstructured"
      alpha.new <- rep(0.2, sum(1:(max(len)-1)))
    }else if(cor.match==7){
      # If corstr = "userdefined"
      alpha.new <- rep(0.2, max(unique(as.vector(corr.mat))))
    }
  }else{
    alpha.new <- init.alpha
  }
  #if no initial overdispersion parameter, start at 1
  if(is.null(init.phi)){
    phi <- 1
  }else{
    phi <- init.phi
  }

  beta <- init.beta

  #Set up matrix storage
  StdErr <- Diagonal(nn)
  dInvLinkdEta <- Diagonal(nn)
  Resid <- Diagonal(nn)
  #  if( (max(len)==1) & cor.match != 1 ){
  #    warning("Largest cluster size is 1. Changing working correlation to independence.")
  #    cor.match <- 1
  #    corstr <- "independence"
  #  }

  if(fullmat == FALSE){

    # Initialize for each correlation structure
    if(cor.match == 1){
      # INDEPENDENCE
      R.alpha.inv <- Diagonal(x = rep.int(1, nn))/phi
      BlockDiag <- getBlockDiag(len)$BDiag
    }else if(cor.match == 2){
      # AR-1
      tmp <- buildAlphaInvAR(len)
      # These are the vectors needed to update the inverse correlation
      a1<- tmp$a1
      a2 <- tmp$a2
      a3 <- tmp$a3
      a4 <- tmp$a4
      # row.vec and col.vec for the big block diagonal of correlation inverses
      # both are vectors of indices that facilitate in updating R.alpha.inv
      row.vec <- tmp$row.vec
      col.vec <- tmp$col.vec
      BlockDiag <- getBlockDiag(len)$BDiag

    }else if(cor.match == 3){
      # EXCHANGEABLE
      # Build a block diagonal correlation matrix for updating and sandwich calculation
      # this matrix is block diagonal with all ones.  Each block is of dimension cluster size.
      tmp <- getBlockDiag(len)
      BlockDiag <- tmp$BDiag

      #Create a vector of length number of observations with associated cluster size for each observation
      n.vec <- vector("numeric", nn)
      index <- c(cumsum(len) - len, nn)
      for(i in 1:K){
        n.vec[(index[i]+1) : index[i+1]] <-  rep(includedlen[i], len[i])
      }

      # n.vec <- vector("numeric", nn)
      # index <- c(cumsum(len) - len, nn)
      # for(i in 1:K){
      #  n.vec[(index[i]+1) : index[i+1]] <-  rep(len[i], len[i])
      # }
    }else if(cor.match == 4){
      # M-DEPENDENT, check that M is not too large
      if(Mv >= max(len)){
        stop("Cannot estimate that many parameters: Mv >=  max(clustersize)")
      }

      # Build block diagonal similar to in exchangeable case, also get row indices and column
      # indices for fast matrix updating later.
      tmp <- getBlockDiag(len)
      BlockDiag <- tmp$BDiag
      row.vec <- tmp$row.vec
      col.vec <- tmp$col.vec
      R.alpha.inv <- NULL
    }else if(cor.match == 5){
      # UNSTRUCTURED
      if( max(len^2 - len)/2 > length(len)){
        stop("Cannot estimate that many parameters: not enough subjects for unstructured correlation")
      }
      tmp <- getBlockDiag(len)
      BlockDiag <- tmp$BDiag
      row.vec <- tmp$row.vec
      col.vec <- tmp$col.vec
    }else if(cor.match == 6){
      # FIXED
      # check if matrix meets some basic conditions
      corr.mat <- checkFixedMat(corr.mat, len)

      R.alpha.inv <- as(getAlphaInvFixed(corr.mat, len), "symmetricMatrix")/phi
      BlockDiag <- getBlockDiag(len)$BDiag
    }else if(cor.match == 7){
      # USERDEFINED
      corr.mat <- checkUserMat(corr.mat, len)

      # get the structure of the correlation matrix in a way that
      # I can use later on.
      tmp1 <- getUserStructure(corr.mat)
      corr.list <- tmp1$corr.list
      user.row <- tmp1$row.vec
      user.col <- tmp1$col.vec
      struct.vec <- tmp1$struct.vec

      # the same block diagonal trick.
      tmp2 <- getBlockDiag(len)
      BlockDiag <- tmp2$BDiag
      row.vec <- tmp2$row.vec
      col.vec <- tmp2$col.vec

    }else if(cor.match == 0){
      stop("Ambiguous Correlation Structure Specification")
    }else{
      stop("Unsupported Correlation Structure")
    }
  }else{
    R.alpha.inv <- corr.mat
    BlockDiag <- getBlockDiag(len)$BDiag
  }

  stop <- F
  converged <- F
  count <- 0
  beta.old <- beta
  unstable <- F
  phi.old <- phi

  # Main fisher scoring loop
  while(!stop){
    count <- count+1

    eta <- as.vector(X %*% beta) + off

    mu <- InvLink(eta)

    diag(StdErr) <- sqrt(1/VarFun(mu))

    if(!scale.fix){
      phi <- updatePhi(Y, mu, VarFun, p, StdErr, included, includedlen, sqrtW, useP)
    }
    phi.new <- phi

    ## Calculate alpha, R(alpha)^(-1) / phi
    if(cor.match == 2){
      # AR-1
      alpha.new <- updateAlphaAR(Y, mu, VarFun, phi, id, len,
                                 StdErr, p, included, includedlen,
                                 includedvec, allobs, sqrtW,
                                 BlockDiag, useP)
      R.alpha.inv <- getAlphaInvAR(alpha.new, a1,a2,a3,a4, row.vec, col.vec)/phi
    }else if(cor.match == 3){
      #EXCHANGEABLE
      alpha.new <- updateAlphaEX(Y, mu, VarFun, phi, id, len, StdErr,
                                 Resid, p, BlockDiag, included,
                                 includedlen, sqrtW, useP)
      #R.alpha.inv <- getAlphaInvEX(alpha.new, n.vec, BlockDiag)/phi
      R.alpha.inv <- getAlphaInvEX(alpha.new, n.vec, BlockDiag)/phi
    }else if(cor.match == 4){
      # M-DEPENDENT
      if(Mv==1){
        alpha.new <- updateAlphaAR(Y, mu, VarFun, phi, id, len,
                                   StdErr, p, included, includedlen,
                                   includedvec, allobs,
                                   sqrtW, BlockDiag, useP)
      }else{
        alpha.new <- updateAlphaMDEP(Y, mu, VarFun, phi, id, len,
                                     StdErr, Resid, p, BlockDiag, Mv,
                                     included, includedlen,
                                     allobs, sqrtW, useP)
        if(sum(len>Mv) <= p){
          unstable <- T
        }
      }
      if(any(alpha.new >= 1)){
        stop <- T
        warning("some estimated correlation is greater than 1, stopping.")
      }
      R.alpha.inv <- getAlphaInvMDEP(alpha.new, len, row.vec, col.vec)/phi
    }else if(cor.match == 5){
      # UNSTRUCTURED
      alpha.new <- updateAlphaUnstruc(Y, mu, VarFun, phi, id, len,
                                      StdErr, Resid,  p, BlockDiag,
                                      included, includedlen, allobs,
                                      sqrtW, useP)
      # This has happened to me (greater than 1 correlation estimate)
      if(any(alpha.new >= 1)){
        stop <- T
        warning("some estimated correlation is greater than 1, stopping.")
      }
      R.alpha.inv <- getAlphaInvUnstruc(alpha.new, len, row.vec, col.vec)/phi
    }else if(cor.match ==6){
      # FIXED CORRELATION, DON'T NEED TO RECOMPUTE
      R.alpha.inv <- R.alpha.inv*phi.old/phi
    }else if(cor.match == 7){
      # USER SPECIFIED
      alpha.new <- updateAlphaUser(Y, mu, phi, id, len, StdErr, Resid,
                                   p, BlockDiag, user.row, user.col,
                                   corr.list, included, includedlen,
                                   allobs, sqrtW, useP)
      R.alpha.inv <- getAlphaInvUser(alpha.new, len, struct.vec, user.row, user.col, row.vec, col.vec)/phi
    }else if(cor.match == 1){
      # INDEPENDENT
      R.alpha.inv <-  Diagonal(x = rep.int(1/phi, nn))
      alpha.new <- "independent"
    }

    beta.list <- updateBeta(Y, X, beta, off, InvLinkDeriv, InvLink, VarFun, R.alpha.inv, StdErr, dInvLinkdEta, tol, W, included)
    beta <- beta.list$beta

    phi.old <- phi
    if( max(abs((beta - beta.old)/(beta.old + .Machine$double.eps))) < tol ){converged <- T; stop <- T}
    if(count >= maxit){stop <- T}
    beta.old <- beta
  }
  biggest <- which.max(len)[1]
  index <- sum(len[1:biggest])-len[biggest]

  if(K == 1){
    biggest.R.alpha.inv <- R.alpha.inv
    if(cor.match == 6) {
      biggest.R.alpha <- corr.mat*phi
    }else{
      biggest.R.alpha <- solve(R.alpha.inv)
    }
  }else{
    biggest.R.alpha.inv <- R.alpha.inv[(index+1):(index+len[biggest]) , (index+1):(index+len[biggest])]
    if(cor.match == 6){
      biggest.R.alpha <- corr.mat[1:len[biggest] , 1:len[biggest]]*phi
    }else{
      biggest.R.alpha <- solve(biggest.R.alpha.inv)
    }
  }

  eta <- as.vector(X %*% beta) + off
  if(sandwich){
    sandvar.list <- getSandwich(Y, X, eta, id, R.alpha.inv, phi, InvLinkDeriv, InvLink, VarFun,
                                beta.list$hess, StdErr, dInvLinkdEta, BlockDiag, W, included)
  }else{
    sandvar.list <- list()
    sandvar.list$sandvar <- "no sandwich"
  }

  if(!converged){warning("Did not converge")}
  if(unstable){warning("Number of subjects with number of observations >= Mv is very small, some correlations are estimated with very low sample size.")}

  # Create object of class geem with information about the fit
  dat <- model.frame(formula, data, na.action=na.pass)
  X <- model.matrix(formula, dat)

  if(is.character(alpha.new)){alpha.new <- 0}
  results <- list()
  results$beta <- as.vector(beta)
  results$phi <- phi
  results$alpha <- alpha.new
  if(cor.match == 6){
    results$alpha <- as.vector(triu(corr.mat, 1)[which(triu(corr.mat,1)!=0)])
  }
  results$coefnames <- colnames(X)
  results$niter <- count
  results$converged <- converged
  results$naiv.var <- solve(beta.list$hess)  ## call model-based
  results$var <- sandvar.list$sandvar
  results$call <- call
  results$corr <- cor.vec[cor.match]
  results$clusz <- len
  results$FunList <- famret
  results$X <- X
  results$offset <- off
  results$eta <- eta
  results$dropped <- dropid
  results$weights <- weights
  results$terms <- modterms
  results$y <- Y
  results$biggest.R.alpha <- biggest.R.alpha/phi
  results$formula <- formula
  class(results) <- "geem"
  return(results)
}

### Simple moment estimator of dispersion parameter
updatePhi <- function(YY, mu, VarFun, p, StdErr, included, includedlen, sqrtW, useP){
  nn <- sum(includedlen)

  resid <- diag(StdErr %*% included %*% sqrtW %*% Diagonal(x = YY - mu))

  phi <- (1/(sum(included)- useP * p))*crossprod(resid, resid)

  return(as.numeric(phi))
}

### Method to update coefficients.  Goes to a maximum of 10 iterations, or when
### rough convergence has been obtained.
updateBeta = function(YY, XX, beta, off, InvLinkDeriv, InvLink,
                      VarFun, R.alpha.inv, StdErr, dInvLinkdEta, tol, W, included){
  beta.new <- beta
  conv=F
  for(i in 1:10){
    eta <- as.vector(XX%*%beta.new) + off

    diag(dInvLinkdEta) <- InvLinkDeriv(eta)
    mu <- InvLink(eta)
    diag(StdErr) <- sqrt(1/VarFun(mu))

    hess <- crossprod( StdErr %*% dInvLinkdEta %*%XX, R.alpha.inv %*% W %*% StdErr %*%dInvLinkdEta %*% XX)
    esteq <- crossprod( StdErr %*%dInvLinkdEta %*%XX , R.alpha.inv %*% W %*% StdErr %*% as.matrix(YY - mu))

    #hess <- crossprod( StdErr %*% dInvLinkdEta %*%XX, included %*% R.alpha.inv  %*% W %*% StdErr %*%dInvLinkdEta %*% XX)
    #esteq <- crossprod( StdErr %*%dInvLinkdEta %*%XX , included %*% R.alpha.inv %*% W %*% StdErr %*% as.matrix(YY - mu))

    update <- solve(hess, esteq)

    beta.new <- beta.new + as.vector(update)

  }
  return(list(beta = beta.new, hess = hess))
}

### Calculate the sandiwch estimator as usual.
getSandwich = function(YY, XX, eta, id, R.alpha.inv, phi, InvLinkDeriv,
                       InvLink, VarFun, hessMat, StdErr, dInvLinkdEta,
                       BlockDiag, W, included){

  diag(dInvLinkdEta) <- InvLinkDeriv(eta)
  mu <- InvLink(eta)
  diag(StdErr) <- sqrt(1/VarFun(mu))
  scoreDiag <- Diagonal(x= YY - mu)
  BlockDiag <- scoreDiag %*% BlockDiag %*% scoreDiag

  numsand <- as.matrix(crossprod(  StdErr %*% dInvLinkdEta %*% XX,  R.alpha.inv %*% W %*% StdErr %*% BlockDiag %*% StdErr %*% W %*% R.alpha.inv %*%  StdErr %*% dInvLinkdEta %*% XX))
  #numsand <- as.matrix(crossprod(  StdErr %*% dInvLinkdEta %*% XX, included %*% R.alpha.inv %*% W %*% StdErr %*% BlockDiag %*% StdErr %*% W %*% R.alpha.inv %*% included %*% StdErr %*% dInvLinkdEta %*% XX))

  sandvar <- t(solve(hessMat, numsand))
  sandvar <- t(solve(t(hessMat), sandvar))

  return(list(sandvar = sandvar, numsand = numsand))
}


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

# Perform binary logistic regression
#
# Performs binary logistic regression on the phenotype stored in thisdata
# and stores result in 'results-logistic-binary' results file.
binaryLogisticRegression <- function(varName, varType, thisdata, isExposure) {

        phenoFactor = factor(thisdata[,phenoStartIdx])

        facLevels = levels(phenoFactor)

	# assert variable has exactly two distinct values
	if (length(facLevels)!=2) {
		#stop(paste("Not 2 levels: ", length(facLevels), " || ", sep=""))
		cat("BINARY-NOT2LEVELS- (", length(facLevels), ") || ",sep="");
                incrementCounter("binary.nottwolevels")
	}

	idxTrue = length(which(phenoFactor==facLevels[1]))
	idxFalse = length(which(phenoFactor==facLevels[2]))
	numNotNA = length(which(!is.na(phenoFactor)))

        if (idxTrue<opt$mincase || idxFalse<opt$mincase) {
		cat("BINARY-LOGISTIC-SKIP-10 (", idxTrue, "/", idxFalse, ") || ", sep="")
		incrementCounter("binary.10")
	}
	else if (numNotNA<500) {
		cat("BINARY-LOGISTIC-SKIP-500 (", numNotNA, ") || ",sep="");
		incrementCounter("binary.500")
       	}
	else {

              	cat("sample ", idxTrue, "/", idxFalse, "(", numNotNA, ") || ", sep="");

		if (opt$save == TRUE) {
			# add pheno to dataframe
			storeNewVar(thisdata[,"userID"], phenoFactor, varName, 'bin')
			cat("SUCCESS results-logistic-binary ");
			incrementCounter("success.binary")
		}
		else {

		# use standardised geno values
		if (opt$standardise==TRUE) {
                	geno = scale(thisdata[,"geno"])
		}
		else {
			geno = thisdata[,"geno"]
		}
                confounders=thisdata[,3:numPreceedingCols, drop = FALSE]

		sink()
		sink(modelFitLogFile, append=TRUE)
		print("--------------")
		print(varName)

		###### BEGIN TRYCATCH
                tryCatch({

		mylogit <- glm(phenoFactor ~ geno + ., data=confounders, family="binomial")

		sink()
             	sink(resLogFile, append=TRUE)

                sumx = summary(mylogit)

                pvalue = sumx$coefficients['geno','Pr(>|z|)']
                beta = sumx$coefficients["geno","Estimate"]

		if (opt$confidenceintervals == TRUE) {
			cis = confint(mylogit, "geno", level=0.95)
	                lower = cis["2.5 %"]
	                upper = cis["97.5 %"]
		}
		else {
			lower = NA
			upper = NA
		}

                numNotNA = length(na.omit(phenoFactor))

                ## save result to file
                write(paste(paste0("\"", varName, "\""),varType,paste(idxTrue,"/",idxFalse,"(",numNotNA,")",sep=""), beta,lower,upper,pvalue, sep=","), file=paste(opt$resDir,"results-logistic-binary-",opt$varTypeArg,".txt",sep=""), append="TRUE");
                cat("SUCCESS results-logistic-binary ");

		incrementCounter("success.binary")

		if (isExposure==TRUE) {
	            	incrementCounter("success.exposure.binary")
	        }

		## END TRYCATCH
                }, error = function(e) {
                        sink()
                        sink(resLogFile, append=TRUE)
                        cat(paste("ERROR:", varName,gsub("[\r\n]", "", e), sep=" "))
                        incrementCounter("binary.error")
                })
		}
        }
}


## 14022020 CKR
#Figure 1C
library(ggplot2)
library(vegan)
library(ggsci)
library(tidyr)
library(reshape2)
library(dplyr)
library(ggpubr)
library(stringr)
library(matrixStats)

Canada=read.table("../Data/Suppl1_CA_Final.txt",sep="\t",head=T,row.names=1)#read in abundances
Canada=t(Canada)#transpose
label = read.table("../Data/TariniLabels_edit.txt",sep="\t",h=T) #read labels
label=filter(label,Country=="CA") %>% filter(str_detect(ID,"E90")|Status=="C") #filter for CA subjects, controls and post-treatment cases
Canada=select(data.frame(Canada),as.character(label$ID)) #filter for abundances of subject of interest

#calculate distance
dist=as.matrix(vegdist(t(Canada),method="bray"))
dist=data.frame(dist)
C=as.character(filter(label,Status=="C")$ID)
R=as.character(filter(label,Status=="R")$ID)
N=as.character(filter(label,Status=="NR")$ID)
distC=select(dist,C)

a=(as.matrix(distC[N,]))
distN=data.frame(t(as.matrix(distC[N,])))%>%summarise_all(median) #median of non-recoverer distance to controls
distR=data.frame(t(as.matrix(distC[R,])))%>%summarise_all(median) #median of recoverer distance to controls
distN=data.frame(gather(distN),label="N")
distR=data.frame(gather(distR),label="R")
Dist=data.frame(rbind(distR,distN))

#plot
Dist$label2<-factor(Dist$label,levels=levels(Dist$label)[c(2,1)]) #change order
ggplot(data=Dist, aes(x=label2,y=value,fill=label,grp=label)) +
  geom_boxplot(width=0.5)  +
  theme_classic() +
  scale_fill_manual(values=c("green","red")) +
  border()
wilcox.test(filter(Dist,label=="R")$value,filter(Dist,label=="N")$value,alternative="l")


library(RODBC)
library(mgcv)
setwd("Z:/Users/steve.barbeaux/My Documents/Private_Data/Stock_Assessments/Aleutian_Assessment_11/data")

AFSC=odbcConnect("AFSC","sbarb","sbarb$1011")

FAge=sqlQuery(AFSC,"SELECT NORPAC.FOREIGN_HAUL.YEAR,
  NORPAC.FOREIGN_HAUL.GENERIC_AREA,
  NORPAC.FOREIGN_AGE.SPECIES,
  NORPAC.FOREIGN_AGE.SEX,
  NORPAC.FOREIGN_AGE.LENGTH,
  NORPAC.FOREIGN_AGE.AGE,
  NORPAC.FOREIGN_AGE.INDIV_WEIGHT,
  NORPAC.FOREIGN_HAUL.LATITUDE,
  NORPAC.FOREIGN_HAUL.E_W,
  NORPAC.FOREIGN_HAUL.LONGITUDE
FROM NORPAC.FOREIGN_HAUL
INNER JOIN NORPAC.FOREIGN_AGE
ON NORPAC.FOREIGN_HAUL.HAUL_JOIN = NORPAC.FOREIGN_AGE.HAUL_JOIN
WHERE NORPAC.FOREIGN_HAUL.YEAR   > 1977
AND NORPAC.FOREIGN_HAUL.GENERIC_AREA BETWEEN 539 AND 544
AND NORPAC.FOREIGN_AGE.SPECIES = 201
ORDER BY NORPAC.FOREIGN_HAUL.YEAR")

FAge1<-subset(FAge,FAge$GENERIC_AREA==541&FAge$LATITUDE<5300)
FAge2<-subset(FAge,FAge$GENERIC_AREA==542&FAge$LATITUDE<5230)
FAge3<-subset(FAge,FAge$GENERIC_AREA==543&FAge$LATITUDE<5330)
FAge<-rbind(FAge1,FAge2,FAge3)
FAge<-FAge[order(FAge$YEAR,FAge$GENERIC_AREA),]
remove(FAge1,FAge2,FAge3)
FAge<-subset(FAge,select= -c(LATITUDE,LONGITUDE,E_W) )

FLength=sqlQuery(AFSC," SELECT NORPAC.FOREIGN_HAUL.YEAR,
  NORPAC.FOREIGN_HAUL.GENERIC_AREA,
  NORPAC.FOREIGN_LENGTH.SPECIES,
  NORPAC.FOREIGN_LENGTH.SEX,
  NORPAC.FOREIGN_LENGTH.SIZE_GROUP,
  NORPAC.FOREIGN_LENGTH.FREQUENCY,
  NORPAC.FOREIGN_HAUL.LATITUDE,
  NORPAC.FOREIGN_HAUL.E_W,
  NORPAC.FOREIGN_HAUL.LONGITUDE
FROM NORPAC.FOREIGN_HAUL
INNER JOIN NORPAC.FOREIGN_LENGTH
ON NORPAC.FOREIGN_HAUL.HAUL_JOIN = NORPAC.FOREIGN_LENGTH.HAUL_JOIN
WHERE NORPAC.FOREIGN_HAUL.YEAR   > 1977
AND NORPAC.FOREIGN_HAUL.GENERIC_AREA BETWEEN 539 AND 544
AND NORPAC.FOREIGN_LENGTH.SPECIES = 201
ORDER BY NORPAC.FOREIGN_HAUL.YEAR")

FLength1<-subset(FLength,FLength$GENERIC_AREA==541&FLength$LATITUDE<5300)
FLength2<-subset(FLength,FLength$GENERIC_AREA==542&FLength$LATITUDE<5230)
FLength3<-subset(FLength,FLength$GENERIC_AREA==543&FLength$LATITUDE<5330)
FLength<-rbind(FLength1,FLength2,FLength3)
FLength<-FLength[order(FLength$YEAR,FLength$GENERIC_AREA),]
remove(FLength1,FLength2,FLength3)
FLength<-subset(FLength,select= -c(LATITUDE,LONGITUDE,E_W) )

DAge=sqlQuery(AFSC,"SELECT OBSINT.DEBRIEFED_AGE.YEAR,
  OBSINT.DEBRIEFED_AGE.NMFS_AREA,
  OBSINT.DEBRIEFED_AGE.SPECIES,
  OBSINT.DEBRIEFED_AGE.SEX,
  OBSINT.DEBRIEFED_AGE.LENGTH,
  OBSINT.DEBRIEFED_AGE.AGE,
  OBSINT.DEBRIEFED_AGE.WEIGHT,
  OBSINT.DEBRIEFED_AGE.LATDD_END,
  OBSINT.DEBRIEFED_AGE.LONDD_END
FROM OBSINT.DEBRIEFED_AGE
WHERE OBSINT.DEBRIEFED_AGE.NMFS_AREA BETWEEN 539 AND 544
AND OBSINT.DEBRIEFED_AGE.SPECIES = 201
ORDER BY OBSINT.DEBRIEFED_AGE.YEAR" )

DAge1<-subset(DAge,DAge$NMFS_AREA==541&DAge$LATDD_END<53.00)
DAge2<-subset(DAge,DAge$NMFS_AREA==542&DAge$LATDD_END<52.50)
DAge3<-subset(DAge,DAge$NMFS_AREA==543&DAge$LATDD_END<53.50)
DAge<-rbind(DAge1,DAge2,DAge3)
DAge<-DAge[order(DAge$YEAR,DAge$NMFS_AREA),]
remove(DAge1,DAge2,DAge3)
DAge<-subset(DAge,select= -c(LATDD_END,LONDD_END) )

DLength=sqlQuery(AFSC,"SELECT OBSINT.DEBRIEFED_LENGTH.YEAR,
  OBSINT.DEBRIEFED_LENGTH.NMFS_AREA,
  OBSINT.DEBRIEFED_LENGTH.SPECIES,
  OBSINT.DEBRIEFED_LENGTH.SEX,
  OBSINT.DEBRIEFED_LENGTH.LENGTH,
  OBSINT.DEBRIEFED_LENGTH.FREQUENCY,
  OBSINT.DEBRIEFED_LENGTH.LATDD_END,
  OBSINT.DEBRIEFED_LENGTH.LONDD_END
FROM OBSINT.DEBRIEFED_LENGTH
WHERE OBSINT.DEBRIEFED_LENGTH.NMFS_AREA BETWEEN 539 AND 544
AND OBSINT.DEBRIEFED_LENGTH.SPECIES = 201
ORDER BY OBSINT.DEBRIEFED_LENGTH.YEAR")

DLength1<-subset(DLength,DLength$NMFS_AREA==541&DLength$LATDD_END<53.00)
DLength2<-subset(DLength,DLength$NMFS_AREA==542&DLength$LATDD_END<52.50)
DLength3<-subset(DLength,DLength$NMFS_AREA==543&DLength$LATDD_END<53.50)
DLength<-rbind(DLength1,DLength2,DLength3)
DLength<-DLength[order(DLength$YEAR,DLength$NMFS_AREA),]
remove(DLength1,DLength2,DLength3)
DLength<-subset(DLength,select= -c(LATDD_END,LONDD_END) )

AAge<-read.csv("Acoustic_survey_data.csv",header=T)
AAge$WEIGHT<-AAge$WEIGHT/1000
ALength<-aggregate(list(FREQ=AAge$LENGTH),by=list(YEAR=AAge$YEAR,NMFS_AREA=AAge$NMFS_AREA,SPECIES=AAge$SPECIES,SEX=AAge$SEX,LENGTH=AAge$LENGTH),FUN=length)
ALength<-ALength[order(ALength$YEAR,ALength$LENGTH),]

names(FLength)<-names(DLength)
names(FAge)<-names(DAge)
names(AAge)<-names(DAge)
names(ALength)<-names(DLength)

FAge<-rbind(FAge,DAge,AAge)
FLength<-rbind(FLength,DLength,ALength)
remove(DAge,DLength,ALength,AAge)

## Fishery AGE
FAge_w<-subset(FAge,!is.na(FAge$AGE))
FAge_w<-subset(FAge_w,!is.na(FAge_w$LENGTH))
FAge_w1<-subset(FAge_w,FAge_w$YEAR<1999&FAge_w$YEAR!=1988&FAge_w$YEAR!=1989&FAge_w$YEAR!=1990&FAge_w$YEAR!=1991&FAge_w$YEAR!=1992&FAge_w$YEAR!=1993&FAge_w$YEAR!=1997)
FAge_w2<-subset(FAge_w,FAge_w$YEAR>2005&FAge_w$YEAR<2009)
FAge_w<-rbind(FAge_w1,FAge_w2)

FLength_w1<-subset(FLength,FLength$YEAR<1999&FLength$YEAR!=1988&FLength$YEAR!=1989&FLength$YEAR!=1990&FLength$YEAR!=1991&FLength$YEAR!=1992&FLength$YEAR!=1993&FLength$YEAR!=1997)
FLength_w2<-subset(FLength,FLength$YEAR>2005&FLength$YEAR<2009)
FLength_w<-rbind(FLength_w1,FLength_w2)

FAge_w$SEX1<-FAge_w$SEX
FAge_w$SEX<-as.character(FAge_w$SEX)
FAge_w$SEX[FAge_w$SEX1=="M"]=1
FAge_w$SEX[FAge_w$SEX1=='F']=2
FAge_w$SEX[FAge_w$SEX1=='U']=3
FAge_w$LENGTH<-FAge_w$LENGTH*10
FAge_w$WEIGHT<-FAge_w$WEIGHT*1000

FLength_w$SEX1<-FLength_w$SEX
FLength_w$SEX<-as.character(FLength_w$SEX)
FLength_w$SEX[FLength_w$SEX1=='M']=1
FLength_w$SEX[FLength_w$SEX1=='F']=2
FLength_w$SEX[FLength_w$SEX1=='U']=3

FLength_w$LENGTH<-FLength_w$LENGTH*10

source("find_AL.r")
years<-sort(unique(FAge_w$YEAR))
z<-data.frame(matrix(ncol=4,nrow=1))
names(z)<-c("YEAR","SEX","AGE","LENGTH" )
for( i in 1:length(years)){
 x=find_AL(FAge_w,FLength_w,years[i])
 y1=data.frame(YEAR=years[i],SEX=1,AGE=x$len1$age,LENGTH=x$len1$tl)
 y2=data.frame(YEAR=years[i],SEX=2,AGE=x$len1$age,LENGTH=x$len1$tl)
 z=rbind(z,y1,y2)
 }
 F_length_age<-subset(z,is.na(z$YEAR)==F)

F_Total_AGE<-aggregate(list(FREQ=F_length_age$AGE),by=list(SEX=F_length_age$SEX,AGE=F_length_age$AGE,YEAR=F_length_age$YEAR),FUN=length)

 GRID<-expand.grid(SEX=c(1,2),YEAR=years,AGE=c(1:15))
 F_Total_AGE<-merge(GRID,F_Total_AGE, all=T)
 F_Total_AGE$FREQ[is.na(F_Total_AGE$FREQ)]=0
 Total<-aggregate(list(Total=F_length_age$AGE),by=list(YEAR=F_length_age$YEAR),FUN=length)
 F_Total_AGE<-merge(Total,F_Total_AGE, all=T)
 F_Total_AGE$PROB<-F_Total_AGE$FREQ/F_Total_AGE$Total
 F_Total_AGE<-subset(F_Total_AGE,select=-c(Total))
 F_Total_AGE<-F_Total_AGE[order(F_Total_AGE$YEAR,F_Total_AGE$SEX,F_Total_AGE$AGE),]

 F_Total_LENGTH<-aggregate(list(FREQ=F_length_age$AGE),by=list(SEX=F_length_age$SEX,LENGTH=F_length_age$LENGTH,YEAR=F_length_age$YEAR),FUN=length)

 GRID<-expand.grid(YEAR=years,LENGTH=seq(min(FLength_w$LENGTH),max(FLength_w$LENGTH),10))
 F_Total_LENGTH<-merge(GRID,F_Total_LENGTH, all=T)
 F_Total_LENGTH$FREQ[is.na(F_Total_LENGTH$FREQ)]=0
 Total<-aggregate(list(Total=F_length_age$AGE),by=list(YEAR=F_length_age$YEAR),FUN=length)
 F_Total_LENGTH<-merge(Total,F_Total_LENGTH, all=T)
 F_Total_LENGTH$PROB<-F_Total_LENGTH$FREQ/F_Total_LENGTH$Total
 F_Total_LENGTH<-subset(F_Total_LENGTH,select=-c(Total))
 F_Total_LENGTH<-F_Total_LENGTH[order(F_Total_LENGTH$YEAR,F_Total_LENGTH$SEX,F_Total_LENGTH$LENGTH),]
 remove(Total,GRID)

 ## Fishery WEIGHT at Age data
source("SWEIGHT.r")
F_WEIGHT<-SWEIGHT(data=FAge_w,Total_A=F_Total_AGE,fyear=2011)
F_Total_AGE<-merge(F_Total_AGE,F_WEIGHT[[1]])
F_Total_AGE<-F_Total_AGE[order(F_Total_AGE$YEAR,F_Total_AGE$SEX,F_Total_AGE$AGE),]

## Fishery Catch Data
source("get_catch.r")
CATCH<-GET_CATCH()

F_Total_WB<-merge(F_Total_AGE,CATCH[[1]],all.x=T)
F_Total_WB<-F_Total_WB[order(F_Total_WB$YEAR,F_Total_WB$AGE),]

F_Total_WB$N_AGE<-F_Total_WB$PROB*F_Total_WB$TONS/F_Total_WB$WEIGHT2*1000000
F_Total_WB$W_AGE<-F_Total_WB$PROB*F_Total_WB$TONS

F_total<-aggregate(list(FREQ=F_Total_AGE$FREQ),by=list(YEAR=F_Total_AGE$YEAR,AGE=F_Total_AGE$AGE),FUN=sum)
F_number<-aggregate(list(NUMBER=F_Total_AGE$FREQ),by=list(YEAR=F_Total_AGE$YEAR),FUN=sum)
F_total<-merge(F_total,F_number)
F_total$PROB<-F_total$FREQ/F_total$NUMBER
F_total<-F_total[order(F_total$YEAR,F_total$AGE),]

F_NAGE<-data.frame(matrix(ncol=15,nrow=length(years)))
  names(F_NAGE)<-c("YEAR","A2","A3" ,"A4","A5","A6","A7","A8","A9","A10","A11","A12","A13","A14","A15")
  F_NAGE$YEAR<-years

 for( i in 1:length(F_NAGE$YEAR)){
  F_NAGE[i,2:15]<-F_total$PROB[F_total$YEAR==F_NAGE$YEAR[i]][1:14]
  }

Catch_CV<-rep(0.05,length(unique(CATCH[[1]]$YEARS)))

##Total_FWB$C_LENGTH<-Total_WB$Prob*Total_FWB$TONS

CATCH[[1]]$TONS         ## CATCH BIOMASS
F_NAGE                  ## fishery numbers at age
F_WEIGHT$S_AGE_WEIGHT   ## fishery WEIGTH at age

a<-noquote("# General Parameters")
write.table(a,"test.dat",row.names=F,col.names=F)