context('Test genotype functions')

test_that('getAlleleFrequencies returns a vector of allele frequencies equal to
          the simulated frequencies', {
              snp <- rbinom(1000, 2, 0.3)
              allelefreq <- getAlleleFrequencies(snp)
              expect_equal(allelefreq[2], 0.3, tolerance = 0.1, scale = 0.3)
          })

test_that('getAlleleFrequencies fails with encoding error', {
    snp <- rep(c(1,2,3), 4)
    expect_error(getAlleleFrequencies(snp),
                 "SNP vector contains alleles not encoded as 0, 1 or 2"
    )
})

test_that('getAlleleFrequencies fails with dimension error', {
    snp <- matrix(rep(c(1,2,3), 4), nrow=2)
    expect_error(getAlleleFrequencies(snp),
                 paste("getAllelelFrequencies .*", sep=""))
})

test_that('standardiseGenotypes returns output matrix/dataframe of same
          dimension as input matrix/dataframe', {
              geno <- cbind(rbinom(100, 2, 0.3), rbinom(100, 2, 0.4))
              geno_sd <- standardiseGenotypes(geno)
              expect_equal(dim(geno), dim(geno_sd))
          })

test_that('standardiseGenotypes returns genotypes with mean 0 and sd 1', {
    geno <- cbind(rbinom(10000, 2, 0.3), rbinom(10000, 2, 0.4))
    geno_sd <- standardiseGenotypes(geno)
    expect_equal(colMeans(geno_sd), expected = c(0,0),
                 tolerance = 10e-3)
    expect_equal(apply(geno_sd, 2, sd), expected = c(1,1),
                 tolerance = 10e-3)

    expect_equal(dim(geno), dim(geno_sd))
})

test_that('standardiseGenotypes fails with missing values error', {
    expect_error(standardiseGenotypes(geno=c(1,2,2,NA), impute=FALSE),
                 "Missing genotypes found and impute=FALSE")
})
test_that('standardiseGenotypes works with missing values', {
    expect_equal(sum(standardiseGenotypes(geno=c(1,1,1,NA), impute=TRUE)),
                 0)
})

test_that('simulateGenotypes fails with range error', {
    expect_error(simulateGenotypes(N=10, NrSNP=10, freq=c(-0.1, 0.4)),
                 paste("Allele frequencies must be between 0 and 1"))
})

test_that('simulateGenotypes fails with snpID error', {
    expect_error(simulateGenotypes(N=10, NrSNP=10, snpID=2, freq=c(0.1, 0.4)),
                 "snpID has to be of length 1 and of type character")
})

test_that('simulateGenotypes fails with sampleID error', {
    expect_error(simulateGenotypes(N=10, NrSNP=10, sampleID=c("ID1", "ID2"),
                                   freq=c(0.1, 0.4)),
                 "sampleID has to be of length 1 and of type character")
})

test_that('simulateGenotypes simulates correct frequencies', {
    x <- simulateGenotypes(N=1000, NrSNP=1, freq=0.4)
    f <- min(getAlleleFrequencies(x$genotypes))
    expect_equal(f, 0.4, tolerance = 0.1, scale = 0.4)
})

test_that('readStandardGenotypes fails with missing format error', {
    expect_error(readStandardGenotypes(N=100, filename="test"),
                 "Genotypefile format has to be specified, supported")
})

test_that('readStandardGenotypes fails with format error', {
    expect_error(readStandardGenotypes(N=100, filename="test", format="GCTA"),
                 ".*is not a supported genotype format.*")
})

test_that('readStandardGenotypes returns correctly formated genotypes GENOME', {
    filename_genome  <- system.file("extdata/genotypes/genome/",
                                    "genotypes_genome.txt",
                                    package = "PhenotypeSimulator")
    data_genome <- readStandardGenotypes(N=100, filename_genome,
                                         format ="genome")
    expect_equal(dim(data_genome$genotypes)[1], length(data_genome$id_samples))
    expect_equal(dim(data_genome$genotypes)[2], length(data_genome$id_snps))
    expect_true(is.null(data_genome$format_files))
    expect_true(all(data_genome$genotypes %in% c(0,1,2)))
})

test_that('readStandardGenotypes returns correctly formated genotypes plink', {
    filename_plink  <- system.file("extdata/genotypes/plink/",
                                   "genotypes_plink.bed",
                                   package = "PhenotypeSimulator")
    filename_plink <- gsub("\\.bed", "", filename_plink)
    data_plink <- readStandardGenotypes(N=100, filename=filename_plink,
                                        format="plink")
    expect_equal(dim(data_plink$genotypes)[1], length(data_plink$id_samples))
    expect_equal(dim(data_plink$genotypes)[2], length(data_plink$id_snps))
    expect_identical(data_plink$id_snps[1:3], c("SNP_0", "SNP_1","SNP_2"))
    expect_identical(data_plink$id_samples[1:3], c("per0", "per1","per2"))
    expect_false(is.null(data_plink$format_files))
    expect_true(all(data_plink$genotypes %in% c(0,1,2)))
})

test_that('readStandardGenotypes returns correctly formated genotypes HAPGEN2', {
    filename_hapgen  <- system.file("extdata/genotypes/hapgen/",
                                    "genotypes_hapgen.controls.gen",
                                    package = "PhenotypeSimulator")
    filename_hapgen <- gsub("\\.gen", "", filename_hapgen)
    data_hapgen <- readStandardGenotypes(N=100, filename_hapgen, format='oxgen')
    expect_equal(dim(data_hapgen$genotypes)[1], length(data_hapgen$id_samples))
    expect_equal(dim(data_hapgen$genotypes)[2], length(data_hapgen$id_snps))
    expect_identical(data_hapgen$id_snps[1:2], c("rs10399749", "rs4030303"))
    expect_identical(data_hapgen$id_samples[1:3], c("id1_0", "id1_1","id1_2"))
    expect_false(is.null(data_hapgen$format_files))
    expect_true(all(data_hapgen$genotypes %in% c(0,1,2)))
})

test_that('readStandardGenotypes returns correctly formated delim genotypes', {
    filename_delim  <- system.file("extdata/genotypes/",
                                   "genotypes_chr22.csv",
                                   package = "PhenotypeSimulator")
    data_delim <- readStandardGenotypes(N=50, filename=filename_delim,
                                        format="delim")
    expect_equal(dim(data_delim$genotypes)[1], length(data_delim$id_samples))
    expect_equal(dim(data_delim$genotypes)[2], length(data_delim$id_snps))
    expect_identical(data_delim$id_snps[1], "22-16050408-rs149201999")
    expect_identical(data_delim$id_samples[1], "ID_1")
    expect_true(is.null(data_delim$format_files))
    expect_true(all(data_delim$genotypes %in% c(0,1,2)))
})

test_that('readStandardGenotypes fails with sample error', {
    filename_plink  <- system.file("extdata/genotypes/plink/",
                                   "genotypes_plink.bed",
                                   package = "PhenotypeSimulator")
    filename_plink <- gsub("\\.bed", "", filename_plink)
    expect_error(readStandardGenotypes(N=10000, filename=filename_plink,
                                       format="plink"),
                 "Sample number specified.*")
})

test_that('readStandardGenotypes subsampling works', {
    filename_plink  <- system.file("extdata/genotypes/plink/",
                                   "genotypes_plink.bed",
                                   package = "PhenotypeSimulator")
    filename_plink <- gsub("\\.bed", "", filename_plink)
    geno <- readStandardGenotypes(N=50, filename=filename_plink,
                                  format="plink")
    expect_equal(nrow(geno$genotypes), 50)
    expect_equal(length(geno$id_samples), 50)
})

test_that('getKinship fails if neither kinshipfile nor genotype matrix are
          provided',{
              expect_error(getKinship(N=100),
                           "Either X or kinshipfile must be provided")
          })

test_that('getKinship fails with non-existing kinship file',{
    expect_error(getKinship(N=100, kinshipfile="~/test/kinship"),
                 "does not exist")
})

test_that('getKinship returns positive semi-definite matrix',{
    geno <- simulateGenotypes(N=100, NrSNP=10, verbose=FALSE)
    kin <- getKinship(N=100, X=geno$genotypes, verbose=FALSE)
    kin_eigen <- as.complex(eigen(kin, only.values = TRUE)$values)
    expect_true(all(Re(kin_eigen) > 0))
})

test_that('getKinship fails with sample error', {
    kinshipfile <- system.file("extdata/kinship", "kinship.csv",
                               package = "PhenotypeSimulator")
    expect_error(getKinship(N=1000, kinshipfile=kinshipfile, verbose=FALSE),
                 "Number of samples specifid is greater than number")
})

test_that('getKinship fails with sample ID error', {
    kinshipfile <- system.file("extdata/kinship", "kinship.csv",
                               package = "PhenotypeSimulator")
    expect_error(getKinship(N=10, kinshipfile=kinshipfile,
                            id_samples = paste("Sample_", 1:10, sep=""),
                            verbose=FALSE),
                 "Not all id_samples are present")
})

test_that('getKinship fails with sample ID to sample mismatch error', {
    kinshipfile <- system.file("extdata/kinship", "kinship.csv",
                               package = "PhenotypeSimulator")
    expect_error(getKinship(N=10, kinshipfile=kinshipfile,
                            id_samples = paste("Sample_", 1:12, sep=""),
                            verbose=FALSE),
                 "Length of id_samples")
})

test_that('getKinship returns kinship of correct dimensions', {
    kinshipfile <- system.file("extdata/kinship", "kinship.csv",
                               package = "PhenotypeSimulator")
    K <- getKinship(N=50, kinshipfile=kinshipfile, verbose=FALSE)
    expect_equal(dim(K), c(50,50))
})

test_that('getKinship sampling by sample ID works', {
    kinshipfile <- system.file("extdata/kinship", "kinship.csv",
                               package = "PhenotypeSimulator")
    K <- getKinship(N=10, kinshipfile=kinshipfile,
                    id_samples = paste("ID_", 1:10, sep=""),
                    verbose=FALSE)
    expect_equal(dim(K), c(10,10))
})

test_that('getCausalSNPs fails with missing input error', {
    expect_error(getCausalSNPs(N=100, NrCausalSNPs = 20, verbose=FALSE),
                 "No genotype information provided,.*")
})

test_that('getCausalSNPs fails with genotype input error', {
    geno <- simulateGenotypes(N=10, NrSNP=10)
    expect_error(getCausalSNPs(N=10, NrCausalSNPs=10, genotypes=geno),
                 "Genotypes have to be provided as")
})

test_that('getCausalSNPs fails with genotype input error', {
    geno <- simulateGenotypes(N=10, NrSNP=10)
    expect_error(getCausalSNPs(N=10, NrCausalSNPs=50, genotypes=geno$genotypes),
                 "Number of genotypes is less than number of causal SNPs")
})

test_that('getCausalSNPs fails with incorrect input error', {
    expect_error(getCausalSNPs(N=100, NrCausalSNPs = 20,
                               genoFilePrefix = "~/test", verbose=FALSE),
                 "genoFilePrefix contains ~.*")
})

test_that('getCausalSNPs fails with missing chromosome error', {
    expect_error(getCausalSNPs(N=100, NrCausalSNPs = 20,
                               genoFilePrefix = "/test", verbose=FALSE),
                 "No information about chromosomes to.*")
})

test_that('getCausalSNPs fails with too much chromosome information error', {
    expect_error(getCausalSNPs(N=100, NrCausalSNPs = 20,
                               genoFilePrefix = "/test", NrChrCausal = 20,
                               chr=10, verbose=FALSE),
                 "Too much information for sampling .*")
})
test_that('getCausalSNPs fails with wrong chromosome information error', {
    expect_error(getCausalSNPs(N=100, NrCausalSNPs = 20,
                               genoFilePrefix = "/test", NrChrCausal = 3,
                               NrSNPsOnChromosome = c(4,5), verbose=FALSE),
                 "Not enough information about numbers .*")
})

test_that('getCausalSNPs fails with wrong file error', {
    expect_error(getCausalSNPs(N=100, NrCausalSNPs = 20,
                               genoFilePrefix = "/test",
                               genoFileSuffix = ".csv",
                               NrChrCausal = 3,
                               NrSNPsOnChromosome = c(4,5,6), verbose=FALSE),
                 "does not exist.*")
})

test_that('getCausalSNPs fails with SNP number error', {
    genotypeFile <- system.file("extdata/genotypes/",
                                "genotypes_chr22.csv",
                                package = "PhenotypeSimulator")
    genoFilePrefix <- gsub("chr.*", "", genotypeFile)
    genoFileSuffix <- ".csv"
    expect_error(getCausalSNPs(N=50, NrCausalSNPs=2000, chr=22,
                               genoFilePrefix=genoFilePrefix,
                               genoFileSuffix=genoFileSuffix),
                 "Number of causal SNPs to be chosen from chromosome")
})

test_that('getCausalSNPs fails with sample error', {
    geno <- simulateGenotypes(N=100, NrSNP=10, verbose=FALSE)
    expect_error(getCausalSNPs(N=1000, NrCausalSNPs = 10,
                               genotypes = geno$genotypes,
                               verbose=FALSE),
                 "Sample number specified exceeds number.*")
})

test_that('getCausalSNPs returns correct output dimensions', {
    geno <- simulateGenotypes(N=100, NrSNP=10, verbose=FALSE)
    expect_equal(dim(getCausalSNPs(N=100, NrCausalSNPs = 10,
                                   genotypes = geno$genotypes,
                                   verbose=FALSE)),
                 c(100,10))
})

test_that('getCausalSNPs samples from oxgen formated genotypes', {
    genotypeFile  <- system.file("extdata/genotypes/hapgen/",
                                 "genotypes_hapgen_chr22.gen",
                                 package = "PhenotypeSimulator")
    genoFilePrefix <- gsub("chr.*", "", genotypeFile)
    genoFileSuffix <- ".gen"
    tmp <- getCausalSNPs(N=50, NrCausalSNPs=10, chr=22,
                         genoFilePrefix=genoFilePrefix,
                         genoFileSuffix=genoFileSuffix,
                         format='oxgen', verbose=FALSE)
    expect_equal(dim(tmp)[1], 50)
    expect_equal(dim(tmp)[2], 10)

})

test_that('getCausalSNPs fails with delimiter error', {
    genotypeFile <- system.file("extdata/genotypes",
                                "genotypes_chr22.csv",
                                package = "PhenotypeSimulator")
    genoFilePrefix <- gsub("chr.*", "", genotypeFile)
    genoFileSuffix <- ".csv"
    expect_error(getCausalSNPs(N=50, NrCausalSNPs=10, chr=22,
                               genoFilePrefix=genoFilePrefix,
                               genoFileSuffix=genoFileSuffix,
                               delim="\t", verbose=FALSE),
                 "Delimiter specified for genoFilePrefix-genoFileSuffix")
})

test_that('getCausalSNPs samples from delim formated genotypes', {
    genotypeFile <- system.file("extdata/genotypes/",
                                "genotypes_chr22.csv",
                                package = "PhenotypeSimulator")
    genoFilePrefix <- gsub("chr.*", "", genotypeFile)
    genoFileSuffix <- ".csv"
    tmp <- getCausalSNPs(N=50, NrCausalSNPs=10, chr=22,
                         genoFilePrefix=genoFilePrefix,
                         genoFileSuffix=genoFileSuffix,
                         format='delim', delim=",", verbose=FALSE)
    expect_equal(dim(tmp)[1], 50)
    expect_equal(dim(tmp)[2], 10)
})

test_that('getCausalSNPs samples from bimbam formated genotypes', {
    genotypeFile <- system.file("extdata/genotypes",
                                "genotypes_chr22.bimbam",
                                package = "PhenotypeSimulator")
    genoFilePrefix <- gsub("chr.*", "", genotypeFile)
    genoFileSuffix <- ".bimbam"
    tmp <- getCausalSNPs(N=50, NrCausalSNPs=10, chr=22,
                         genoFilePrefix=genoFilePrefix,
                         genoFileSuffix=genoFileSuffix,
                         format='bimbam', delim=",", verbose=FALSE)
    expect_equal(dim(tmp)[1], 50)
    expect_equal(dim(tmp)[2], 10)
})


#Objetivo:  generar un arbol CREANDO una nueva variable que es la combinacion de las dos mas importantes

#Arbol con libreria  rpart
#se trabaja con constantes para ordenar el codigo fuente

#source("M:\\R\\elementary\\MiPrimerArbol_02.r")

#limpio la memoria
rm(list=ls())
gc()

library("data.table")
library("rpart")
library("rpart.plot")

setwd("E:/UBA/2019-II/DM en Finanzas/Dropbox Prof/datasets")

#Parametros entrada
karchivo_entrada      <-  "201902.txt"
kcampos_separador     <-  "\t"
kcampo_id             <-  "numero_de_cliente"
kclase_nomcampo       <-  "clase_ternaria"
kclase_valor_positivo <-  "BAJA+2"
kcampos_a_borrar      <-  c(kcampo_id)

#Parametros salida
karchivo_imagen       <-  "..\\work\\arbol_02.jpg"

#cargo los datos
dataset <- fread(karchivo_entrada, header=TRUE, sep=kcampos_separador)

#Agrego la nueva variable  MAX(Visa_cuenta_estado, Master_cuenta_estado)
dataset[ ,  VisaMaster_cuenta_estado1 :=  pmax(Visa_cuenta_estado, Master_cuenta_estado, na.rm = TRUE)  ]

# generacion del modelo
formula  <-  formula(paste(kclase_nomcampo, "~ ."))

t0       <-  Sys.time()
modelo   <-  rpart(formula,   data = dataset,   cp=0.1,   xval=0)
t1       <-  Sys.time()

tcorrida <-  as.numeric( t1 - t0, units = "secs")
print( tcorrida)

#impresion un poco mas elaborada del arbol
jpeg(file = karchivo_imagen,  width = 6, height = 4, units = 'in', res = 300)
prp(modelo, extra=101, digits=5, branch=1, type=4, varlen=0, faclen=0)
dev.off()


myROC <- function(ftime,
                  fstatus,
                  strata,
                  times,
                  data,
                  span,
                  strata.name){

  roc.dat <- NULL
  auc.dat <- NULL

  strata.levels <- unique(strata[!is.na(strata)])

  for(j in 1:length(strata.levels)){

    out <- NULL
    for(i in 1:length(times)){

      risk.ind <- which(names(data)==paste0("prob", times[i]))

      out2 = crCROC(Stime = ftime[is.element(strata, strata.levels[j])],
             status = fstatus[is.element(strata, strata.levels[j])],
             marker = data[is.element(strata, strata.levels[j]),risk.ind],
             predict.time = times[i],
             span = span)

      #out2$plot + ggtitle("2 year") + ylim(0, .1)
      out2$roc.dat <- data.frame(fpf = out2$FP, tpf = out2$TP[,1], year = paste(times[i], "year"))
      out2$roc.dat[[strata.name]] <- strata.levels[j]
      out2$FP <- NULL; out2$TP <- NULL; out2$cut.values = NULL;
      out2$auc.dat <- data.frame(auc = out2$AUC[,1], year = paste(times[i], "year"))
      out2$auc.dat[[strata.name]] <- strata.levels[j]

      out[[i]] <- out2
    }

    roc.dat[[j]] <- bind_rows(lapply(out, function(x) x$roc.dat) )

    auc.dat[[j]] <- bind_rows(lapply(out, function(x) x$auc.dat))

  }

  roc.dat <- bind_rows(roc.dat)

  auc.dat <- bind_rows(auc.dat)

  roc.dat$year <- factor(roc.dat$year, levels = c("2 year", "5 year", "10 year"))
  auc.dat$year <- factor(auc.dat$year, levels = c("2 year", "5 year", "10 year"))

  return(list(roc.dat, auc.dat))

}


## Code by Jorn Dallinga, under Expat license
cloud_filter <- function(x, probav_sm_dir, cf_bands, pattern, tiles, thresholds=c(-50, Inf) , span=0.3, minrows=1, mc.cores=1, logfile, overwrite=FALSE, filename="") {

  thresholds <- matrix(thresholds, nrow=2)

  df_probav_sm <- getProbaVinfo(probav_sm_dir, pattern = pattern, tiles = tiles)
  s_info <- df_probav_sm
  #s_info <- getProbaVinfo(names(x))
  bands <- s_info[s_info$date == s_info$date[1], 'band']
  dates <- s_info[s_info$band == bands[1], 'date']
  ydays <- s_info[s_info$band == bands[1], 'yday']

  cf <- function(x){
    # smooth loess and getHarmMetrics
    m <- matrix(x, nrow= length(bands), ncol=length(dates))
    #qcb <- smoothLoess(m, dates = dates, thresholds=NULL, res_type = "QC", span=0.3)
    if (!all(is.na(m[1,]))) {
      res <- try({
        # smooth loess on all cf bands, then combine
        qc <- foreach(bn = 1:length(cf_bands), .combine='&') %do% {
          qcb <-   smoothLoess(m[cf_bands[bn],], dates = dates, threshold = thresholds[,bn],
                               res_type = "QC", span=span)
        }
      })

      if(class(res) == 'try-error') {
        res <- rep(NA_integer_, length(dates))
      }
    } else {
      res <- rep(NA_integer_, length(dates))
    }

    return(res)
  }

  out <- mcCalc(x=x, fun = cf, minrows = minrows, mc.cores = mc.cores, logfile=logfile, out_name = filename, overwrite = overwrite, mc.preschedule = FALSE, datatype = "INT1U", of="GTiff")

  return(out)
}


ex1<-'Dirichlet'
stom<-Read.stomach.data(dir=file.path(root,'ns_paper_05_size'))
a<-subset(stom,select=c(-L.N.bar,-Prey.avail,-Suit,-obj.contrib,-sum.p,-like.dir,-Predator.available.food,-Prey.avail))
a$stomcon.hat.dir<-a$stomcon.hat; a$stomcon.hat<-NULL
a$Stom.var.dir<-a$Stom.var ; a$Stom.var<-NULL
a$Residual.dir<-a$Residual; a$Residual<-NULL
dim(a)

ex2<-'log-normal'
stom<-Read.stomach.data(dir=file.path(root,'ns_paper_05_size_log_normal'))
b<-subset(stom,select=c(-L.N.bar,-Prey.avail,-Suit,-obj.contrib,-sum.p,-like.dir,-Predator.available.food,-Prey.avail))
b$stomcon.hat.log<-b$stomcon.hat; b$stomcon.hat<-NULL
b$Stom.var.log<-b$Stom.var ; b$Stom.var<-NULL
b$Residual.log<-b$Residual; b$Residual<-NULL
dim(b)

ab<-merge(a,b)
dim(ab)
ab<-subset(ab,stom.used.like==1,select=c(-stom.used.like, -stom.used.avail ,-N.haul))
dim(ab)

dev<-"print"
dev<-"screen"
nox<-4
noy<-3

a<-subset(ab,Year==1991 & Predator %in% c('Cod','Whiting','Haddock'))

##############################################################
#log observed and predicted stomach contents by Predator and prey

dir.col<-2
dir.pch<-3

cleanup()
nox<-3; noy<-3;
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-log(x$stomcon)
   bb.dir<-log(x$stomcon.hat.dir)
   bb.log<-log(x$stomcon.hat.log)
   max.val<-max(aa,bb.log,bb.dir)
   min.val<-min(aa,bb.log,bb.dir)
   plot(bb.log,aa,xlab='log Expected stomach content',ylab='log observed',ylim=c(min.val,max.val),xlim=c(min.val,max.val))
   if (var(bb.log)>0) abline(lm(aa~bb.log), lty=3)

   points(bb.dir,aa,col=dir.col,pch=dir.pch)
   if (var(bb.dir)>0) abline(lm(aa~bb.dir), lty=2,col=dir.col)

   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

##############################################################
# observed and predicted stomach contents by Predator and prey

cleanup()
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-(x$stomcon)
   bb.dir<-(x$stomcon.hat.dir)
   bb.log<-(x$stomcon.hat.log)
   max.val<-max(aa,bb.log,bb.dir)
   min.val<-min(aa,bb.log,bb.dir)
   plot(bb.log,aa,xlab='Expected stomach content',ylab='observed',ylim=c(min.val,max.val),xlim=c(min.val,max.val))
   if (var(bb.log)>0) abline(lm(aa~bb.log), lty=3)

   points(bb.dir,aa,col=dir.col,pch=dir.pch)
   if (var(bb.dir)>0) abline(lm(aa~bb.dir), lty=2,col=dir.col)

   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

##############################################################
# observed and predicted stomach contents by Predator and prey
# for very small observed

a<-subset(ab,Year==1991 & Predator %in% c('Cod','Whiting','Haddock') & stomcon<0.01)

cleanup()

newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-log(x$stomcon)
   bb.dir<-log(x$stomcon.hat.dir)
   bb.log<-log(x$stomcon.hat.log)
   max.val<-max(aa,bb.log,bb.dir)
   min.val<-min(aa,bb.log,bb.dir)
   plot(bb.log,aa,xlab='log Expected stomach content',ylab='log observed',ylim=c(min.val,max.val),xlim=c(min.val,max.val))
   if (var(bb.log)>0) abline(lm(aa~bb.log), lty=3)

   points(bb.dir,aa,col=dir.col,pch=dir.pch)
   if (var(bb.dir)>0) abline(lm(aa~bb.dir), lty=2,col=dir.col)

   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

cleanup()
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   aa<-(x$stomcon)
   bb.dir<-(x$stomcon.hat.dir)
   bb.log<-(x$stomcon.hat.log)
   max.val<-max(aa,bb.log,bb.dir)
   min.val<-min(aa,bb.log,bb.dir)
   plot(bb.log,aa,xlab='Expected stomach content',ylab='observed',ylim=c(min.val,max.val),xlim=c(min.val,max.val))
   if (var(bb.log)>0) abline(lm(aa~bb.log), lty=3)

   points(bb.dir,aa,col=dir.col,pch=dir.pch)
   if (var(bb.dir)>0) abline(lm(aa~bb.dir), lty=2,col=dir.col)

   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

##############################################################
# Stomach variance observations

a<-subset(ab,Year==1991 & Predator %in% c('Cod','Whiting','Haddock') )
cleanup()
nox<-3; noy<-3;
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
    plot(x$Stom.var.log,x$Stom.var.dir,ylab=paste('Stom variance',ex1),xlab='log-normal')

   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

##############################################################
# Stomach residuals, compare

a<-subset(ab,Year==1991 & Predator %in% c('Cod','Whiting','Haddock') )
cleanup()
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
    plot(x$Residual.log,x$Residual.dir,ylab=paste('Residual',ex1),xlab=paste('Residual',ex2))

   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

##############################################################
# Residuals by Predator, and expected stom content

cleanup()
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$stomcon.hat.log,x$Residual.log,xlab='Expected relative stomach content',ylab=paste('Residual',ex2))
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})

cleanup()
newplot(dev,nox,noy);
i<-0

by(a,list(a$Prey,a$Predator),function(x) {
   if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
   plot(x$stomcon.hat.dir,x$Residual.dir,xlab='Expected relative stomach content',ylab=paste('Residual',ex1))
   abline(h=0, lty=3)
   title(main=paste("Pred:",x[1,]$Predator,", Prey:",x[1,]$Prey,sep=""))
   i<<-i+1
})


library("tidyverse")
library("edgeR")
library("limma")
library("psych")
library("gridExtra")
library("stringr")
library("scales")

# read in the data
temp <- read_tsv("ave_missing.txt")

# make a basic plot
ggplot(temp, aes(x = Ave, y = FracMissing)) +
  geom_point() +
  ggtitle("Missing Fraction versus Average SpC") +
  labs(x = "Ave SpC", y = "Missing Fraction")

# expanded x-axis plot
ggplot(temp, aes(x = Ave, y = FracMissing)) +
  geom_line() +
  coord_cartesian(xlim = c(0, 8)) +
  ggtitle("Missing Fraction versus Average SpC") +
  labs( x = "Ave SpC", y = "Missing Fraction") +
  geom_vline(xintercept = 2.5, linetype = "dotted")

# read in the prepped data
paw_spc <- read_tsv("edgeR_input.txt")

# save accessions in vector and remove from data table
accession <- paw_spc$Accession
paw_spc <- select(paw_spc, -Accession)
head(paw_spc)
nrow(paw_spc)

# read in short table
freq <- read_tsv("Fractions_SpC_ID.txt")

# make a bar plot to summarize the data
ggplot(freq, aes(InHowMany, Fraction, fill = Measure)) +
  geom_bar(stat = "identity", color = "black", position = position_dodge()) +
  geom_text(aes(label = Fraction), vjust = 1.6, color = "black",
            position = position_dodge(0.9), size = 2.5) +
  scale_x_continuous( breaks = 1:10) +
  ggtitle("Fractions of total spectra counts or of total identifications") +
  xlab("In How Many Samples") + ylab("Fraction (%)")

# function for simple normalization
SL_Norm <- function(df, color = NULL, plot = TRUE) {
    # This makes each channel sum to the average grand total
        # df - data frame of TMT intensities
        # returns a new data frame with normalized values

    # compute scaling factors to make colsums match the average sum
    norm_facs <- mean(c(colSums(df))) / colSums(df)
    cat("SL Factors:\n", sprintf("%-5s -> %f\n", colnames(df), norm_facs))
    df_sl  <- sweep(df, 2, norm_facs, FUN = "*")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(df_sl + 1), col = color, notch = TRUE, main = "SL Normalized data")
    }
    df_sl
}

# normalize the data before plotting
color <- c(rep('blue', 5), rep('red', 5))
paw_sl <- SL_Norm(paw_spc, color)

# shortcuts for the cell types
C <- 1:5
R <- 6:10

pairs.panels(paw_sl[C], main = "Choroidal")
pairs.panels(log2(paw_sl[C]+1), main = "Choroidal")
pairs.panels(paw_sl[R], main = "Retinal")
pairs.panels(log2(paw_sl[R]+1), main = "Retinal")

# load the data into edgeR data structures
# group labels need to be factors
y <- DGEList(counts = paw_spc, genes = accession)

# run the TMM normalization (and library size corrections)
y <- calcNormFactors(y)

apply_tmm_factors <- function(y, color = NULL, plot = TRUE) {
    # computes the tmm normalized data from the DGEList object
        # y - DGEList object
        # returns a dataframe with normalized intensities

    # compute grand total (library size) scalings
    lib_facs <- mean(y$samples$lib.size) / y$samples$lib.size

    # the TMM factors are library adjustment factors (so divide by them)
    norm_facs <- lib_facs / y$samples$norm.factors
    cat("Overall Factors (lib.size+TMM):\n", sprintf("%-5s -> %f\n",
                                                     colnames(y$counts), norm_facs))

    # compute the normalized data as a new data frame
    df_tmm <- as.data.frame(sweep(y$counts, 2, norm_facs, FUN = "*"))
    colnames(df_tmm) <- str_c(colnames(y$counts), "_tmm")

    # visualize results and return data frame
    if(plot == TRUE) {
        boxplot(log10(df_tmm + 1), col = color, notch = TRUE, main = "TMM Normalized data")
    }
    df_tmm
}

paw_spc_tmm <- apply_tmm_factors(y, color)

# check clustering
plotMDS(y, col = color, main = "Retina vs Choroid")

CV <- function(df) {
    # Computes CVs of data frame rows
        # df - data frame,
        # returns vector of CVs (%)
    ave <- rowMeans(df)    # compute averages
    sd <- apply(df, 1, sd) # compute standard deviations
    cv <- 100 * sd / ave   # compute CVs in percent (last thing gets returned)
}

labeled_boxplot <- function(df, ylim, title) {
    # Makes a box plot with the median value labeled
        # df - data frame with data to compute CVs of
        # ylim - upper limit for y-axis
        # title - plot title
    cv = CV(df)
    boxplot(cv, ylim = c(0, ylim), notch = TRUE, main = title)
    text(x = 0.65, y = boxplot.stats(cv)$stats[3],
         labels = round(boxplot.stats(cv)$stats[3], 1))
}

# see what effect TMM had on CV distributions
par(mfrow = c(2, 2))
labeled_boxplot(paw_spc[C], 150, "Choroid before")
labeled_boxplot(paw_spc[R], 150, "Retina before")
labeled_boxplot(paw_spc_tmm[C], 150, "Choroid after")
labeled_boxplot(paw_spc_tmm[R], 150, "Retina after")
par(mfrow = c(1, 1))

group <- factor(c(rep("C", 5), rep("R", 5)))
yy <-  DGEList(counts = paw_spc, group = group, genes = accession)
yy <- calcNormFactors(yy)
yy <- estimateDisp(yy)
et <- exactTest(yy)
topTags(et)$table
summary(decideTests(et, p.value = 0.10))

# create the experimental design matrix
donor <- factor(rep(c(189, 191, 194, 195, 199), 2))
cell <- factor(c(rep("C", 5), rep("R", 5)))

# Example 4.1 in edgeR user's guide
design <- model.matrix(~donor+cell)
rownames(design) <- colnames(y)
design

# extimate the dispersion parameters and check
y <- estimateDisp(y, design, robust = TRUE)
y$common.dispersion
plotBCV(y, main = "Variance Trends")

# fit statistical models (design matrix already in y$design)
fit <- glmQLFit(y, design, robust = TRUE)
plotQLDisp(fit)

# if we do not specify a contrast, the default is the last column
# of the design matrix - a C versus R comparison
paired <- glmQLFTest(fit) # default comparison

# check test results
topTags(paired)$table
tt <- topTags(paired, n = Inf, sort.by = "none")$table
summary(decideTests(paired, p.value = 0.10))

collect_results <- function(df, tt, x, xlab, y, ylab) {
    # Computes new columns and extracts some columns to make results frame
        # df - data in data.frame
        # tt - top tags from edgeR test
        # x - columns for first condition
        # xlab - label for x
        # y - columns for second condition
        # ylab - label for y
        # returns a new dataframe

    # condition average vectors
    ave_x <- rowMeans(df[x])
    ave_y <- rowMeans(df[y])

    # FC, direction, candidates
    fc <- ifelse(ave_y > ave_x, (ave_y / ave_x), (-1 * ave_x / ave_y))
    direction <- ifelse(ave_y > ave_x, "up", "down")
    candidate <- cut(tt$FDR, breaks = c(-Inf, 0.01, 0.05, 0.10, 1.0),
                     labels = c("high", "med", "low", "no"))

    # make data frame
    temp <- cbind(df[c(x, y)], data.frame(logFC = tt$logFC, FC = fc,
                                          PValue = tt$PValue, FDR = tt$FDR,
                                          ave_x = ave_x, ave_y = ave_y,
                                          direction = direction, candidate = candidate,
                                          Acc = tt$genes))

    # fix column headers for averages
    names(temp)[names(temp) %in% c("ave_x", "ave_y")]  <- str_c("ave_", c(xlab, ylab))

    temp # return the data frame
}

# get the results summary
results <- collect_results(paw_spc_tmm, tt, C, "choroid", R, "retina")

pvalue_plots <- function(results, ylim, title) {
    # Makes p-value distribution plots
        # results - results data frame
        # ylim - ymax for expanded view
        # title - plot title
    p_plot <- ggplot(results, aes(PValue)) +
        geom_histogram(bins = 100, fill = "white", color = "black") +
        geom_hline(yintercept = mean(hist(results$PValue, breaks = 100,
                                     plot = FALSE)$counts[26:100]))

    # we will need an expanded plot
    p1 <- p_plot + ggtitle(str_c(title, " p-value distribution"))
    p2 <- p_plot + coord_cartesian(xlim = c(0, 1.0), ylim = c(0, ylim)) + ggtitle("p-values expanded")
    grid.arrange(p1, p2, nrow = 2) # from gridExtra package
}

# check the p-value distribution
pvalue_plots(results, 100, "Retina vs Choroid - SpC")

log2FC_plots <- function(results, range, title) {
    # Makes faceted log2FC plots by candidate
        # results - results data frame
        # range - plus/minus log2 x-axis limits
        # title - plot title
    ggplot(results, aes(x = logFC, fill = candidate)) +
        geom_histogram(binwidth=0.1, color = "black") +
        facet_wrap(~candidate) +
        ggtitle(title) +
        coord_cartesian(xlim = c(-range, range))
}

# make log2FC plots
log2FC_plots(results, 4, "Faceted log2FC")

# see how many candidates are in each category
results %>% count(candidate)

transform <- function(results, x, y) {
    # Make data frame with some transformed columns
        # results - results data frame
        # x - columns for x condition
        # y - columns for y condition
        # return new data frame
    df <- data.frame(log10((results[x] + results[y])/2),
                     log2(results[y] / results[x]),
                     results$candidate,
                     -log10(results$FDR))
    colnames(df) <- c("A", "M", "candidate", "P")

    df # return the data frame
}

MA_plots <- function(results, x, y, title) {
    # makes MA-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # uses transformed data
    temp <- transform(results, x, y)

    # 2-fold change lines
    ma_lines <- list(geom_hline(yintercept = 0.0, color = "black"),
                     geom_hline(yintercept = 1.0, color = "black", linetype = "dotted"),
                     geom_hline(yintercept = -1.0, color = "black", linetype = "dotted"))

    # make main MA plot
    ma <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("logFC (", y, "/", x, ")")) +
        scale_x_continuous("Ave_intensity") +
        ggtitle(title) +
        ma_lines

    # make separate MA plots
    ma_facet <- ggplot(temp, aes(x = A, y = M)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scale_y_continuous(paste0("log2 FC (", y, "/", x, ")")) +
        scale_x_continuous("log10 Ave_intensity") +
        ma_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(ma)
    print(ma_facet)
}

# make MA plots
MA_plots(results, "ave_choroid", "ave_retina", "Choroid vs Retina")

scatter_plots <- function(results, x, y, title) {
    # makes scatter-plot DE candidate ggplots
        # results - data frame with edgeR results and some condition average columns
        # x - string for x-axis column
        # y - string for y-axis column
        # title - title string to use in plots
        # returns a list of plots

    # 2-fold change lines
    scatter_lines <- list(geom_abline(intercept = 0.0, slope = 1.0, color = "black"),
                          geom_abline(intercept = 0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          geom_abline(intercept = -0.301, slope = 1.0, color = "black", linetype = "dotted"),
                          scale_y_log10(),
                          scale_x_log10())

    # make main scatter plot
    scatter <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        ggtitle(title) +
        scatter_lines

    # make separate scatter plots
    scatter_facet <- ggplot(results, aes_string(x, y)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        scatter_lines +
        facet_wrap(~ candidate) +
        ggtitle(str_c(title, " (separated)"))

    # make the plots visible
    print(scatter)
    print(scatter_facet)
}

# make scatter plots
scatter_plots(results, "ave_choroid", "ave_retina", "Choroid vs Retina")

volcano_plot <- function(results, x, y, title) {
    # makes a volcano plot
        # results - a data frame with edgeR results
        # x - string for the x-axis column
        # y - string for y-axis column
        # title - plot title string

    # uses transformed data
    temp <- transform(results, x, y)

    # build the plot
    ggplot(temp, aes(x = M, y = P)) +
        geom_point(aes(color = candidate, shape = candidate)) +
        xlab("log2 FC") +
        ylab("-log10 FDR") +
        ggtitle(str_c(title, " Volcano Plot"))
}

# make a volcano plot
volcano_plot(results, "ave_choroid", "ave_retina", "Choroid vs Retina")

# ============== individual protein expression plots ===========================

# function to extract the identifier part of the accesssion
get_identifier <- function(accession) {
    identifier <- str_split(accession, "\\|", simplify = TRUE)
    identifier[,3]
}

set_plot_dimensions <- function(width_choice, height_choice) {
    options(repr.plot.width=width_choice, repr.plot.height=height_choice)
}

plot_candidates <- function(results, nleft, nright, show_these = c("high", "med", "low")) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot

    # get desired candidates
    proteins <- proteins %>%
        filter(candidate %in% show_these) %>% arrange(candidate)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3), ", ", row$candidate)
        barplot(vec, col = color, main = title)
    }
}

plot_top_tags <- function(results, nleft, nright, top_tags) {
    # results should have data first, then test results (two condition summary table)
    # nleft, nright are number of data points in each condition
    # top_tags is number of up and number of down top DE candidates to plot
    # get top ipregulated
    up <- results %>%
        filter(logFC >= 0) %>%
        arrange(FDR)
    up <- up[1:top_tags, ]

    # get top down regulated
    down <- results %>%
        filter(logFC < 0) %>%
        arrange(FDR)
    down <- down[1:top_tags, ]

    # pack them
    proteins <- rbind(up, down)

    color = c(rep("red", nleft), rep("blue", nright))
    for (row_num in 1:nrow(proteins)) {
        row <- proteins[row_num, ]
        vec <- as.vector(unlist(row[1:(nleft + nright)]))
        names(vec) <- colnames(row[1:(nleft + nright)])
        title <- str_c(get_identifier(row$Acc), ", int: ", scientific(mean(vec), 2),
                       ", p-val: ", scientific(row$FDR, digits = 3),
                       ", FC: ", round(row$FC, digits = 1))
        barplot(vec, col = color, main = title)
    }
}
# plot the top 25 up and 20 down proteins
set_plot_dimensions(6, 3.5)
plot_top_tags(results, 5, 5, 25)
set_plot_dimensions(7, 7)

# write results
write.table(results, "edgeR_results.txt", sep = "\t", row.names = FALSE, na = " ")

# log the session
sessionInfo()


#' Numeric vector
#'
#' @description Coerce a character vector to numeric: removing thousand separator, replace comma with dots and applytins as.numeric()
#'
#' @param x character vector
#'
#'
#' @return Numeric vector
#' @export
#'
#' @examples
#'
#' x <- "10.000,50"
#'
#' num_convert(x)
#'

num_convert <- function(x){

  if(!is.numeric(x)){

    as.numeric(gsub("\\,", "\\.",gsub("\\.", "", x)), na.rm = F)

  }else{
      return(x)
    }

}


#rm(list=ls(all=TRUE))
#data_fn="tmp/"
#folder_fn="results-benchmark-binary"
#results_fn=paste(data_fn,folder_fn,"/raw",sep="")
#output_fn=paste(data_fn,folder_fn,"/results-timeseries.pdf",sep="")

#configs.loop=10
#configs.recursion=c(10)
#configs.labels=c("No Probe","Deactivated Probe","Collecting Data","Writing Data")
#configs.colors=c("black","red","blue","green")
configs.count=length(configs.labels)

## We assume same amount of data in each category
#results.count=20000000
buckets.count=1000
buckets.size=results.count/buckets.count

## Configure Timeseries
#tsconf.min=0
#tsconf.max=50

pdf(output_fn, width=10, height=6.25, paper="special")

for (cr in configs.recursion) {
  for (cl in (1:configs.loop)) {
    results.ts <- array(dim=c(buckets.count,configs.count))
    for (cc in (1:configs.count)) {
      results.bucket <- array(dim=c(buckets.count))
      results_fn_temp=paste(results_fn, "-", cl, "-", cr, "-", cc, ".csv", sep="")
      results=read.csv2(results_fn_temp,quote="",colClasses=c("NULL","numeric"),comment.char="",col.names=c("thread_id","duration_nsec"),nrows=results.count)
      results["rt_musec"]=results["duration_nsec"]/(1000)
      results$duration_nsec <- NULL
      for (ci in (1:buckets.count)) {
        results.bucket[ci] <- mean(results[(((ci-1)*buckets.size)+1):(ci*buckets.size),"rt_musec"])
      }
      results.ts[,cc]=ts(results.bucket,end=results.count,deltat=buckets.size)
      rm(results,results_fn_temp,results.bucket)
    }
    ts.plot(results.ts,gpars=list(ylim=c(tsconf.min,tsconf.max),col=configs.colors,xlab="Executions"))
    legend("topright",inset=c(0.01,0.01),legend=c(rev(configs.labels)),lty="solid",col=rev(configs.colors),bg="white",title="Mean execution time of ...",ncol=2)
    title(main=paste("Iteration: ", cl, "  Recursion Depth: ", cr),ylab=expression(paste("Execution Time (",mu,"s)")))
  }
}
invisible(dev.off())


cat(sapply(strsplit(readLines(tail(commandArgs(), n=1)), " | ", fixed=TRUE), function(s) {
  t <- sapply(strsplit(s[1], " ")[[1]], as.integer)
  if (length(t) > 1) {
  n <- min(as.integer(s[2]), length(t))
  for (i in 1:n) {
    for (j in 2:length(t)) {
      if (t[j-1] > t[j]) {
        tmp <- t[j-1]
        t[j-1] <- t[j]
        t[j] <- tmp
      }
    }
  }
  }
  paste(t, collapse=" ")
}), sep="\n")


restoreParams = function (bugsResult, ragged = NULL, extraX = NULL)
{
    thearray = bugsResult$sims.array
    parnames = dimnames(thearray)[[3]]
    vecPars = grep("\\[[[:digit:]]+\\]$", parnames, value = TRUE)
    matPars = grep("[[:digit:]+],[[:digit:]]+\\]$", parnames,
        value = TRUE)
    scPars = parnames[!parnames %in% c(vecPars, matPars)]
    scPars = scPars[grep("^beta", scPars, invert = TRUE)]
    result = list()
    if (length(matPars)) {
        precisionIndex = grep("^T", matPars)
        precisions = matPars[precisionIndex]
        matPars = matPars[-precisionIndex]
        result$precision = thearray[, , precisions]
        precisions = unique(gsub("\\[[[:digit:]]+,[[:digit:]]+\\]",
            "", precisions))
        for (D in precisions) {
            result[[paste("var", D, sep = "")]] = cholInvArray(result$precision,
                D)
        }
        colno = substr(matPars, regexpr(",[[:digit:]]+\\]", matPars) +
            1, 10000)
        colno = substr(colno, 1, nchar(colno) - 1)
        maxcol = max(as.integer(colno))
        if (is.na(maxcol))
            warning("can't find max col number")
        interceptcols = grep(paste(",", maxcol, "\\]", sep = ""),
            matPars)
        slopecols = matPars[-interceptcols]
        result$slopes = thearray[, , slopecols]
        matPars = which(parnames %in% matPars)
        parnames[matPars] = gsub(paste(",", maxcol, "\\]", sep = ""),
            "\\]", parnames[matPars])
        dimnames(thearray)[[3]] = parnames
        vecPars = grep("\\[[[:digit:]]+\\]$", parnames, value = TRUE)
    }
    thephi = grep("^phi", scPars, value = TRUE)
    for (D in thephi) {
        thesd = gsub("^phi", "SD", D)
        if (thesd %in% scPars) {
            scPars = grep(D, scPars, invert = TRUE, value = TRUE)
            therange = gsub("^phi", "range", D)
            result[[therange]] = thearray[, , D]/thearray[, ,
                thesd]
        }
    }
    for (D in scPars) result[[D]] = thearray[, , D]
    if (!length(scPars))
        warning("no parameter names")
    fixedEffects = grep("^X", names(ragged), value = TRUE)
    betas = NULL
    for (D in fixedEffects) {
        tobind = thearray[, , grep(gsub("^X", "beta", D), dimnames(thearray)[[3]]),
            drop = F]
        if (!dim(tobind)[3])
            warning("can't find fixed effect parameters for ",
                D)
        newnames = dimnames(ragged[[D]])[[2]]
        if (length(newnames) == (dim(tobind)[3]))
            dimnames(tobind)[[3]] = newnames
        betas = abind::abind(betas, tobind, along = 3)
    }
    result$betas = betas
    groups = unique(gsub("\\[[[:digit:]]+\\]$", "", vecPars))
    thebetas = grep("^beta", groups)
    if (length(thebetas))
        groups = groups[-thebetas]
    for (D in groups) {
        thisGroup = grep(paste("^", D, "\\[", sep = ""), vecPars,
            value = TRUE)
        result[[D]] = thearray[, , thisGroup]
    }
    theSpatialGroups = grep("Spatial$", groups)
    if (length(theSpatialGroups)) {
        notSpatial = groups[-theSpatialGroups]
    }
    else {
        notSpatial = groups
    }
    for (D in notSpatial) {
        result[[paste("Fitted", D, sep = "")]] = result[[D]]
    }
    if (is.null(ragged)) {
        return(result)
    }
    groups = paste("S", substr(groups, 2, nchar(groups)), sep = "")
    randomEffects = groups[groups %in% names(ragged)]
    randomEffects = names(sort(unlist(lapply(ragged[randomEffects],
        length))))
    randomEffects = substr(randomEffects, 2, nchar(randomEffects))
    if (!length(randomEffects)) {
        warning(paste(toString(groups), ":cannot find random effects"))
        return(result)
    }
    theMeanOld = array(result[["intercept"]], c(dim(result[["intercept"]]),
        1))
    Nchain = dim(theMeanOld)[2]
    torep = rep(1, length(ragged[[paste("S", randomEffects[1],
        sep = "")]]) - 1)
    betanames = dimnames(result$betas)[[3]]
    for (D in randomEffects) {
        theR = paste("R", D, sep = "")
        theS = ragged[[paste("S", D, sep = "")]]
        thenames = names(theS)[-length(theS)]
        if (length(thenames) != (dim(result[[theR]])[3]))
            warning(D, "different dimensions in bugsResult and ragged")
        dimnames(result[[theR]])[[3]] = thenames
        dimnames(result[[paste("Fitted", theR, sep = "")]])[[3]] = thenames
        DX = paste("X", D, sep = "")
        Dbeta = paste("beta", D, sep = "")
        themean = theMeanOld[, , torep]
        if (!is.null(ragged[[DX]])) {
            theX = t(ragged[[DX]])
            if (Dbeta %in% betanames) {
                theseBetas = result$betas[, , Dbeta, drop = F]
            }
            else {
                if (all(rownames(theX) %in% dimnames(result$betas)[[3]])) {
                  theseBetas = result$betas[, , rownames(theX),
                    drop = FALSE]
                }
                else {
                  warning("cannot find ", D, " , ", DX)
                }
            }
            for (Dchain in 1:Nchain) {
                themean[, Dchain, ] = themean[, Dchain, ] + abind::adrop(theseBetas[,
                  Dchain, , drop = FALSE], drop = 2) %*% theX
            }
        }
        theMeanOld = result[[theR]]
        torep = diff(theS)
        torep = rep(1:length(torep), torep)
        result[[theR]] = result[[theR]] - themean
    }
    spatialEffects = paste("R", randomEffects, "Spatial", sep = "")
    spatialEffects = spatialEffects[spatialEffects %in% names(result)]
    for (D in spatialEffects) {
        DsubR = gsub("Spatial$", "", D)
        Dsub = gsub("^R", "", DsubR)
        Dfitted = paste("Fitted", DsubR, sep = "")
        thenames = names(ragged[[paste("num", Dsub, sep = "")]])
        if (is.null(thenames)) {
            thenames = paste("noname", 1:ragged[[paste("N", Dsub,
                "Spatial", sep = "")]], sep = "")
            thenames[ragged[[paste("Sspatial", Dsub, sep = "")]]] = names(ragged[[paste("Sspatial",
                Dsub, sep = "")]])
        }
        theID = dimnames(result[[D]])[[3]]
        theID = gsub("[[:graph:]]+\\[", "", theID)
        theID = gsub("\\]$", "", theID)
        dimnames(result[[D]])[[3]] = thenames[as.integer(theID)]
        regionsNoV = thenames[!thenames %in% dimnames(result[[DsubR]])[[3]]]
        if (length(regionsNoV)) {
            dimNoV = c(dim(result$intercept), length(regionsNoV))
            sdBig = array(result[[paste("SD", Dsub, sep = "")]],
                dimNoV)
            VfornoV = stats::rnorm(prod(dim(sdBig)), 0, sdBig)
            VfornoV = array(VfornoV, dimNoV)
            dimnames(VfornoV)[[3]] = regionsNoV
            DsubSpatial = paste(DsubR, "Spatial", sep = "")
            withSpatial = regionsNoV[regionsNoV %in% dimnames(result[[DsubSpatial]])[[3]]]
            VfornoV[, , withSpatial] = VfornoV[, , withSpatial] +
                result[[DsubSpatial]][, , withSpatial]
            result[[DsubR]] = abind::abind(result[[DsubR]], VfornoV,
                along = 3)
            fittedForNoV = VfornoV + array(result$intercept,
                dimNoV)
            if (!is.null(extraX)) {
                haveExtraX = rownames(extraX)[rownames(extraX) %in%
                  VfornoV]
                theBeta = result[[paste("beta", Dsub, sep = "")]]
                haveBeta = colnames(extraX)[colnames(extraX) %in%
                  rownames(theBeta)]
                if (length(haveExtraX) & length(haveBeta)) {
                  fittedForNoV = fittedForNoV + extraX[haveExtraX,
                    haveBeta] %*% theBeta[haveBeta, ]
                }
            }
            result[[Dfitted]] = abind::abind(result[[Dfitted]],
                fittedForNoV, along = 3)
            result[[DsubR]] = result[[DsubR]][, , thenames]
            result[[Dfitted]] = result[[Dfitted]][, , thenames]
        }
    }
    #if (dim(result$betas)[3] == 1) {
    #    result$betas = result$betas[, , 1]
    #}
    return(result)
}


1.,
+1.,
-1.,
1.0,
+1.0,
-1.0,
.1,
+.1,
-.1,
1E,
+1E,
-1E,
1e,
+1e,
-1e,
1e1,
1e+1,
+1e+1,
-1e+1,
1e-1,
+1e-1,
-1e-1,
1.e1,
+1.e1,
-1.e1,
1.0e1,
+1.0e1,
-1.0e1,
.1e1,
+.10e1,
-.1e1,
2.367,
23.56E+17,
.4567e-12,
00.00,
0001.00000000000000e-1000000000,


# Investigating Dengue RDT sensitivity and specificty requirements
# written by Stefan Flasche using R version 3.4.4
# results published in "On the importance of sensitivity and the negative predictive value for a rapid dengue test" by S. Flasche and P.G. Smith

# load packages
require(tidyverse)

# Data --------------------------------------------------------------------

# data: cumulative incidence over 5yrs observed in the trial and its stratification into
#       seropositive and seronegative using PRNT50 with multiple imputation (in per 100).
df <- tibble(no=1:8,
             randomisation = c("vacc","vacc","control","control","vacc","vacc","control","control"),
             serostatus = c("pos","neg","pos","neg","pos","neg","pos","neg"),
             outcome = c(rep("hosp",4),rep("severe",4)),
             incidence.ph.mid = c(.375,1.571,1.883,1.093,0.075,0.404,0.48,0.174),
             incidence.ph.lo = c(.263,1.125,1.536,.526,0.034,0.218,0.335,0.036),
             incidence.ph.hi = c(.535,2.193,2.307,2.265,0.165,0.749,0.688,0.834))

# plot data
p.data <- df %>% ggplot(aes(x= serostatus, y = incidence.ph.mid, ymin = incidence.ph.lo, ymax = incidence.ph.hi,color=randomisation)) +
  geom_linerange(position=position_dodge(width = 0.5)) +
  geom_point(position=position_dodge(width = 0.5)) +
  facet_grid(.~outcome, scales = "free") +
  coord_flip() + ylab("incidence per 100") +
  labs(y = "Incidence per 100", x = "Serostatus", color = "Randomisation")
ggsave(filename = "Pics\\Fig1_Data.tiff",p.data ,unit="cm", width = 14, height = 5, compression = "lzw", dpi = 300)

# sample from lognormal distribution in which the 50%, 2.5% and 97.5% quanitles fit the observed mean, CI.lo and CI.hi respectively
LnfitSample <- function(input= c(mean=1, lo=.5, hi=2), N=10000){
  mean = input[1] %>% as.numeric()
  lo = input[2] %>% as.numeric()
  hi = input[3] %>% as.numeric()
  rlnorm(N, meanlog = log(mean), sdlog = (log(mean/lo) +  log(hi/mean))/2/1.96) %>%
    return()
}

# Population impact of test and vaccinate ---------------------------------------------

# calculate population impact of test and vaccinate strategy
## need to include resampling of incidence
CasesAverted <- function(seroPrevalence = .7, sensitivity = 1, specificity = 0,
                         cohortSize=100000, df.tmp = df, outcm = "hosp"){
  df.tmp = df.tmp %>% filter(outcome == outcm)
  Inc.SeroPos.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="pos") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  Inc.SeroPos.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="pos") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  Inc.SeroNeg.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="neg") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  Inc.SeroNeg.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="neg") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()

  CasesAvertedSeroPos = cohortSize * seroPrevalence * sensitivity * (Inc.SeroPos.Cont - Inc.SeroPos.Vacc) / 100
  CasesAvertedSeroNeg = cohortSize * (1-seroPrevalence) * (1 - specificity) * (Inc.SeroNeg.Cont - Inc.SeroNeg.Vacc) /100

  df_res <- tibble(seroPrevalence = seroPrevalence, sensitivity = sensitivity,
                   specificity = specificity, outcome = outcm,
                   CasesAvertedSeroPos.mid = median(CasesAvertedSeroPos),
                   CasesAvertedSeroPos.lo = quantile(CasesAvertedSeroPos,.025),
                   CasesAvertedSeroPos.hi = quantile(CasesAvertedSeroPos,.975),
                   CasesAvertedSeroNeg.mid = median(CasesAvertedSeroNeg),
                   CasesAvertedSeroNeg.lo = quantile(CasesAvertedSeroNeg,.025),
                   CasesAvertedSeroNeg.hi = quantile(CasesAvertedSeroNeg,.975),
                   CasesAvertedTotal.mid =  median(CasesAvertedSeroPos + CasesAvertedSeroNeg),
                   CasesAvertedTotal.lo = quantile(CasesAvertedSeroPos + CasesAvertedSeroNeg, .025),
                   CasesAvertedTotal.hi = quantile(CasesAvertedSeroPos + CasesAvertedSeroNeg, .975))
  return(df_res)
}

# plot impact of test and vaccinate strategy
df.plt = NULL
for(seroPrevalence in c(.6,.7,.8)){
  for(specificity in c(.9,.95,.98,.99,1)){
    for(sensitivity in seq(.8,1,by=.05)){
      df.plt <- df.plt %>%
        rbind(CasesAverted(seroPrevalence = seroPrevalence, sensitivity = sensitivity, specificity = specificity))
    }
  }
}

df.plt <- df.plt %>%
  gather(key,value, -seroPrevalence, -sensitivity, -specificity, -outcome) %>%
  extract(key, c("outcome","conf"),"(.*)\\.(.*)") %>%
  spread(conf, value)

p.tandv = df.plt %>% ggplot(aes(x=sensitivity, y = mid, ymin=lo, ymax= hi, color = as.factor(seroPrevalence))) +
  geom_linerange(position = position_dodge(width = 0.04)) +
  geom_point(position = position_dodge(width = 0.04)) +
  facet_grid(outcome ~ specificity, scales = "free") +
  scale_color_discrete(name="seroprevalence") + ylab("hospitalised dengue cases averted\nin a 100,000 cohort") +
  geom_hline(yintercept = 0, color="black", lty="dashed")
ggsave(filename = "Pics\\Fig2_Impact_TandV.tiff",p.tandv ,unit="cm", width = 25, height = 14, compression = "lzw", dpi = 300)

# Impact of sensitivity --------------------------------------------------------------------

# calculate sensitivity needed to avoid chosing to vaccinate test negative
TestNegRatio <- function(seroPrevalence = .7, sensitivity = .8, specificity = .95,
                             df.tmp = df, outcm = "hosp", midonly=F){
  df.tmp = df.tmp %>% filter(outcome == outcm)
  if(midonly){
    Inc.SeroPos.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="pos") %>%
      select(incidence.ph.mid) %>% as.numeric()
    Inc.SeroPos.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="pos") %>%
      select(incidence.ph.mid) %>% as.numeric()
    Inc.SeroNeg.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="neg") %>%
      select(incidence.ph.mid) %>% as.numeric()
    Inc.SeroNeg.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="neg") %>%
      select(incidence.ph.mid) %>% as.numeric()
  }else{
    Inc.SeroPos.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="pos") %>%
      select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
    Inc.SeroPos.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="pos") %>%
      select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
    Inc.SeroNeg.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="neg") %>%
      select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
    Inc.SeroNeg.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="neg") %>%
      select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  }

  risk.if.testNeg.vacc <- ((1-seroPrevalence) * specificity *  Inc.SeroNeg.Vacc +
    seroPrevalence * (1-sensitivity) * Inc.SeroPos.Vacc ) /
    ((1-seroPrevalence) * specificity  + seroPrevalence * (1-sensitivity) )
  risk.if.testNeg.nova <- ((1-seroPrevalence) * specificity *  Inc.SeroNeg.Cont +
    seroPrevalence * (1-sensitivity) * Inc.SeroPos.Cont ) /
    ((1-seroPrevalence) * specificity  + seroPrevalence * (1-sensitivity) )

  df_res <- tibble(seroPrevalence = seroPrevalence, sensitivity = sensitivity,
                   specificity = specificity, outcome = outcm,
                   riskiftestNegvacc.mid = median(risk.if.testNeg.vacc),
                   riskiftestNegnova.mid = median(risk.if.testNeg.nova),
                   riskiftestNegvacc.lo = quantile(risk.if.testNeg.vacc,.025),
                   riskiftestNegvacc.hi = quantile(risk.if.testNeg.vacc,.975),
                   riskiftestNegnova.lo = quantile(risk.if.testNeg.nova,.025),
                   riskiftestNegnova.hi = quantile(risk.if.testNeg.nova,.975),
                   RR.mid =  median(risk.if.testNeg.vacc / risk.if.testNeg.nova),
                   RR.lo = quantile(risk.if.testNeg.vacc / risk.if.testNeg.nova, .025),
                   RR.hi = quantile(risk.if.testNeg.vacc / risk.if.testNeg.nova, .975))
  return(df_res)
}

# analyse where test nagative vacc vs novacc risks are for a number of scenarios
df.plt = NULL
for(seroPrevalence in c(.5,.7,.9)){
  for(specificity in c(.95,1)){
    for(sensitivity in seq(.6,1,by=.1)){
      df.plt <- df.plt %>%
        rbind(TestNegRatio(seroPrevalence = seroPrevalence, sensitivity = sensitivity, specificity = specificity)) %>%
        rbind(TestNegRatio(seroPrevalence = seroPrevalence, sensitivity = sensitivity, specificity = specificity, outcm = "severe"))

    }
  }
}

p.sens <- df.plt %>%
  ggplot(aes(x=sensitivity, y = RR.mid, ymin=RR.lo, ymax= RR.hi, color=outcome)) +
  geom_linerange(position = position_dodge(width = 0.04)) +
  geom_point(position = position_dodge(width = 0.04)) +
  facet_grid(seroPrevalence ~ specificity, scales = "free") +
  scale_y_log10() + geom_hline(yintercept = 1, color="black", lty="dashed") +
  scale_color_discrete(name="outcome") +
  ylab("RR for hospitalised dengue\nin test-negative for\nvaccination vs no vaccination")
ggsave(filename = "Pics\\FigX_SensitivityImpact.tiff",p.sens ,unit="cm", width = 20, height = 12, compression = "lzw", dpi = 300)

# analyse where test nagative vacc vs novacc risks - map
df.plt2 = NULL
for(seroPrevalence in c(.5,.6,.7,.8,.9)){
  for(specificity in seq(.9,1,by=.01)){
    for(sensitivity in seq(.6,1,by=.01)){
      df.plt2 <- df.plt2 %>%
        rbind(TestNegRatio(seroPrevalence = seroPrevalence, sensitivity = sensitivity, specificity = specificity, midonly=T)) %>%
        rbind(TestNegRatio(seroPrevalence = seroPrevalence, sensitivity = sensitivity, specificity = specificity, outcm = "severe", midonly=T))

    }
  }
}

p.sens.b <- df.plt2 %>%
  ggplot(aes(x=sensitivity, y=specificity, fill = RR.mid)) +
  facet_grid(seroPrevalence ~ outcome) +
  geom_tile() +
  scale_fill_gradient2(name="RR in vaccinees\nvs controls", low = "green", mid = "yellow",
                       high = "red", midpoint = 0, breaks=round(c(.5,1/1.2,1/1.1,1,1.1,1.2,2),2),trans = "log", limits=c(1/1.21,1.2)) +
  theme_bw() +
  labs(x = "Sensitivity", y = "Specificity")
ggsave("Pics\\Fig3a_SensitivityImpactMap.tiff", p.sens.b, width = 20, height = 13, units = "cm", compression="lzw", dpi =300)

# importance of NPV ---------------------------------------------
TestNegRatio.NPV <- function(NPV = .7, df.tmp = df, outcm = "hosp"){
  df.tmp = df.tmp %>% filter(outcome == outcm)

  Inc.SeroPos.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="pos") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  Inc.SeroPos.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="pos") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  Inc.SeroNeg.Vacc <- df.tmp %>% filter(randomisation=="vacc" & serostatus =="neg") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()
  Inc.SeroNeg.Cont <- df.tmp %>% filter(randomisation=="control" & serostatus =="neg") %>%
    select(incidence.ph.mid:incidence.ph.hi) %>% LnfitSample()

  risk.if.testNeg.vacc <- ( NPV * Inc.SeroNeg.Vacc +
                            (1-NPV) * Inc.SeroPos.Vacc )
  risk.if.testNeg.nova <- ( NPV * Inc.SeroNeg.Cont +
                            (1-NPV) * Inc.SeroPos.Cont )

  df_res <- tibble(NPV = NPV, outcome = outcm,
                   riskiftestNegvacc.mid = median(risk.if.testNeg.vacc),
                   riskiftestNegnova.mid = median(risk.if.testNeg.nova),
                   riskiftestNegvacc.lo = quantile(risk.if.testNeg.vacc,.025),
                   riskiftestNegvacc.hi = quantile(risk.if.testNeg.vacc,.975),
                   riskiftestNegnova.lo = quantile(risk.if.testNeg.nova,.025),
                   riskiftestNegnova.hi = quantile(risk.if.testNeg.nova,.975),
                   RR.mid =  median(risk.if.testNeg.vacc / risk.if.testNeg.nova),
                   RR.lo = quantile(risk.if.testNeg.vacc / risk.if.testNeg.nova, .025),
                   RR.hi = quantile(risk.if.testNeg.vacc / risk.if.testNeg.nova, .975))
  return(df_res)
}

df.plt.NPV = NULL
for( NPV in seq(.5,1,by=0.01)){
  df.plt.NPV = df.plt.NPV %>%
    rbind(TestNegRatio.NPV(NPV)) %>%
    rbind(TestNegRatio.NPV(NPV, outcm = "severe"))
}
df.plt.NPV$outcome = df.plt.NPV$outcome %>% str_replace("hosp","Hospitalised")
df.plt.NPV$outcome = df.plt.NPV$outcome %>% str_replace("severe","Severe")
df.plt.NPV %>%
  ggplot(aes(x=NPV, y=RR.mid, ymin=RR.lo, ymax=RR.hi, group=outcome, color=outcome, fill=outcome)) +
  geom_ribbon(alpha=0.2, color=NA) +
  geom_line() +
  geom_hline(yintercept = 1, color = "black", lty = "dashed") +
  #facet_grid(outcome~., scales="free") +
  scale_y_log10() +
  labs(x = "Negative predictive value", y = "RR for\nsevere or hospitalised disease \nin test-negative for\nvaccination vs no vaccination",
        fill = "Outcome", color = "Outcome") +
  theme_bw()+
  guides(group=F)
ggsave("Pics\\Fig3b_NPVimpact.tiff", width = 13, height = 7, units = "cm", compression="lzw", dpi =1000)
ggsave("Pics\\Fig3b_NPVimpact.pdf", width = 13, height = 7, units = "cm")

# calculate min sens needed ---------------------------------------------

get_PV <- function(specificity=.9, sensitivity=.7, seroprevalence=0.7 ){
  tp= sensitivity * seroprevalence
  fn= (1-sensitivity) * seroprevalence
  tn= specificity * (1-seroprevalence)
  fp= (1-specificity) * (1-seroprevalence)

  PPV = tp / (tp+fp) #prop of true positive among all pos
  NPV = tn / (tn+fn) #prop of negative positive among all negative

  df = data.frame(specificity=as.factor(specificity), sensitivity=sensitivity, seroprevalence=seroprevalence, NPV=NPV, PPV=PPV) %>%
    as.tibble()

  return(df)

}

res = NULL
for(specificity in c(.9,.95,.99)){
  for(seroprevalence in seq(0.15,1,by=0.01)){
    for(sensitivity in seq(0,1,by=0.01)){
      res = res %>%
        rbind(get_PV(specificity, sensitivity, seroprevalence))
    }
  }
}
min.PPV = .90
min.NPV = .75 # Ratio for RR forvaccinees to get hospitalised in Seropos vs Seroneg is 1.57/1.09 / 0.375/1.88
p.dat = res %>% group_by(specificity,seroprevalence) %>% mutate(PPV.based = ( PPV == min(PPV + 5*(PPV<min.PPV))),
                                                        NPV.based = ( NPV == min(NPV + 5*(NPV<min.NPV)))) %>%
  filter(PPV.based | NPV.based) %>%
  gather(criteria, value, -specificity, -sensitivity, -seroprevalence, -NPV, -PPV) %>%
  filter (value)
p.dat$criteria = p.dat$criteria %>% str_replace("V.b","V b")
p = p.dat %>%
  ggplot(aes(x=seroprevalence, y=sensitivity, color=criteria, lty = specificity)) +
  geom_line() +
  theme_bw() +
  labs(x = "Seroprevalence", y = "Minimum sensitivity", color = "Criteria", lty = "Specificity") +
  scale_x_continuous(breaks = seq(0.1,1,by=0.2)) +
  scale_y_continuous(breaks = seq(0,1,by=0.2))
ggsave("Pics/RequiredSensitivity.tiff", p, units = "cm",height = 7, width = 13, compression="lzw", dpi=1000)
ggsave("Pics/RequiredSensitivity.pdf", p, units = "cm",height = 7, width = 13)


##########################################################
# R script 1 of: Birds exposed to physiological stress   #
# post-breeding engage in stress-reducing social         #
# interactions in winter flocks                          #

# Generating social network and deriving network metric  #

# author: Lionel Hertzog                                 #
##########################################################

# set wd to the local position of the github repo
setwd("~/Documents/PostDoc_Ghent/Feeder_stuff/network_stress/")

# load packages
library(asnipe)
library(igraph)
library(reshape2)

# 1. Generate the network from the raw feeder data
## note: this analysis takes quite some RAM and some time
## it is included here only for reproducability, you can
## directly get the network from the data/network.csv file

# # load data
feeder_dat <- read.csv("data/feeder_data_formatted.csv")

# get the infos for computing the social network
## the time of the recording
day_hour <- strptime(feeder_dat$day_hour, format = "%Y-%m-%d %H:%M:%S")
day_hour <- as.numeric(day_hour) # turn into integer
day_hour <- day_hour - min(day_hour) # for faster computation

## the transponder id of the bird
bird_id <- feeder_dat$Transponder.code

## the feeder id
feeder_id <- feeder_dat$Feeder_ID

# run gmmevents, this line of code takes a lot of RAM! Beware !!!
# gmm <- gmmevents(day_hour, bird_id, feeder_id, verbose = FALSE)
# save this for the permutation analysis
# saveRDS("data/gmmevent_out_2016_2017.rds")

# get network
# network <- get_network(gmm$gbi)

# # save it in a file
# # write.table(network, "data/network.csv",row.names = FALSE, sep = ",")

# 2. Derive the network indices

## load the network
network <- read.csv("data/network.csv")

## turn it into an igraph object
gg_winter <- graph_from_adjacency_matrix(as.matrix(network), mode = "undirected", weighted = TRUE)

## put all into one data frame
network_metric <- data.frame(bird_tag = gsub("X","",names(V(gg_winter))),
                             betw = log(betweenness(gg_winter, directed = FALSE) + 1),
                             eigen = eigen_centrality(gg_winter)$vector,
                             degree = degree(gg_winter, mode = "all"),
                             strength = strength(gg_winter),
                             stringsAsFactors = FALSE)

# 3. Merge with the stress and other covariate

## load the stress info
stress <- read.csv("data/stress_info.csv")

## merge
network_dat <- merge(network_metric, stress, by = "bird_tag")

## save it in a file
write.table(network_dat,"data/network_dat.csv", row.names = FALSE, sep = ",")


#' Compute metacell using resampling iterations of graph cover k-means-like approach
#'
#' @param mc_id id of metacell object to be added
#' @param graph_id a knn graph object id into scdb
#' @param mat_id a matrix object id
#' @param min_mc_size target minimum metacell size. This is only an approximation and smaller MC may be returned by the algorithm
#' @param resamp_n number of resampling iterations
#'
#' @export
#'
#' @export

mcell_coclust_from_graph_resamp = function(coc_id,
		graph_id,
		min_mc_size, p_resamp, n_resamp)
{
	old_seed = .set_seed(get_param("mc_rseed"))

	tgs_clust_cool = get_param("scm_tgs_clust_cool")
	tgs_clust_burn = get_param("scm_tgs_clust_burn_in")

	graph = scdb_cgraph(graph_id)
	if(is.null(graph)) {
		stop("MC-ERR: cell graph id ", graph_id, " is missing when running add_mc_from_graph")
	}
	message("running bootstrap to generate cocluster")
	edges = graph@edges
	colnames(edges) = c("col1", "col2", "weight")

if(0) {
orig_levels = levels(edges$col1)
edges$col1 <- as.character(edges$col1)
edges$col2 <- as.character(edges$col2)
reduced_levels <- unique(c(as.character(edges$col1),as.character(edges$col2)))
edges$col1<-factor(as.character(edges$col1), levels=reduced_levels)
edges$col2<-factor(as.character(edges$col2), levels=reduced_levels)
}

	K = round(nrow(edges)/length(graph@cell_names))

	resamp = tgs_graph_cover_resample(edges, knn = K, min_mc_size, cooling = tgs_clust_cool, burn_in = tgs_clust_burn, p_resamp = p_resamp, n_resamp = n_resamp, method="full")

#TEMP - fixing a bug with trailing 0 factor values
	resamp$co_cluster = resamp$co_cluster[
						as.numeric(resamp$co_cluster$node1)>0,]
	message("done resampling")
if(0) {
resamp$co_cluster$node1 = factor(as.character(resamp$co_cluster$node1),
															levels=orig_levels)
resamp$co_cluster$node2 = factor(as.character(resamp$co_cluster$node2),
															levels=orig_levels)
}

	scdb_add_coclust(coc_id,
			tgCoClust(graph_id=graph_id, coclust = resamp$co_cluster, n_samp=resamp$samples))

	.restore_seed(old_seed)
}


library(shiny)

library('qrmdata')
library('ggplot2')
library('forecast')
library('tseries')
library('xts')
library('graphics')

xts.to.ts <- function(X, freq = 12L) {
    ts(as.numeric(X),
          start = c(.indexyear(X)[1] + 1900, .indexmon(X)[1] + 1),
          freq = freq)
}

ui <- fluidPage(
  titlePanel("Forecast"),
  sidebarLayout(
    sidebarPanel(
      radioButtons("dataset", "Dataset:",
               c("Gold" = "gold",
                 "British Pound" = "cur_gbp",
                 "Euro" = "cur_eur",
                 "Canadian Dollar" = "cur_can",
                 "Crypto [BTC]" = "crypto_btc",
                 "Crypto [ETH]" = "crypto_eth",
                 "Crypto [XRP]" = "crypto_xrp")),
      radioButtons("method", "Method:",
               c("ETS" = "ets",
                 "ARIMA" = "arima",
                 "ARFIMA" = "arfima",
                 "STL" = "stl",
                 "TBATS" = "tbats"))
    ),
    mainPanel(
      tabsetPanel(type = "tabs",
                  tabPanel("Hist", plotOutput("hist")),
                  tabPanel("Plot", plotOutput("plot"))
      )
    )
  )
)

data("GOLD")
data("crypto")
data("CAD_USD")
data("GBP_USD")
data("EUR_USD")

serverEts <- function(dataset) {
  dataset %>%
    ets() %>%
    forecast()
}

serverArima <- function(dataset) {
  dataset %>%
    auto.arima() %>%
    forecast(h=20)
}

serverArfima <- function(dataset) {
  arfima(dataset) %>%
    forecast(h=30)
}

serverStl <- function(dataset) {
  dataset %>%
    stlm(modelfunction=ar) %>%
    forecast(h=36)
}

serverTbats <- function(dataset) {
  dataset %>%
    tbats() %>%
    forecast()
}

server <- function(input, output) {
  dataset <- reactive({
    data <- switch(input$dataset,
                     cur_gbp = GBP_USD['2010/'],
                     cur_eur = EUR_USD['2010/'],
                     cur_can = CAD_USD['2010/'],
                     crypto_btc = crypto$BTC,
                     crypto_eth = crypto$ETH,
                     crypto_xrp = crypto$XRP,
                     GOLD['2010/'])
    data <- xts.to.ts(data)
    data
  })

  method <- reactive({
    switch(input$method,
                     ets = serverEts,
                     arima = serverArima,
                     arfima = serverArfima,
                     stl = serverStl,
                     serverTbats)
  })

  output$plot <- renderPlot({
    d <- dataset()
    method()(d) %>%
      autoplot()
  })

  output$hist <- renderPlot({
    d <- dataset()
    hist(d)
  })
}

server <- function(input, output) {
  dataset <- reactive({
    dnorm(100)
  })

  output$plot <- renderPlot({
    dataset() %>%
      plot()
  })

  output$hist <- renderPlot({
    dataset() %>%
      hist()
  })
}

shinyApp(ui = ui, server = server)


library(adegenet)

x <- read.structure("certhia_contact_10000b.stru",onerowperind=F,n.ind=24,n.loc=31948,ask=F,sep="\t")

grp <- find.clusters(x,max.n.clust=10,n.iter=1e5) #25 pc, 2 cluster
dapc1 <- dapc(x,grp$grp) # choose 10 pc 1 df
scatter(dapc1,scree.da=F,cex=1.4,clab=0)
compoplot(dapc1)

# read in structure results
x2 <- read.table("structure_results.txt", sep="\t", stringsAsFactors=F)

# sort by population
populations <- c("Utah", "Pinal", "Pinaleno", "SCatalina", "Chiricahua", "SRita", "Huachuca", "Mexico")

# make new matrix
output <- c()
for(a in 1:length(populations)) {
	a_rep1 <- x2[sapply(strsplit(x2[,1], "_"), "[[", 3) == populations[a], ]
	a_rep2 <- dapc1$posterior[sapply(strsplit(x2[,1], "_"), "[[", 3) == populations[a], ]
	output <- rbind(output, cbind(a_rep1, a_rep2))
}

par(mar=c(0.1, 0.1, 0.1, 0.1))
par(mfrow=c(2,1))
barplot(t(as.matrix(output[,2:3])), col=c("red", "blue"))
barplot(t(as.matrix(output[,4:5])), col=c("red", "blue"))