#### Functions for cancer cell fraction estimation #####

identify.mut.copy.number.ascat <- function(x, sub.mat.mut, sub.mat.copy) {
  mut <- sub.mat.mut[x, , drop = FALSE]
  ww <- which(as.numeric(sub.mat.copy$Chr) == as.numeric(mut$Chr)
  & as.numeric(sub.mat.copy$Start) <= as.numeric(mut$Start_position)
  & as.numeric(sub.mat.copy$End) >= as.numeric(mut$Start_position))
  copy <- sub.mat.copy[ww, , drop = FALSE]

  mutation_id <- paste(mut$Patient, mut$Chr, mut$Start_position, mut$Reference, sep = ":")
  ref_counts <- mut$Ref_freq
  var_counts <- mut$Variant_freq
  normal_cn <- 2
  patient <- mut$Patient
  Reference_Base <- mut$Reference
  Alternate_Base <- mut$Alternate

  if (nrow(copy) != 1) {
    minor_cn <- NA
    major_cn <- NA
    output <- data.frame(mutation_id,
      ref_counts,
      var_counts,
      normal_cn,
      minor_cn,
      major_cn,
      patient,
      Reference_Base,
      Alternate_Base,
      stringsAsFactors = FALSE
    )
    return(output)
  }

  minor_cn <- min(c(copy$nA, copy$nB))
  major_cn <- max(c(copy$nA, copy$nB))

  output <- data.frame(mutation_id,
    ref_counts,
    var_counts,
    normal_cn,
    minor_cn,
    major_cn,
    patient,
    Reference_Base,
    Alternate_Base,
    stringsAsFactors = FALSE
  )

  return(output)
}

#######

# earlyORlate <- function(patient, complete.mutation.table, purity) {
#
#
#   # First of all load the needed packaged
#   #
#   suppressPackageStartupMessages(library(sequenza))
#   suppressPackageStartupMessages(library(bootstrap))
#   suppressPackageStartupMessages(library(boot))
#
#   # Get the table ready, with only information for specific patient
#   mut.table <- complete.mutation.table[complete.mutation.table$patient == patient, ]
#
#   # and all the other stuff
#   cellularity <- as.numeric(purity)
#   major.cn <- unlist(mut.table$major_cn)
#   abs.cn <- unlist(mut.table$minor_cn) + unlist(mut.table$major_cn)
#   depth.t <- unlist(mut.table$ref_counts) + unlist(mut.table$var_counts)
#   max.cn <- max(abs.cn)
#   VAF <- unlist(mut.table$var_counts) / (unlist(mut.table$var_counts) + unlist(mut.table$ref_counts))
#
#   # Estimate theoretical VAFs for each type of copy number
#   types <- types.matrix(CNt.min = 1, CNt.max = max.cn, CNn = 2)
#   types.xy <- types.matrix(CNt.min = 1, CNt.max = max.cn, CNn = 1)
#   types <- rbind(types, types.xy)
#   types <- types[types$Mt >= 1, ]
#   types$F <- 0
#   for (i in 1:nrow(types)) {
#     types$F[i] <- theoretical.mufreq(
#       cellularity = cellularity,
#       CNn = types$CNn[i], CNt = types$CNt[i],
#       Mt = types$Mt[i]
#     )
#   }
#
#   # Let's create some functions that can estimate whether early or late
#
#   get.Mt <- function(F, depth.t, types, CNt, CNn, Mt) {
#     types <- types[types$CNn == CNn, ]
#     l <- sequenza:::mufreq.dpois(
#       mufreq = F, types$F[types$CNt == CNt & types$Mt <= Mt],
#       depth.t = depth.t
#     )
#     l <- l / sum(l)
#     L <- data.frame(l = l, Mt = types$Mt[types$CNt == CNt & types$Mt <= Mt])
#   }
#
#   get.conf <- function(F, depth.t) {
#     conf.int <- cbind(
#       prop.test(round(F * depth.t, 0), depth.t)$conf[1],
#       prop.test(round(F * depth.t, 0), depth.t)$conf[2]
#     )
#     return(conf.int)
#   }
#
#   bootstrap.cf <- function(Vaf, cellularity, CNn, CNt, depth.t) {
#     # print(i)
#     if (Vaf == 1) {
#       conf.int <- cbind(
#         prop.test(round(Vaf * depth.t, 0), depth.t)$conf[1],
#         prop.test(round(Vaf * depth.t, 0), depth.t)$conf[2]
#       )
#
#       lower <- get.mut.mult(Vaf = conf.int[1], cellularity = cellularity, CNt = CNt, CNn = CNn)
#       higher <- get.mut.mult(Vaf = conf.int[2], cellularity = cellularity, CNt = CNt, CNn = CNn)
#       conf.int <- cbind(lower, higher)
#       return(conf.int)
#     }
#
#     x <- c(rep(1, round(Vaf * depth.t, 0)), rep(0, (depth.t - round(Vaf * depth.t, 0))))
#     theta <- function(x, i) {
#       data <- x[i]
#       est <- sum(data) / length(data)
#       mut.multi <- (est * 1 / cellularity) * ((cellularity * CNt) + CNn * (1 - cellularity))
#       return(mut.multi)
#     }
#
#     bt.res <- boot(x, theta, R = 1000)
#     bt.ci <- boot.ci(bt.res, type = "norm")
#     out <- c(bt.ci$normal[2], bt.ci$normal[3])
#
#     return(out)
#   }
#
#
#   get.mut.mult <- function(CNt, Vaf, cellularity, CNn) {
#     return((Vaf * 1 / cellularity) * ((cellularity * CNt) + CNn * (1 - cellularity)))
#   }
#
#
#   get.cancer.cell.fraction <- function(Max.Likelihood, mut.mult) {
#     predicted.Mtn <- Max.Likelihood[, "Mt"]
#     ccf <- mut.mult / predicted.Mtn
#     return(ccf)
#   }
#
#   absolute.cancer.cell.fraction <- function(n.alt, depth, purity, local.copy.number) {
#     f.function <- function(c, purity, local.copy.number) {
#       return((purity * c) / (2 * (1 - purity) + purity * local.copy.number))
#     }
#     x <- dbinom(n.alt, depth, prob = sapply(seq(0.01, 1, length.out = 100), f.function, purity, local.copy.number))
#     if (min(x) == 0) {
#       x[length(x)] <- 1
#     }
#
#     names(x) <- seq(0.01, 1, length.out = 100)
#     sub.cint <- function(x, prob = 0.95, n.alt, depth) {
#       xnorm <- x / sum(x)
#       xsort <- sort(xnorm, decreasing = TRUE)
#       xcumLik <- cumsum(xsort)
#       n <- sum(xcumLik < prob) + 1
#       LikThresh <- xsort[n]
#       cint <- x[xnorm >= LikThresh]
#       all <- as.numeric(names(x))
#       cellu <- as.numeric(names(cint))
#       l.t <- cellu[1]
#       r.t <- cellu[length(cellu)]
#       m <- cellu[which.max(cint)]
#
#       prob.subclonal <- sum(xnorm[1:90]) # 1-prop.test(n.alt,depth,p=f.function(1,purity,local.copy.number),alternative='less')$p.val
#       prob.clonal <- sum(xnorm[91:100]) # 1-prop.test(n.alt,depth,p=f.function(1,purity,local.copy.number),alternative='greater')$p.val
#
#       data.frame(left = l.t, est = m, right = r.t, prob.subclonal = prob.subclonal, prob.clonal = prob.clonal)
#     }
#
#
#     return(sub.cint(x, n.alt = n.alt, depth = depth))
#   }
#
#   absolute.cancer.cell.mtcpn <- function(n.alt, depth, purity, local.copy.number, mtcpn) {
#     f.function <- function(c, purity, local.copy.number) {
#       return((purity * c) / (2 * (1 - purity) + purity * local.copy.number))
#     }
#     x <- dbinom(n.alt, depth, prob = sapply(seq(0.01, as.numeric(mtcpn), length.out = (100)), f.function, purity, local.copy.number))
#     if (min(x) == 0) {
#       x[length(x)] <- 1
#     }
#
#     names(x) <- seq(0.01, 1, length.out = 100)
#     sub.cint <- function(x, prob = 0.95, n.alt, depth) {
#       xnorm <- x / sum(x)
#       xsort <- sort(xnorm, decreasing = TRUE)
#       xcumLik <- cumsum(xsort)
#       n <- sum(xcumLik < prob) + 1
#       LikThresh <- xsort[n]
#       cint <- x[xnorm >= LikThresh]
#       all <- as.numeric(names(x))
#       cellu <- as.numeric(names(cint))
#       l.t <- cellu[1]
#       r.t <- cellu[length(cellu)]
#       m <- cellu[which.max(cint)]
#
#       prob.subclonal <- sum(xnorm[1:90]) # 1-prop.test(n.alt,depth,p=f.function(1,purity,local.copy.number),alternative='less')$p.val
#       prob.clonal <- sum(xnorm[91:100]) # 1-prop.test(n.alt,depth,p=f.function(1,purity,local.copy.number),alternative='greater')$p.val
#
#       data.frame(left = l.t, est = m, right = r.t, prob.subclonal = prob.subclonal, prob.clonal = prob.clonal)
#     }
#
#
#     return(sub.cint(x, n.alt = n.alt, depth = depth))
#   }
#   # add an absolute estimate of the cancer cell fraction
#
#   get.all.mut.info <- function(i) {
#     # print(i)
#     # First estimate the VAF confidence intervals
#     obs.VAF <- VAF[i]
#     mut.conf.0.05 <- get.conf(F = VAF[i], depth.t = depth.t[i])[1]
#     mut.conf.0.95 <- get.conf(F = VAF[i], depth.t = depth.t[i])[2]
#
#     if (abs.cn[i] == 0) {
#       output <- cbind(obs.VAF,
#         mut.conf.0.05,
#         mut.conf.0.95,
#         mut.multi = NA,
#         mut.multi.0.05 = NA,
#         mut.multi.bstr.0.05 = NA,
#         mut.multi.0.95 = NA,
#         mut.multi.bstr.0.95 = NA,
#         Exp.Cpn = NA,
#         Exp.Cpn.Likelihood = NA,
#         ccf = NA,
#         ccf.0.05 = NA,
#         ccf.btstr.0.05 = NA,
#         ccf.0.95 = NA,
#         ccf.btstr.0.95 = NA,
#         absolute.ccf = NA,
#         absolute.ccf.0.05 = NA,
#         absoltue.ccf.0.95 = NA,
#         prob.subclonal = NA,
#         prob.clonal = NA,
#         timing = "Not.Poss"
#       )
#       return(output)
#     }
#
#     # Next estimate the likelihood relating to which copy number the mutation has
#     L <- get.Mt(
#       F = VAF[i],
#       depth.t = depth.t[i], CNt = abs.cn[i],
#       types = types, CNn = unlist(mut.table$normal_cn[i]),
#       Mt = major.cn[i]
#     )
#
#     # Next determine the mut multiplicity
#     mut.multi <- get.mut.mult(CNt = abs.cn[i], Vaf = VAF[i], cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]))
#     mut.multi.0.05 <- get.mut.mult(CNt = abs.cn[i], Vaf = mut.conf.0.05, cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]))
#     mut.multi.0.95 <- get.mut.mult(CNt = abs.cn[i], Vaf = mut.conf.0.95, cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]))
#     mut.multi.bstr <- bootstrap.cf(Vaf = VAF[i], cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]), CNt = abs.cn[i], depth.t = depth.t[i])
#     mut.multi.bstr.0.05 <- mut.multi.bstr[1]
#     mut.multi.bstr.0.95 <- mut.multi.bstr[2]
#
#     if (is.na(L$l)[1]) {
#       output <- cbind(obs.VAF,
#         mut.conf.0.05,
#         mut.conf.0.95,
#         mut.multi,
#         mut.multi.0.05,
#         mut.multi.bstr.0.05,
#         mut.multi.0.95,
#         mut.multi.bstr.0.95,
#         Exp.Cpn = NA,
#         Exp.Cpn.Likelihood = NA,
#         ccf = NA,
#         ccf.0.05 = NA,
#         ccf.btstr.0.05 = NA,
#         ccf.0.95 = NA,
#         ccf.btstr.0.95 = NA,
#         absolute.ccf = NA,
#         absolute.ccf.0.05 = NA,
#         absoltue.ccf.0.95 = NA,
#         prob.subclonal = NA,
#         prob.clonal = NA,
#         timing = "Not.Poss"
#       )
#       return(output)
#     }
#
#     # Now determine which likelihood should be used
#     Max.Likelihood <- L[which.max(L$l), ]
#     absolute.calc <- absolute.cancer.cell.fraction(n.alt = unlist(mut.table$var_counts)[i], depth = depth.t[i], purity = cellularity, local.copy.number = abs.cn[i])
#     absolute.ccf.0.05 <- absolute.calc[1]
#     absolute.ccf.0.95 <- absolute.calc[3]
#     absolute.ccf <- absolute.calc[2]
#     prob.subclonal <- absolute.calc[4]
#     prob.clonal <- absolute.calc[5]
#
#
#
#
#     # Next determine the cancer cell fraction
#     ccf <- get.cancer.cell.fraction(Max.Likelihood, mut.multi)
#     ccf.0.05 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.0.05)
#     ccf.btstr.0.05 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.bstr.0.05)
#
#     ccf.0.95 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.0.95)
#     ccf.btstr.0.95 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.bstr.0.95)
#
#     # Next determine the late cancer cell fraction
#     # Make sure you also output the theoretical Copy (i.e. what it's closest to using maximum likelihood)
#     expected.copy <- Max.Likelihood[2]
#
#
#     # Finally also make a suggestion about whether the mutation is early late or not possible to tell
#
#
#     if (Max.Likelihood$Mt > 1) {
#       timing <- "early"
#     }
#
#     if (Max.Likelihood$Mt <= 1) {
#       timing <- "late"
#     }
#
#     if (major.cn[i] <= 1) {
#       timing <- "Not.Poss"
#     }
#
#
#
#
#     # Let's put this all together and output it
#     output <- data.frame(obs.VAF,
#       mut.conf.0.05,
#       mut.conf.0.95,
#       mut.multi,
#       mut.multi.0.05,
#       mut.multi.bstr.0.05,
#       mut.multi.0.95,
#       mut.multi.bstr.0.95,
#       Exp.Cpn = Max.Likelihood$Mt,
#       Exp.Cpn.Likelihood = Max.Likelihood$l,
#       ccf,
#       ccf.0.05,
#       ccf.btstr.0.05,
#       ccf.0.95,
#       ccf.btstr.0.95,
#       absolute.ccf,
#       absolute.ccf.0.05,
#       absolute.ccf.0.95,
#       prob.subclonal,
#       prob.clonal,
#       timing,
#       stringsAsFactors = FALSE
#     )
#
#     # output           <- data.frame(output,stringsAsFactors=FALSE)
#     return(output)
#   }
#
#   output <- t(sapply(1:nrow(mut.table), get.all.mut.info))
#   output <- data.frame(output, stringsAsFactors = FALSE)
#
#   colnames(output) <- c(
#     "obs.VAF",
#     "mut.conf.0.05",
#     "mut.conf.0.95",
#     "mut.multi",
#     "mut.multi.0.05",
#     "mut.multi.bstr.0.05",
#     "mut.multi.0.95",
#     "mut.multi.bstr.0.95",
#     "Exp.Cpn",
#     "Exp.Cpn.Likelihood",
#     "ccf",
#     "ccf.0.05",
#     "ccf.btstr.0.05",
#     "ccf.0.95",
#     "ccf.btstr.0.95",
#     "absolute.ccf",
#     "absolute.ccf.0.05",
#     "absolute.ccf.0.95",
#     "prob.subclonal",
#     "prob.clonal",
#     "timing"
#   )
#
#
#   out <- cbind(mut.table, output)
#   return(out)
# }

earlyORlate.strict <- function(patient, complete.mutation.table, purity) {

  # The following function is very similar indeed to the function above
  # However, there is one important difference
  # For this function, copy number states where the minor allele =1 are not classified as late.

  # First of all load the needed packaged
  #
  suppressPackageStartupMessages(library(sequenza))
  suppressPackageStartupMessages(library(bootstrap))
  suppressPackageStartupMessages(library(boot))

  # Get the table ready, with only information for specific patient
  mut.table <- complete.mutation.table[complete.mutation.table$patient == patient, ]

  # and all the other stuff
  cellularity <- as.numeric(purity)
  major.cn <- unlist(mut.table$major_cn)
  abs.cn <- unlist(mut.table$minor_cn) + unlist(mut.table$major_cn)
  minor.cn <- unlist(mut.table$minor_cn)
  depth.t <- unlist(mut.table$ref_counts) + unlist(mut.table$var_counts)
  max.cn <- max(abs.cn)
  VAF <- unlist(mut.table$var_counts) / (unlist(mut.table$var_counts) + unlist(mut.table$ref_counts))

  # Use sequenza to estimate theoretical VAFs for each type of copy number
  types <- types.matrix(CNt.min = 1, CNt.max = max.cn, CNn = 2)
  types.xy <- types.matrix(CNt.min = 1, CNt.max = max.cn, CNn = 1)
  types <- rbind(types, types.xy)
  types <- types[types$Mt >= 1, ]
  types$F <- 0
  for (i in 1:nrow(types)) {
    types$F[i] <- theoretical.mufreq(
      cellularity = cellularity,
      CNn = types$CNn[i], CNt = types$CNt[i],
      Mt = types$Mt[i]
    )
  }

  # Let's create some functions that can estimate whether early or late

  get.Mt <- function(F, depth.t, types, CNt, CNn, Mt) {
    types <- types[types$CNn == CNn, ]
    l <- sequenza:::mufreq.dpois(
      mufreq = F, types$F[types$CNt == CNt & types$Mt <= Mt],
      depth.t = depth.t
    )
    l <- l / sum(l)
    L <- data.frame(l = l, Mt = types$Mt[types$CNt == CNt & types$Mt <= Mt])
  }

  get.conf <- function(F, depth.t) {
    conf.int <- cbind(
      prop.test(round(F * depth.t, 0), depth.t)$conf[1],
      prop.test(round(F * depth.t, 0), depth.t)$conf[2]
    )
    return(conf.int)
  }

  bootstrap.cf <- function(Vaf, cellularity, CNn, CNt, depth.t) {
    # print(i)
    if (Vaf == 1) {
      conf.int <- cbind(
        prop.test(round(Vaf * depth.t, 0), depth.t)$conf[1],
        prop.test(round(Vaf * depth.t, 0), depth.t)$conf[2]
      )

      lower <- get.mut.mult(Vaf = conf.int[1], cellularity = cellularity, CNt = CNt, CNn = CNn)
      higher <- get.mut.mult(Vaf = conf.int[2], cellularity = cellularity, CNt = CNt, CNn = CNn)
      conf.int <- cbind(lower, higher)
      return(conf.int)
    }

    x <- c(rep(1, round(Vaf * depth.t, 0)), rep(0, (depth.t - round(Vaf * depth.t, 0))))
    theta <- function(x, i) {
      data <- x[i]
      est <- sum(data) / length(data)
      mut.multi <- (est * 1 / cellularity) * ((cellularity * CNt) + CNn * (1 - cellularity))
      return(mut.multi)
    }

    bt.res <- boot(x, theta, R = 1000)
    bt.ci <- boot.ci(bt.res, type = "norm")
    out <- c(bt.ci$normal[2], bt.ci$normal[3])

    return(out)
  }

  get.mut.mult <- function(CNt, Vaf, cellularity, CNn) {
    return((Vaf * 1 / cellularity) * ((cellularity * CNt) + CNn * (1 - cellularity)))
  }

  get.cancer.cell.fraction <- function(Max.Likelihood, mut.mult) {
    predicted.Mtn <- Max.Likelihood[, "Mt"]
    ccf <- mut.mult / predicted.Mtn
    return(ccf)
  }

  get.all.mut.info <- function(i) {
    # print(i)
    # First estimate the VAF confidence intervals
    obs.VAF <- VAF[i]
    mut.conf.0.05 <- get.conf(F = VAF[i], depth.t = depth.t[i])[1]
    mut.conf.0.95 <- get.conf(F = VAF[i], depth.t = depth.t[i])[2]

    if (abs.cn[i] == 0) {
      output <- cbind(obs.VAF,
        mut.conf.0.05,
        mut.conf.0.95,
        mut.multi = NA,
        mut.multi.0.05 = NA,
        mut.multi.bstr.0.05 = NA,
        mut.multi.0.95 = NA,
        mut.multi.bstr.0.95 = NA,
        Exp.Cpn = NA,
        Exp.Cpn.Likelihood = NA,
        ccf = NA,
        ccf.0.05 = NA,
        ccf.btstr.0.05 = NA,
        ccf.0.95 = NA,
        ccf.btstr.0.95 = NA,
        timing = "Not.Poss"
      )
      return(output)
    }

    # Next estimate the likelihood relating to which copy number the mutation has
    L <- get.Mt(
      F = VAF[i],
      depth.t = depth.t[i], CNt = abs.cn[i],
      types = types, CNn = unlist(mut.table$normal_cn[i]),
      Mt = major.cn[i]
    )

    # Next determine the mut multiplicity
    mut.multi <- get.mut.mult(CNt = abs.cn[i], Vaf = VAF[i], cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]))
    mut.multi.0.05 <- get.mut.mult(CNt = abs.cn[i], Vaf = mut.conf.0.05, cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]))
    mut.multi.0.95 <- get.mut.mult(CNt = abs.cn[i], Vaf = mut.conf.0.95, cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]))
    mut.multi.bstr <- bootstrap.cf(Vaf = VAF[i], cellularity = cellularity, CNn = unlist(mut.table$normal_cn[i]), CNt = abs.cn[i], depth.t = depth.t[i])
    mut.multi.bstr.0.05 <- mut.multi.bstr[1]
    mut.multi.bstr.0.95 <- mut.multi.bstr[2]

    if (is.na(L$l)[1]) {
      output <- cbind(obs.VAF,
        mut.conf.0.05,
        mut.conf.0.95,
        mut.multi,
        mut.multi.0.05,
        mut.multi.bstr.0.05,
        mut.multi.0.95,
        mut.multi.bstr.0.95,
        Exp.Cpn = NA,
        Exp.Cpn.Likelihood = NA,
        ccf = NA,
        ccf.0.05 = NA,
        ccf.btstr.0.05 = NA,
        ccf.0.95 = NA,
        ccf.btstr.0.95 = NA,
        timing = "Not.Poss"
      )
      return(output)
    }

    # Now determine which likelihood should be used
    Max.Likelihood <- L[which.max(L$l), ]

    # Next determine the cancer cell fraction
    ccf <- get.cancer.cell.fraction(Max.Likelihood, mut.multi)
    ccf.0.05 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.0.05)
    ccf.btstr.0.05 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.bstr.0.05)

    ccf.0.95 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.0.95)
    ccf.btstr.0.95 <- get.cancer.cell.fraction(Max.Likelihood, mut.multi.bstr.0.95)

    # Next determine the late cancer cell fraction
    # Make sure you also output the theoretical Copy (i.e. what it's closest to using maximum likelihood)
    expected.copy <- Max.Likelihood[2]

    # Finally also make a suggestion about whether the mutation is early late or not possible to tell

    timing <- "Not.Poss"

    if (Max.Likelihood$Mt > 1) {
      timing <- "early"
    }

    if (Max.Likelihood$Mt <= 1 & minor.cn[i] != 1) {
      timing <- "late"
    }

    if (major.cn[i] <= 1) {
      timing <- "Not.Poss"
    }

    # Let's put this all together and output it
    output <- cbind(obs.VAF,
      mut.conf.0.05,
      mut.conf.0.95,
      mut.multi,
      mut.multi.0.05,
      mut.multi.bstr.0.05,
      mut.multi.0.95,
      mut.multi.bstr.0.95,
      Exp.Cpn = Max.Likelihood$Mt,
      Exp.Cpn.Likelihood = Max.Likelihood$l,
      ccf,
      ccf.0.05,
      ccf.btstr.0.05,
      ccf.0.95,
      ccf.btstr.0.95,
      timing
    )

    return(output)
  }

  output <- t(sapply(1:nrow(mut.table), get.all.mut.info))

  colnames(output) <- c(
    "obs.VAF",
    "mut.conf.0.05",
    "mut.conf.0.95",
    "mut.multi",
    "mut.multi.0.05",
    "mut.multi.bstr.0.05",
    "mut.multi.0.95",
    "mut.multi.bstr.0.95",
    "Exp.Cpn",
    "Exp.Cpn.Likelihood",
    "ccf",
    "ccf.0.05",
    "ccf.btstr.0.05",
    "ccf.0.95",
    "ccf.btstr.0.95",
    "timing"
  )

  out <- cbind(mut.table, output)
  return(out)
}

#### Plotting ######
plot.EarlyOrLate <- function(seg.mat.patient,
                             TCGA.earlyLate,
                             TCGA.purity,
                             TCGA.barcode,
                             max.cpn = 5,
                             min.probes = 10,
                             sub.clonal = 1) {
  seg.mat.patient$Chromosome <- as.numeric(as.character(seg.mat.patient$Chromosome))
  seg.mat.patient$StartPosition <- as.numeric(as.character(seg.mat.patient$StartPosition))
  seg.mat.patient$EndPosition <- as.numeric(as.character(seg.mat.patient$EndPosition))
  seg.mat.patient$nr.probes <- as.numeric(as.character(seg.mat.patient$nr.probes))

  chrom.length.copy <- fun.chrom.length(seg.mat.patient[, 2:4])
  chrom.segs <- fun.add.chrom(seg.mat.patient[, 2:4], chrom.length.copy)
  seg.mat.plot <- seg.mat.patient
  seg.mat.plot[, 2:4] <- chrom.segs
  major <- seg.mat.plot$Copy.Number - seg.mat.plot$min.allele
  seg.mat.plot <- cbind(seg.mat.plot, major)
  seg.mat.plot <- seg.mat.plot[seg.mat.plot$nr.probes >= min.probes, ]

  # Order correctly
  TCGA.plot <- TCGA.earlyLate
  Chromosome <- as.numeric(do.call(rbind, strsplit(unlist(TCGA.earlyLate$mutation_id), split = ":"))[, 2])
  Start_pos <- as.numeric(do.call(rbind, strsplit(unlist(TCGA.earlyLate$mutation_id), split = ":"))[, 3])
  TCGA.plot <- cbind(TCGA.plot, Chromosome, Start_pos)
  TCGA.plot <- data.frame(apply(TCGA.plot, 2, unlist), stringsAsFactors = FALSE)

  min.x <- 0
  min.y <- -0.25
  max.y <- max.cpn + 1
  max.x <- as.numeric(max(seg.mat.plot$EndPosition))

  # Make sure any copy numbers that are too high are still included
  seg.mat.plot$major <- ifelse(seg.mat.plot$major > max.cpn, max.cpn, seg.mat.plot$major)
  seg.mat.plot$min.allele <- ifelse(seg.mat.plot$min.allele > max.cpn, max.cpn, seg.mat.plot$min.allele)
  TCGA.plot$mut.multi <- ifelse(TCGA.plot$mut.multi > max.cpn, max.cpn, TCGA.plot$mut.multi)

  # layout(rbind(1,2))
  # par(mar=c(5,5,5,5))
  plot(1,
    xlim = c(min.x, max.x),
    ylim = c(min.y, max.y),
    type = "n",
    xaxt = "n",
    yaxs = "i",
    yaxt = "n",
    xaxs = "i",
    ylab = "",
    xlab = "",
    lwd = 2,
    bty = "n"
  )

  box(lwd = 0.5)

  axis(
    side = 2,
    at = seq(0, max.cpn, by = 1),
    labels = c(seq(0, max.cpn - 1, by = 1), paste(">", max.cpn, sep = "")),
    las = 2,
    cex.axis = 0.7,
    lwd = 0.5
  )

  mtext(
    text = TCGA.barcode,
    side = 3,
    line = 2
  )

  # Now plot each segment
  fun.plot.segment <- function(x, seg.mat.plot) {
    # print(x)
    # start with major allele
    x0 <- as.numeric(seg.mat.plot[x, "StartPosition"])
    x1 <- as.numeric(seg.mat.plot[x, "EndPosition"])
    y0 <- seg.mat.plot[x, "major"] + 0.05
    y1 <- y0

    segments(x0, y0, x1, y1, col = "black", lwd = 2.4)

    x0 <- as.numeric(seg.mat.plot[x, "StartPosition"])
    x1 <- as.numeric(seg.mat.plot[x, "EndPosition"])
    y0 <- as.numeric(seg.mat.plot[x, "min.allele"]) - 0.05
    y1 <- y0

    segments(x0, y0, x1, y1, col = "#009E73", lwd = 2.4)
  }

  sapply(1:nrow(seg.mat.plot), fun.plot.segment, seg.mat.plot)
  # Draw lines to separate the different chromosomes
  for (i in sort(unique(as.numeric(seg.mat.plot$Chromosome))))
  {
    abline(
      v = max(as.numeric(seg.mat.plot[seg.mat.plot$Chromosome == i, "EndPosition"])),
      lwd = 0.5
    )
    # ,lty='dashed')
  }

  # We need to update the
  TCGA.plot <- TCGA.plot[order(as.numeric(TCGA.plot$Chromosome), as.numeric(TCGA.plot$Start_pos)), ]

  TCGA.plot$Start_pos <- as.numeric(fun.add.chrom(cbind(TCGA.plot$Chromosome, TCGA.plot$Start_pos, TCGA.plot$Start_pos), chrom.length.copy)[, 2])

  # Let's add the mutations
  # Start with early mutations
  early.muts <- TCGA.plot[TCGA.plot$timing %in% c("early"), ]
  early.clonal <- early.muts[early.muts$absoltue.ccf.0.95 >= sub.clonal, ]
  early.subclonal <- early.muts[early.muts$absoltue.ccf.0.95 < sub.clonal, ]

  late.muts <- TCGA.plot[TCGA.plot$timing %in% c("late"), ]
  late.clonal <- late.muts[late.muts$absoltue.ccf.0.95 >= sub.clonal, ]
  late.subclonal <- late.muts[late.muts$absoltue.ccf.0.95 < sub.clonal, ]

  nontimed.muts <- TCGA.plot[!TCGA.plot$mutation_id %in% c(early.muts$mutation_id, late.muts$mutation_id), ]
  nontimed.clonal <- nontimed.muts[nontimed.muts$absoltue.ccf.0.95 >= sub.clonal, ]
  nontimed.subclonal <- nontimed.muts[nontimed.muts$absoltue.ccf.0.95 < sub.clonal, ]

  # let's determine early or late or not possible
  plot.earlyORlateCol <- function(x, timed.muts, nontimed = FALSE) {
    # print(x)
    mut <- timed.muts[x, , drop = FALSE]

    # fix bug: some data of mut.multi.bstr.0.95 are NA, which will induce to error.
    if (any(is.na(mut$mut.multi.bstr.0.95))) {
      return(NULL)
    }

    # determine cell multiplicity
    mut.multiplicity <- mut$mut.multi
    # mut.multiplicity <- mut.multiplicity*(as.numeric(mut$minor_cn)+as.numeric(mut$major_cn))

    if (nontimed) {
      if (as.numeric(mut$mut.multi.bstr.0.95) < sub.clonal) {
        points(mut$Start_pos,
          mut.multiplicity,
          cex = 0.7,
          pch = 17,
          col = "#99999965"
        ) # cannot be determined
      }

      if (as.numeric(mut$mut.multi.bstr.0.95) >= sub.clonal) {
        points(mut$Start_pos,
          mut.multiplicity,
          cex = 0.8,
          pch = 16,
          col = "#99999995"
        ) # cannot be determined
      }
    }

    if (!nontimed) {
      # is it an early event?
      if (mut$timing == "early") {
        # is it subclonal
        if (as.numeric(mut$mut.multi.bstr.0.95) < sub.clonal) {
          points(mut$Start_pos,
            mut.multiplicity,
            cex = 0.7,
            pch = 17,
            col = "#0072B245"
          ) # early event
        }

        # is it clonal
        if (as.numeric(mut$mut.multi.bstr.0.95) >= sub.clonal) {
          points(mut$Start_pos,
            mut.multiplicity,
            cex = 0.9,
            pch = 16,
            col = "#0072B295"
          ) # early event
        }
      }

      if (mut$timing == "late") {
        if (as.numeric(mut$mut.multi.bstr.0.95) < sub.clonal) {
          points(mut$Start_pos,
            mut.multiplicity,
            cex = 0.7,
            pch = 17,
            col = "#D55E0045"
          ) # late event
        }

        if (as.numeric(mut$mut.multi.bstr.0.95) >= sub.clonal) {
          points(mut$Start_pos,
            mut.multiplicity,
            cex = 0.9,
            pch = 16,
            col = "#D55E0095"
          ) # late event
        }
      }
    }
  }

  if (nrow(early.muts) >= 1) {
    sapply(1:nrow(early.muts), plot.earlyORlateCol, early.muts)
  }
  if (nrow(late.muts) >= 1) {
    sapply(1:nrow(late.muts), plot.earlyORlateCol, late.muts)
  }
  if (nrow(nontimed.muts) >= 1) {
    sapply(1:nrow(nontimed.muts), plot.earlyORlateCol, nontimed.muts, nontimed = TRUE)
  }

  mtext(
    side = 3,
    at = fun.chrom.mean(seg.mat.plot[, 2:4]),
    text = sort(unique(seg.mat.plot[, 2])),
    cex = seq(0.6, 0.4, length.out = length(unique(seg.mat.plot[, 2]))),
    line = -1
    # ,lwd=0.5
  )
}

#########################################################################################

fun.chrom.length <- function(seg) {
  # This function returns the length of chromosome 1,...,22
  # seg: first three columns of the minimum conistent region matrix

  chrom.length <- c()
  for (i in sort(as.numeric(unique(seg[, 1])))) {
    sub.chrom <- subset(seg, seg[, 1] == i)
    chrom.length <- c(chrom.length, sub.chrom[nrow(sub.chrom), 3])
  }
  return(chrom.length)
}

#############################################################################################

fun.add.chrom <- function(seg, chrom.length) {
  # This function adds the length of chromosome 1,...,(i - 1) to chromsomes 2,...,22
  # seg: first three columns of the minimum conistent region matrix
  # chrom.length: output of fun.chrom.length(...)

  # fix bug: Data type mismatch results in mismatched results.
  seg <- as.data.frame(seg)
  seg[, 1] <- as.numeric(seg[, 1])
  if (1 %in% seg[, 1]) {
    seg.tmp <- subset(seg, seg[, 1] == 1)
  } else {
    warning("In fun.add.chrom(), seg has no chromosome 1.")
    seg.tmp <- matrix(NA, nrow = 0, ncol = ncol(seg))
  }
  for (i in 2:max(max(seg[, 1]), 3)) {
    if (!(i %in% seg[, 1])) {
      warning(stringr::str_interp("In fun.add.chrom(), seg has no chromosome ${i}."))
      next
    }
    sub.chrom <- subset(seg, seg[, 1] == i)
    sub.chrom[, 2] <- as.numeric(sub.chrom[, 2]) + sum(as.numeric(chrom.length[1:(i - 1)]))
    sub.chrom[, 3] <- as.numeric(sub.chrom[, 3]) + sum(as.numeric(chrom.length[1:(i - 1)]))
    seg.tmp <- rbind(seg.tmp, sub.chrom)
  }
  assertthat::assert_that(nrow(seg.tmp) == nrow(seg))
  return(seg.tmp)
}

####################################################################################################

fun.smooth.score <- function(score, seg) {
  # This function applies smoothing (rollmean) to chromosome 1,...,22 separetely
  # score: score to be smoothed (e.g. correlation)
  # seg: Corresponding positions
  # window: window size for rollmean
  # The R package "zoo" is required
  score.tmp <- c()
  for (i in 1:22) {
    score.tmp <- c(score.tmp, rollmean(score[seg[, 1] == i], k = round(length(score[seg[, 1] == i]) / 10), na.pad = T))
  }

  return(score.tmp)
}

#######################################################################################################

fun.chrom.mean <- function(seg) {
  # This function finds the middle of the positions for each chromosome.
  # seg: Matrix with three columns, containing the positions.
  chrom.mean <- c()
  for (i in sort(as.numeric(unique(seg[, 1])))) {
    sub.chrom <- subset(seg, seg[, 1] == i)
    chrom.mean <- c(chrom.mean, (min(sub.chrom[, 2]) + max(sub.chrom[, 3])) / 2)
  }
  return(chrom.mean)
}

#######################################################################################################

plot.TCGA.sample.ccfs <- function(TCGA.earlyLate,
                                  clonal.cut.off = 1,
                                  spec.genes = NULL) {

  # get the patient
  cancer.patient <- data.frame(TCGA.earlyLate)

  # par(mfrow=c(2,1))
  layout(rbind(1, 2))
  par(mar = c(0.5, 5, 5, 5))
  # density(cancer.patient$ccf,bw='SJ')

  plot(density(as.numeric(cancer.patient$ccf), bw = "SJ"),
    xlim = c(0, 1.4),
    xaxt = "n",
    yaxt = "n"
    # ,xaxs='i'
    # ,yaxs='i'
    , xlab = "",
    ylab = "Density (a.u.)",
    main = cancer.patient$patient[1],
    lwd = 3
  )
  par(mar = c(5, 5, 0.5, 5))
  plot(as.numeric(cancer.patient$ccf),
    log(as.numeric(cancer.patient$var_counts) + as.numeric(cancer.patient$ref_counts)),
    ylim = c(log(5), log(1000)),
    xlim = c(0, 1.6),
    xaxt = "n",
    yaxt = "n"
    # ,xaxs='i'
    # ,yaxs='i'
    , xlab = "Adjusted VAF",
    ylab = "Tumour Coverage",
    main = "",
    lwd = 3,
    cex = 1.5,
    pch = 21,
    col = ifelse(as.numeric(cancer.patient$absolute.ccf.0.95) >= 1, "#de2d2699", "#0072B299"),
    bg = ifelse(cancer.patient$absolute.ccf.0.95 >= 1, "#de2d2699", "#0072B299")
  )

  # next plot the genes of interest
  if (!is.null(spec.genes)) {
    for (gene in spec.genes)
    {
      if (!gene %in% cancer.patient$Hugo_Symbol) {
        next
      }

      gene.mut <- cancer.patient[cancer.patient$Hugo_Symbol %in% gene, , drop = FALSE]
      gene.mut <- gene.mut[gene.mut$Variant_Classification %in% c(
        "Missense_Mutation",
        "Nonsense_Mutation",
        "Splice_Site",
        "Frame_Shift_Del",
        "Translation_Start_Site",
        "Nonstop_Mutation"
      ), , drop = FALSE]
      if (nrow(gene.mut) == 0) {
        next
      }

      points(gene.mut$ccf, log(gene.mut$var_counts + gene.mut$ref_counts),
        cex = 1.8,
        lwd = 3
      )
      text(gene.mut$ccf, log(gene.mut$var_counts + gene.mut$ref_counts),
        labels = gene,
        pos = 4,
        cex = 1,
        lwd = 3,
        font = 2
      )
    }
  }

  axis(side = 1, at = seq(0, 1.6, by = 0.2))
  cov.seq <- c(5, 10, 20, 50, 100, 200, 500, 1000)
  axis(side = 2, at = log(cov.seq), labels = cov.seq, las = 2)
}


# inc_gantt_simplified.r

library(gdata)

cairo_pdf(bg="grey98", pdf_file,width=11.7,height=8.26)

par(lend=1,omi=c(0.25,1,1,0.25),mai=c(1,1.85,0.25,2.75),family="Lato Light",las=1)
mySchedule<-read.xls("mydata/projectplanning.xlsx", encoding="latin1")
n<-nrow(mySchedule)
myScheduleData<-subset(mySchedule,nchar(as.character(mySchedule$from))>0)
myBegin<-min(as.Date(as.matrix(myScheduleData[,c('from','to')])))
myEnd<-max(as.Date(as.matrix(myScheduleData[,c('from','to')])))
attach(mySchedule)

plot(from,1:n,type="n",axes=F,xlim=c(myBegin,myEnd),ylim=c(n,1))
for (i in 1:n)
{
if (nchar(as.character(Group[i]))>0)
{
text(myBegin-2,i,Group[i],adj=1,xpd=T,cex=1.25)
}
else if (nchar(as.character(what[i]))>0)
{
x1<-as.Date(mySchedule[i,'from'])
x2<-as.Date(mySchedule[i,'to'])
x3<-x1+((x2-x1)*mySchedule[i,'done']/100)
x<-c(x1,x2)
x_done<-c(x1,x3)
y<-c(i,i)
segments(myBegin, i, myEnd, i, col="grey")
lines(x,y,lwd=20,col=myColour[i])
points(myEnd+90, i, cex=(mySchedule[i,'Persons']*mySchedule[i,'Durance'])^0.5, pch=19, col=rgb(110, 110, 110, 50, maxColorValue=255), xpd=T)
if (x3-x1>1) lines(x_done,y,lwd=20,col=myColour_done)
if (mySchedule[i,'PAG'] > 0)
{
x4<-as.Date(mySchedule[i,'AG_from'])
x5<-as.Date(mySchedule[i,'AG_to'])
x_ag<-c(x4,x5)
rect(x4,i-0.75,x5,i+0.75,lwd=2)
}
text(myBegin-2,i,what[i],adj=1,xpd=T,cex=0.75)
text(myEnd+25,i,paste(done[i],"%",sep=" "),adj=1,xpd=T,cex=0.75)
text(myEnd+35,i,paste(format(x1,format="%d/%m/%y"),"-",format(x2,format="%d/%m/%y"),sep=" "),adj=0,xpd=T,cex=0.75)
}
else # Milestone
{
x3<-as.Date(mySchedule[i,'when'])
myHalf<-(myEnd-myBegin)/2
if (x3-x1<myHalf)
{
points(as.Date(mySchedule[i,'when']),i,pch=18,cex=1.25,col="red")
text(as.Date(mySchedule[i,'when'])+5,i,Milestone[i],adj=0,xpd=T,cex=0.75)
} else
{
points(as.Date(mySchedule[i,'when']),i,pch=18,cex=1.25,col="red")
text(as.Date(mySchedule[i,'when'])-5,i,Milestone[i],adj=1,xpd=T,cex=0.75)
}
}
}
axis(3,at=c(myBegin,myEnd),labels=c(format(myBegin,format="%d/%m/%Y"),format(myEnd,format="%d/%m/%Y")))
myToday<-as.Date("15.08.2012", "%d.%m.%Y")
abline(v=myToday)

mtext("today",1,line=0,at=myToday)

# Titling

mtext("Project plan",3,line=2,adj=0,cex=2.25,family="Lato Black",outer=T)
mtext(paste("planning status: ",format(myToday,format="%d/%m/%y"),sep=""),1,line=4,at=myEnd+20,cex=1.25,font=3)
rect(myBegin-36, n+5, myBegin, n+4, xpd=T,lwd=2)
text(myBegin-35, n+4.5, "Box: Client",xpd=T, adj=0)


#!/usr/bin/env R
#
# This file is part of peakAnalysis,
# http://github.com/alexjgriffith/alpha-score/,
# and is Copyright (C) University of Ottawa, 2015. It is Licensed under
# the three-clause BSD License; see LICENSE.txt.
# Author : Alexander Griffith
# Contact: griffitaj@gmail.com
#
#######################################################################
######################################################################
#
# Usage:
#
# fileLocation="~/Dropbox/UTX-Alex/jan/"
# bedData<-read.delim(paste(fileLocation,"combined_sorted.bed",sep=""),header=0)
# geneList<-read.delim(paste(fileLocation,"hg19.RefSeqGenes.csv",sep=""))
# genes<-geneAssociation(bedData,geneList,  c(50000,0,0,0))
# write.table(cbind(bedData,unlist(t(lapply(genes, function(x) {if(identical(x,character(0))){"None"} else{x}})))) ,"combined_tagged_genes.bed" ,col.names=FALSE,row.names=FALSE,quote=FALSE,sep="\t")

library(parallel)

member<-function(posibList,mem,test="default"){
    fun<-switch(test,default=function(x,y){all(y %in% x)})
    sapply(posibList,fun,mem)}

memberWrapper<-function(bedData,lis ,n=4,sep="-"){
    member(strsplit(as.character(bedData[,n]),sep),lis)}

geneAssoc<-function(point,geneList,bounds){
    # Currently Returns the enhancer locations
    peak<-(as.numeric(point[[2]])+as.numeric(point[[3]]))/2
    tss<-geneList$txStart
    ess<-geneList$txEnd
    chrom<-geneList$chrom
    a<-which(chrom==as.character(point[[1]]))
    b<-a[which(tss[a]-bounds[1]<peak)]
    r<-b[which(ess[b]+bounds[3]>peak)]
    e<-r[c(which(tss[r]-bounds[2]>peak),which(ess[r]+bounds[4]<peak))]
    e}

leneAssoc<-function(point,geneList,bounds){
    peak<-(as.numeric(point[[2]])+as.numeric(point[[3]]))/2
    tss<-geneList$txStart
    ess<-geneList$txEnd
    chrom<-geneList$chrom
    a<-which(chrom==as.character(point[[1]]))
    b<-a[which(tss[a]-bounds[1]<peak)]
    r<-b[which(ess[b]+bounds[3]>peak)]
    locations<-r[c(which(tss[r]-bounds[2]>peak),which(ess[r]+bounds[4]<peak))]
    t<-geneList$txStart[unlist(locations)]
    gene<-as.character(geneList$name[locations[order(abs(t-peak))]])
    if(identical(gene,character(0))){"None"}else(gene)}

minGene<-function(x,y){
    x[order(abs(x-y))]}

geneAssociation<-function(bedData,geneList,bounds,n=FALSE){
    if(is.logical(n)){
        peak<-(as.numeric(bedData[,2])+as.numeric(bedData[,3]))/2
        locations<-apply(bedData,1,geneAssoc,geneList,bounds)
        t<-lapply(n,locations,function(locations) geneList$txStart[unlist(locations)])

        tssGenes<-Map(minGene,t,peak)
        a<-lapply( tssGenes, function(x){as.character(geneList$name2[x])})}
    else{
        cs<-makeForkCluster(n,renice=0)
        a<-parApply(cs,bedData,1,leneAssoc,geneList=geneList,bounds=bounds)
    stopCluster(cs)}
    return (a)}


# idir_base = "products/_12_ngsplot_NEBsensAndStrand/all/Tier3"
# idir_base2= "products/_12_ngsplot_NEBsensAndStrand_bg/all/Tier3"
# odir_base = "products/_13_aggregationPlot/NEBsensAndStrand/all/Tier3"
# fileLabel = "data/files_to_analyze.txt"

#########################
timestamp()

args=(commandArgs(TRUE))

idir_base = args[1]
idir_base2= args[2]
odir_base = args[3]
fileLabel = args[4]

##########

library(data.table); library(dplyr); library(magrittr); library(dtplyr)
library(scales)

if(!file.exists(odir_base)){
  dir.create(odir_base, recursive = T)
}

# source("scripts/_functions.r")

collectDeepToolsWithBackground = function(
            idir_base,
            idir_base2,
            odir_base,
            fileLabel
            ){

  labels <- fread(fileLabel, header = T) %>% select(label) %>% unlist
  labels2 <- paste0(labels, "_bg")
  # groups <- gsub("_.+", "", gsub("_mcf_1", "", gsub("RamDA_", "", labels)))
  # groups_unique <- unique(groups)

  ifiles <- sprintf("%s/%s/%s.%s", idir_base, labels, labels, "txt.gz")
  ifiles2 <- sprintf("%s/%s/%s.%s", idir_base2, labels, labels, "txt.gz")

  for(i in seq_along(ifiles)){
    ifile <- ifiles[i]
    print(sprintf("%s, %s", labels[i], ifiles[i]))
    dt <- fread(sprintf("gzip -dc %s", ifile), header = FALSE, skip = 1)
    if(i == 1){
      arr1 <- array(0, dim = c(nrow(dt), ncol(dt)-6, length(ifiles)))
      dimnames(arr1)[[1]] = dt[, V4]
    }
    ma = dt %>% select(-V1,-V2,-V3,-V4,-V5,-V6) %>% as.matrix()
    ma[is.nan(ma)] = 0
    arr1[,,i] <- ma
  }
  dimnames(arr1)[[3]] <- labels

  for(i in seq_along(ifiles2)){
    ifile <- ifiles2[i]
    print(sprintf("%s, %s", labels2[i], ifiles2[i]))
    dt <- fread(sprintf("gzip -dc %s", ifile), header = FALSE, skip = 1)
    if(i == 1){
      arr2 <- array(0, dim = c(nrow(dt), ncol(dt)-6, length(ifiles2)))
      dimnames(arr2)[[1]] = dt[, V4]
    }
    ma = dt %>% select(-V1,-V2,-V3,-V4,-V5,-V6) %>% as.matrix()
    ma[is.nan(ma)] = 0
    arr2[,,i] <- ma
  }
  dimnames(arr2)[[3]] <- labels2

  path_rdata = sprintf("%s/%s.Rdata", odir_base, "rdata")
  save(arr1, arr2, file = path_rdata)
}

collectDeepToolsWithBackground(idir_base, idir_base2, odir_base, fileLabel)

sessionInfo()

timestamp()


get_FSS<-function(species=201,sy=1977,area="AI"){
   if(area=="AI"){
    reg<-"539 and 544"
  }
  if(area=="GOA"){
    reg<-"600 and 699"
  }
  if(area=="BS"){
    reg<-"500 and 539"
  }

  test<-paste("SELECT NORPAC.FOREIGN_HAUL.YEAR,\n ",
    "NORPAC.FOREIGN_LENGTH.HAUL_JOIN\n ",
  "FROM NORPAC.FOREIGN_HAUL\n ",
  "INNER JOIN NORPAC.FOREIGN_LENGTH\n ",
  "ON NORPAC.FOREIGN_HAUL.HAUL_JOIN = NORPAC.FOREIGN_LENGTH.HAUL_JOIN\n ",
  "WHERE NORPAC.FOREIGN_HAUL.YEAR   > ",sy,"\n ",
  "AND NORPAC.FOREIGN_HAUL.GENERIC_AREA BETWEEN ",reg,"\n ",
  "AND NORPAC.FOREIGN_LENGTH.SPECIES = ",species,"\n ",
  "ORDER BY NORPAC.FOREIGN_HAUL.YEAR",sep="")

  FSS=sqlQuery(AFSC,test)

  FSS1<-aggregate(list(LENGTH=FSS$HAUL_JOIN),by=list(HAUL_JOIN=FSS$HAUL_JOIN,YEAR=FSS$YEAR),FUN=min)
  FSS2<-aggregate(list(LENGTH=FSS1$HAUL_JOIN),by=list(YEAR=FSS1$YEAR),FUN=length)
  FSS2<-data.frame(FSS2)
  FSS2$SS=100+((FSS2$LENGTH/mean(FSS2$LENGTH)))
  FSS2$SS<-apply(FSS2,1,min)
  FSS2
  }


# Calculates summary stats (eg. MFI 10%, MFI 25%) on the simulation output
# for fixed regime simulations. Outputs a new file (sim_list_stats1.csv) in each simulation output directory
# with statistics calculated for each simulation run

library(dplyr)

source("summary_functions.r")

calc_stats=function(wd,run){
  print(run)
  data_frame=read.csv(paste0(wd,run,"/sim_list.csv"))

  data_frame$GridRealMFI=0
  data_frame$GridRealNFR=0
  data_frame$NFR_census=0
  data_frame$NFR_500=0
  data_frame$NFR_250=0
  data_frame$NFR_100=0
  data_frame$NFR_50=0
  data_frame$NFR_25=0
  data_frame$NFR_10=0
  data_frame$NFR_500_T=0
  data_frame$NFR_250_T=0
  data_frame$NFR_100_T=0
  data_frame$NFR_50_T=0
  data_frame$NFR_25_T=0
  data_frame$NFR_10_T=0

  data_frame$MFI_census=0
  data_frame$MFI_500=0
  data_frame$MFI_250=0
  data_frame$MFI_100=0
  data_frame$MFI_50=0
  data_frame$MFI_25=0
  data_frame$MFI_10=0
  data_frame$MFI_500_T=0
  data_frame$MFI_250_T=0
  data_frame$MFI_100_T=0
  data_frame$MFI_50_T=0
  data_frame$MFI_25_T=0
  data_frame$MFI_10_T=0

  data_frame$MFI_grid_10=0
  data_frame$MFI_census_10=0

  data_frame$MFI_500_10=0
  data_frame$MFI_250_10=0
  data_frame$MFI_100_10=0
  data_frame$MFI_50_10=0
  data_frame$MFI_25_10=0
  data_frame$MFI_10_10=0

  data_frame$MFI_500_T_10=0
  data_frame$MFI_250_T_10=0
  data_frame$MFI_100_T_10=0
  data_frame$MFI_50_T_10=0
  data_frame$MFI_25_T_10=0
  data_frame$MFI_10_T_10=0

  data_frame$MFI_grid_25=0
  data_frame$MFI_census_25=0

  data_frame$MFI_500_25=0
  data_frame$MFI_250_25=0
  data_frame$MFI_100_25=0
  data_frame$MFI_50_25=0
  data_frame$MFI_25_25=0
  data_frame$MFI_10_25=0

  data_frame$MFI_500_T_25=0
  data_frame$MFI_250_T_25=0
  data_frame$MFI_100_T_25=0
  data_frame$MFI_50_T_25=0
  data_frame$MFI_25_T_25=0
  data_frame$MFI_10_T_25=0

  data_frame$MFI_grid_2o=0
  data_frame$MFI_census_2o=0

  data_frame$MFI_500_2o=0
  data_frame$MFI_250_2o=0
  data_frame$MFI_100_2o=0
  data_frame$MFI_50_2o=0
  data_frame$MFI_25_2o=0
  data_frame$MFI_10_2o=0

  data_frame$MFI_500_T_2o=0
  data_frame$MFI_250_T_2o=0
  data_frame$MFI_100_T_2o=0
  data_frame$MFI_50_T_2o=0
  data_frame$MFI_25_T_2o=0
  data_frame$MFI_10_T_2o=0

  count_dead=TRUE
  for(idx in 1:dim(data_frame)[1]){
    print(idx)

    aa=load(paste0(wd,run,"/fire_record_",idx,".Rdata"),env=environment())

    this_tree=read.csv(paste0(wd,run,"/tree_frame_",idx,".csv"))

    if(!count_dead){
      this_tree=subset(this_tree,STATUS==0)
    }

    ## Real Grid Statistics

    data_frame$GridRealMFI[idx]=f_RealMFI(this_fire,0)
    data_frame$GridRealNFR[idx]=f_RealNFR(this_fire)
    data_frame$MFI_grid_10[idx]=f_RealMFI(this_fire,10)
    data_frame$MFI_grid_25[idx]=f_RealMFI(this_fire,25)
    data_frame$MFI_grid_2o[idx]=f_RealMFIf(this_fire,2)

    # Shuffle this_tree so the ordered trees have a random subset within them, or else all the dead ones will be at the bottom
    this_tree$shuffler=sample(dim(this_tree)[1])

    ## Calculate a summary of the number of scars per tree, for filtering
    this_tree=group_by(this_tree,ID)

    scar_count=summarise(this_tree,count=length(YBP),MFI=f_tree_MFIhelper(YBP),shuffler=first(shuffler))
    scar_count=arrange(scar_count,desc(count),shuffler)

    ## NFR for random samples
    this_tree=as.data.frame(this_tree)
    data_frame$NFR_census[idx]=f_tree_NFR(this_tree,this_fire)
    data_frame$NFR_500[idx]=f_tree_NFR(this_tree[sample(dim(this_tree)[1],500),],this_fire)
    data_frame$NFR_250[idx]=f_tree_NFR(this_tree[sample(dim(this_tree)[1],250),],this_fire)
    data_frame$NFR_100[idx]=f_tree_NFR(this_tree[sample(dim(this_tree)[1],100),],this_fire)
    data_frame$NFR_50[idx]=f_tree_NFR(this_tree[sample(dim(this_tree)[1],50),],this_fire)
    data_frame$NFR_25[idx]=f_tree_NFR(this_tree[sample(dim(this_tree)[1],25),],this_fire)
    data_frame$NFR_10[idx]=f_tree_NFR(this_tree[sample(dim(this_tree)[1],10),],this_fire)

    data_frame$NFR_500_T[idx]=f_tree_NFR(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),this_fire)
    data_frame$NFR_250_T[idx]=f_tree_NFR(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),this_fire)
    data_frame$NFR_100_T[idx]=f_tree_NFR(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),this_fire)
    data_frame$NFR_50_T[idx]=f_tree_NFR(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),this_fire)
    data_frame$NFR_25_T[idx]=f_tree_NFR(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),this_fire)
    data_frame$NFR_10_T[idx]=f_tree_NFR(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),this_fire)

    scar_count=as.data.frame(scar_count)
    scar_count=subset(scar_count,is.finite(scar_count$MFI))

    all_tree_scaryears=f_tree_percscar(this_tree,0,this_fire)

    # MFI for all trees with no synchronicity required
    data_frame$MFI_census[idx]=mean(diff(all_tree_scaryears$year))
    data_frame$MFI_500[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],500),],0,this_fire)$year))
    data_frame$MFI_250[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],250),],0,this_fire)$year))
    data_frame$MFI_100[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],100),],0,this_fire)$year))
    data_frame$MFI_50[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],50),],0,this_fire)$year))
    data_frame$MFI_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],25),],0,this_fire)$year))
    data_frame$MFI_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],10),],0,this_fire)$year))

    data_frame$MFI_500_T[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),0,this_fire)$year))
    data_frame$MFI_250_T[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),0,this_fire)$year))
    data_frame$MFI_100_T[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),0,this_fire)$year))
    data_frame$MFI_50_T[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),0,this_fire)$year))
    data_frame$MFI_25_T[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),0,this_fire)$year))
    data_frame$MFI_10_T[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),0,this_fire)$year))

    # MFI for all trees with 10% synchronicity required

    data_frame$MFI_census_10[idx]=mean(diff(f_tree_percscar(this_tree,10,this_fire)$year))
    data_frame$MFI_500_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],500),],10,this_fire)$year))
    data_frame$MFI_250_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],250),],10,this_fire)$year))
    data_frame$MFI_100_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],100),],10,this_fire)$year))
    data_frame$MFI_50_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],50),],10,this_fire)$year))
    data_frame$MFI_25_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],25),],10,this_fire)$year))
    data_frame$MFI_10_10[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],10),],10,this_fire)$year))

    data_frame$MFI_500_T_10[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),10,this_fire)$year))
    data_frame$MFI_250_T_10[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),10,this_fire)$year))
    data_frame$MFI_100_T_10[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),10,this_fire)$year))
    data_frame$MFI_50_T_10[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),10,this_fire)$year))
    data_frame$MFI_25_T_10[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),10,this_fire)$year))
    data_frame$MFI_10_T_10[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),10,this_fire)$year))

    # MFI for all trees with 25% synchronicity required
    data_frame$MFI_census_25[idx]=mean(diff(f_tree_percscar(this_tree,25,this_fire)$year))
    data_frame$MFI_500_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],500),],25,this_fire)$year))
    data_frame$MFI_250_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],250),],25,this_fire)$year))
    data_frame$MFI_100_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],100),],25,this_fire)$year))
    data_frame$MFI_50_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],50),],25,this_fire)$year))
    data_frame$MFI_25_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],25),],25,this_fire)$year))
    data_frame$MFI_10_25[idx]=mean(diff(f_tree_percscar(this_tree[sample(dim(this_tree)[1],10),],25,this_fire)$year))

    data_frame$MFI_500_T_25[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),25,this_fire)$year))
    data_frame$MFI_250_T_25[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),25,this_fire)$year))
    data_frame$MFI_100_T_25[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),25,this_fire)$year))
    data_frame$MFI_50_T_25[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),25,this_fire)$year))
    data_frame$MFI_25_T_25[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),25,this_fire)$year))
    data_frame$MFI_10_T_25[idx]=mean(diff(f_tree_percscar(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),25,this_fire)$year))

    ### MFI for trees with more than 2 trees with scars in each year

    # MFI for all trees with 10% synchronicity required

    data_frame$MFI_census_2o[idx]=mean(diff(f_tree_percscarf(this_tree,10,this_fire)$year))
    data_frame$MFI_500_2o[idx]=mean(diff(f_tree_percscarf(this_tree[sample(dim(this_tree)[1],500),],2,this_fire)$year))
    data_frame$MFI_250_2o[idx]=mean(diff(f_tree_percscarf(this_tree[sample(dim(this_tree)[1],250),],2,this_fire)$year))
    data_frame$MFI_100_2o[idx]=mean(diff(f_tree_percscarf(this_tree[sample(dim(this_tree)[1],100),],2,this_fire)$year))
    data_frame$MFI_50_2o[idx]=mean(diff(f_tree_percscarf(this_tree[sample(dim(this_tree)[1],50),],2,this_fire)$year))
    data_frame$MFI_25_2o[idx]=mean(diff(f_tree_percscarf(this_tree[sample(dim(this_tree)[1],25),],2,this_fire)$year))
    data_frame$MFI_10_2o[idx]=mean(diff(f_tree_percscarf(this_tree[sample(dim(this_tree)[1],10),],2,this_fire)$year))

    data_frame$MFI_500_T_2o[idx]=mean(diff(f_tree_percscarf(subset(this_tree,this_tree$ID %in% scar_count[1:500,]$ID),2,this_fire)$year))
    data_frame$MFI_250_T_2o[idx]=mean(diff(f_tree_percscarf(subset(this_tree,this_tree$ID %in% scar_count[1:250,]$ID),2,this_fire)$year))
    data_frame$MFI_100_T_2o[idx]=mean(diff(f_tree_percscarf(subset(this_tree,this_tree$ID %in% scar_count[1:100,]$ID),2,this_fire)$year))
    data_frame$MFI_50_T_2o[idx]=mean(diff(f_tree_percscarf(subset(this_tree,this_tree$ID %in% scar_count[1:50,]$ID),2,this_fire)$year))
    data_frame$MFI_25_T_2o[idx]=mean(diff(f_tree_percscarf(subset(this_tree,this_tree$ID %in% scar_count[1:25,]$ID),2,this_fire)$year))
    data_frame$MFI_10_T_2o[idx]=mean(diff(f_tree_percscarf(subset(this_tree,this_tree$ID %in% scar_count[1:10,]$ID),2,this_fire)$year))
  }

  write.csv(data_frame,paste0(wd,run,"/sim_list_stats1.csv"))
}

working_dir="E:/nm_scardata/"

library(doParallel)
library(foreach)
library(iterators)

registerDoParallel(cores=12)

td_vec=c("latin_sens","e1_l1","e1_l2","e1_l3","e1_l4")

foreach(i=iter(td_vec),.packages="dplyr") %dopar% calc_stats(working_dir,i)


library(corrplot) #para matriz de correlacao
library(psych)
library(GPArotation)

surveyOriginal = read.table("responses.csv",sep=",",header=TRUE)

# preparacao dos dados
survey <- surveyOriginal[complete.cases(surveyOriginal),] #limpa missing data
#colnames(survey)
#transformando coluna Slow.songs.or.fast.songs em duas
survey["Slow music"] <- NULL
survey["Fast music"] <- NULL
survey["SmokingNumber"] <- NULL
survey["AlcoholNumber"] <- NULL
survey["Atrasado"] <- NULL
survey["QuantidadeMentiras"] <- NULL
survey["NivelEducacao"] <- NULL
survey['TempoGastoInternet'] <- NULL

#categorias
musicas <- c("Dance","Folk","Country","Classical.music","Musical","Pop","Rock","Metal.or.Hardrock","Punk","Hiphop..Rap","Reggae..Ska","Swing..Jazz","Rock.n.roll","Alternative","Latino","Techno..Trance","Opera")
filmes <- c("Movies","Horror","Thriller","Comedy","Romantic","Sci.fi","War","Fantasy.Fairy.tales","Animated","Documentary","Western","Action")
hobbysEInteresses <- c("History","Psychology","Politics","Mathematics","Physics","Internet","PC","Economy.Management","Biology","Chemistry","Reading","Geography","Foreign.languages","Medicine","Law","Cars","Art.exhibitions","Religion","Countryside..outdoors","Dancing","Musical.instruments","Writing","Passive.sport","Active.sport","Gardening","Celebrities","Shopping","Science.and.technology","Theatre","Fun.with.friends","Adrenaline.sports","Pets")
fobias <- c("Flying","Storm","Darkness","Heights","Spiders","Snakes","Rats","Ageing","Dangerous.dogs","Fear.of.public.speaking")
habitosAlimentares <- c("SmokingNumber", "AlcoholNumber", "Healthy.eating")
habitosDeCompra <- c("Finances","Shopping.centres","Branded.clothing","Entertainment.spending","Spending.on.looks","Spending.on.gadgets","Spending.on.healthy.eating")
personalidadeQuantitativo <- c("Daily.events","Prioritising.workload","Writing.notes","Workaholism","Thinking.ahead","Final.judgement","Reliability","Keeping.promises","Loss.of.interest","Friends.versus.money","Funniness","Fake","Criminal.damage","Decision.making","Elections","Self.criticism","Judgment.calls","Hypochondria","Empathy","Eating.to.survive","Giving","Compassion.to.animals","Borrowed.stuff","Loneliness","Cheating.in.school","Health","Changing.the.past","God","Dreams","Charity", "QuantidadeMentiras", "Atrasado","Number.of.friends","Waiting","New.environment","Mood.swings","Appearence.and.gestures","Socializing","Achievements","Responding.to.a.serious.letter","Children","Assertiveness","Getting.angry","Knowing.the.right.people","Public.speaking","Unpopularity","Life.struggles","Happiness.in.life","Energy.levels","Small...big.dogs","Personality","Finding.lost.valuables","Getting.up","Interests.or.hobbies","Parents..advice","Questionnaires.or.polls", "TempoGastoInternet")
personalidadeQualitativo  <- c("Punctuality","Lying","Internet.usage")
demograficosQuantitativos <- c("Age","Height","Weight","Number.of.siblings", "NivelEducacao")
demograficosQualitativos  <- c("Gender","Left...right.handed","Education","Only.child","Village...town","House...block.of.flats")

variaveisQuantitativas <- c(musicas, filmes, hobbysEInteresses, fobias, habitosAlimentares, habitosDeCompra, habitosDeCompra, demograficosQuantitativos, personalidadeQuantitativo)
variaveisQualitativas <-c(personalidadeQualitativo, demograficosQualitativos)

print(nrow(survey))
for (row in 1:nrow(survey)) {
  survey[row, "Slow.music"] <- abs(survey[row, "Slow.songs.or.fast.songs"]-6)
  survey[row, "Fast.music"] <- survey[row, "Slow.songs.or.fast.songs"]

  switch(as.character(survey[row, "Smoking"]),
         "never smoked"={survey[row, "SmokingNumber"] <- as.numeric(1)},
         "tried smoking"={survey[row, "SmokingNumber"] <- as.numeric(2)},
         "former smoker"={survey[row, "SmokingNumber"] <- as.numeric(3)},
         "current smoker"={survey[row, "SmokingNumber"] <- as.numeric(4)},
         {survey[row, "SmokingNumber"] <- NA}
  )

  switch(as.character(survey[row, "Alcohol"]),
         "never"={survey[row, "AlcoholNumber"] <- as.numeric(1)},
         "social drinker"={survey[row, "AlcoholNumber"] <- as.numeric(2)},
         "drink a lot"={survey[row, "AlcoholNumber"] <- as.numeric(3)},
         {survey[row, "SmokingNumber"] <- NA}
  )

  switch(as.character(survey[row, "Punctuality"]),
         "i am often early"={survey[row, "Atrasado"] <- as.numeric(1)},
         "i am always on time"={survey[row, "Atrasado"] <- as.numeric(2)},
         "i am often running late"={survey[row, "Atrasado"] <- as.numeric(3)},
         {survey[row, "Atrasado"] <- NA}
  )

  switch(as.character(survey[row, "Lying"]),
         "never"={survey[row, "QuantidadeMentiras"] <- as.numeric(1)},
         "only to avoid hurting someone"={survey[row, "QuantidadeMentiras"] <- as.numeric(2)},
         "sometimes"={survey[row, "QuantidadeMentiras"] <- as.numeric(3)},
         "everytime it suits me"={survey[row, "QuantidadeMentiras"] <- as.numeric(4)},
         {survey[row, "QuantidadeMentiras"] <- NA}
  )

  switch(as.character(survey[row, "Internet.usage"]),
         "no time at all"={survey[row, "TempoGastoInternet"] <- as.numeric(1)},
         "less than an hour a day"={survey[row, "TempoGastoInternet"] <- as.numeric(2)},
         "few hours a day"={survey[row, "TempoGastoInternet"] <- as.numeric(3)},
         "most of the day"={survey[row, "TempoGastoInternet"] <- as.numeric(4)},
         {survey[row, "TempoGastoInternet"] <- NA}
  )

  switch(as.character(survey[row, "Education"]),
         "primary school"={survey[row, "NivelEducacao"] <- as.numeric(1)},
         "secondary school"={survey[row, "NivelEducacao"] <- as.numeric(2)},
         "college/bachelor degree"={survey[row, "NivelEducacao"] <- as.numeric(3)},
         "masters degree"={survey[row, "NivelEducacao"] <- as.numeric(4)},
         {survey[row, "NivelEducacao"] <- NA}
  )
}
survey <- survey[complete.cases(survey),] #limpa missing data
print(nrow(survey))

surveyQuantitativo <- survey[,variaveisQuantitativas] #DataSet contendo somente colunas quantitativas

#Matrizes de correlação
corrplot(cor(survey[musicas]), type = "lower", tl.srt = 45, diag = FALSE)
corrplot(cor(survey[filmes]), type = c("lower"), tl.srt = 45, diag = FALSE)
corrplot(cor(survey[hobbysEInteresses]), type = c("lower"), tl.srt = 45, diag = FALSE)
corrplot(cor(survey[habitosAlimentares]), type = c("lower"), tl.srt = 45, diag = FALSE)
corrplot(cor(survey[fobias]), type = c("lower"), tl.srt = 45, diag = FALSE)
corrplot(cor(survey[habitosDeCompra]), type = c("lower"), tl.srt = 45, diag = FALSE)
corrplot(cor(survey[personalidadeQuantitativo]), type = c("lower"), tl.srt = 45, diag = FALSE)
corrplot(cor(survey[demograficosQuantitativos]), type = c("lower"), tl.srt = 45, diag = FALSE)

#INÍCIO - Análise Fatorial
#Etapas
#1 - Análise de Matriz de correlação e Adequação da utilização da AF
#2 - Extração dos fatores iniciais e Escolha dos numeros dos fatores
#3 - Rotação dos Fatores
#4 - Interpretação dos Fatores

#1 - Etapa - Adequação da utilização da AF
#Analisar Matriz de correlação (>0.30)
#aplicar estatistica KMO
#*compara correlações simples com parcial [0:1] (KMO próx. a 1)
#-Teste de esfericidade de Barlett
#*H0: Matriz correlação = Matriz identidade (H0 rejeitada)
#Análise de Matriz anti-imagem
#*Valores negativo das correlações parciais. (Maior mais aceitável)

#2 - Etapa - Extração dos fatores iniciais
#- Método de Extração
#*ACP - análise de componentes principais
#Variância comum: comunalidade

#2 - Etapa - Escolha do numero de fatores
#Possíveis critérios:
#-Critério Raiz latente (Critério de Kaiser)
#* valores > 1
#-Critério a priori ( é determinado o numero de fatores pelo pesquisador)
#-Critério da percentagem da variância (Nível significativo)
#-Critério do gráfico Scree
#* plotagem das raizes latentes(Y) e fatores(X).
#* parte mais horizontal limita a quantidade de fatores

#3 - Etapa - Rotação dos fatores
#Transformar os componentes principais
#-Rotação Ortogonal e obliquo(Varimax)

#4 - Etapa - Interpretação do dados
#- Cargas maiores de 0.30

#Analise Descritiva
summary(surveyQuantitativo)
sd(surveyQuantitativo)

#Análise dos componentes principais
fit <- princomp(surveyQuantitativo,cor=TRUE)
#cor = TRUE, os componentes principais serão gerados a partir da matriz de correlação
#caso cor = FALSE, os componentes principais serão gerados a partir da matriz de covariância

#Apresentação das variâncias explicadas por componentes e variância explicada acumulada
summary(fit)
#É recomendado que o percentual de variância explicada seja de pelo menos 60%
#Elevando-os ao quadrado, teremosa variância dos valores dos fatores
#Deve-se escolher os fatores com os valores maiores que 1

#Apresentação das Cargas Fatoriais considerando todos os vetores
#Na função loadings podemos acrescentar a opção cutoff = 0.5, para que os loadings < 0.5 fiquem ocultos
loadings(fit, cutoff = 0.5)

#Para analisar a quantidade de fatores suficientes à análise fatorial, deve-se realizar o scree plot
plot(fit, type = "line")
#onde deve-se observar o ponto na qual é atingido o padrão mais horizontal

#Cálculo dos scores das observações nos componentes principais
fit$scores

#Com o comando "biplot", consegue-se ver a angulação entre cada variável;
#a correlação entre as variáveis é dada pelo cosseno do ângulo que elas formam.
#Quanto maior a correlação entre duas variáveis, maior a probabilidade de existirem fatores comuns a elas.
biplot(fit) #consegue-se ver a angulação entre cada variável

##Análise fatorial a partir do pacote Psych
#Análise de adequação
#Teste de esferacidade de Barlett
#Hipotese nula(H0): matriz de correlação entre variáveis é a matriz identidade.
#ou seja, variáveis não são correlacionadas
cortest.bartlett(surveyQuantitativo)

#Se H0 é rejeitada, a análise fatorial é valida
# p-value pequeno - rejeita-se H0, logo pode-se aplicar a análise fatorial

#Extração de dados com rotação pelo método VARIMAX
#Com a rotação, passamos a trabalhar com uma matriz mais simples, facilitando a interpretação dos valores
#O método de rotação mais utilizado é processo VARIMAX,
#que se trata de um método ortogonal de rotação que minimiza o número de variáveis com altas cargas sobre
#um fator, reforçando assim a interpretabilidade dos fatores
fit <- principal(surveyQuantitativo, nfactors=6, rotate="varimax", scores=TRUE)
fit

#plot factor 1 by factor 2
load <- fit$loadings
plot(load)
text(load, labels=names(survey[]),cex = .4) #adiciona nome das variáveis
load

#Os resultados mostram os valores dos fatores para cada variavel, os autovalores
#(SS loadings) e a proporção de variância acumulada
#Outras opções para o parametro rotate(), qunatimax, promax, oblimin, simplin e cluster.

### Calculo KMO
#O calculo de KMO testa se as correlações simples são iguais as correlações parciais observada entre as variáveis.
#A correlação parcial entre duas variáveisé a correlação que existe entre duas variáveis que também
#se apresentam correlacionadas com as primeiras.
#Os coeficientes de correlação parcial entre pares de variáveis devem ser pequenos se estas partilharem fatores comuns

##Um KMO maior que 0.5 justifique a utilização da Análise Fatorial
##Logo nessa análise o KMO é igual a o.6812106, sendo justificado a análise fatorial.

#FIM - Análise Fatorial

#tests: https://www.statmethods.net/advstats/factor.html
surveyMusic=surveyQuantitativo[,musicas]
surveyMusicDem=surveyQuantitativo[,c(musicas,demograficosQuantitativos)]
surveyInteresses = surveyQuantitativo[,hobbysEInteresses]
surveyInteressesDem = surveyQuantitativo[, c(hobbysEInteresses, demograficosQuantitativos)]
surveyFinal = surveyQuantitativo[, personalidadeQuantitativo]
# Determine Number of Factors to Extract
library(nFactors)
ev <- eigen(cor(surveyFinal)) # get eigenvalues
ap <- parallel(subject=nrow(surveyFinal),var=ncol(surveyFinal),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# hothorn cap.5 -- determine number of factors by p-value
sapply(1:10, function(f) +
      factanal(surveyFinal, factors = f, method ="mle", rotation = "varimax")$PVAL)

factanal(surveyFinal, factors = 3, method ="mle", rotation = "varimax")

#função hothorn cap.5
pfun <- function(nf, matrix) {
  matrixCovariance <- cor(matrix)
  fa <- factanal(covmat = matrixCovariance, factors = nf, method = "mle", n.obs = nrow(matrix))
  est <- tcrossprod(fa$loadings) + diag(fa$uniquenesses)
  ret <- round((matrixCovariance - est), 2)
  colnames(ret) <- rownames(ret) <- abbreviate(rownames(ret), 3)
  ret
}
pfun(3, surveyFinal)

# Maximum Likelihood Factor Analysis
# entering raw data and extracting 3 factors,
# with varimax rotation
fit <- factanal(surveyFinal, 9, rotation="varimax", method="mle")
print(fit, digits=2, cutoff=.1, sort=TRUE)
# plot factor 1 by factor 2

test <- fit$loadings[, 7:9]
print(sort(test))

load <- fit$loadings[,4:5]
plot(load,type="n", col="black") # set up plot
text(load,labels=names(surveyFinal),cex=.9, col = "black") # add variable names

# Principal Axis Factor Analysis
library(psych)
fit <- factor.pa(surveyFinal, nfactors=9)
fit # print results

# PCA Variable Factor Map
install.packages("FactoMineR")
library(FactoMinerR)
result <- PCA(surveyFinal) # graphs generated automatically

library(sem)
surveyFinal.cov <- cov(surveyFinal)
model.surveyFinal <- specify.model()

# funcao que determina os fatores de uma amostra, dado as cargas
determinaFator <- function(variaveis, loads) {
  fatores <- array(dim=ncol(loads))
  for(i in 1:ncol(loads)) {
    fatores[i] <- sum(variaveis * loads[ ,i])
  }

  return (fatores)
}

# analise fatorial de n fatores
fa <- factanal(surveyFinal, factors = 2, rotation="varimax", method = "mle")
loads <- (fa$loadings)

# para cada amostra, determina seus fatores
fatores <- list()
for(i in 1:nrow(surveyFinal)) {
  fatores[[i]] <- determinaFator(surveyFinal[i,], loads)
}

# converte a lista de listas em uma matriz
# adaptado de: https://stackoverflow.com/questions/43425300/list-of-lists-to-matrix
max_length <- max(unlist(lapply (fatores, FUN = length)))
fatores <- sapply (fatores, function (x) {length (x) <- max_length; return (x)})
fatores <- t(fatores)

# http://motioninsocial.com/tufte/#dot-dash-plot
# plotta os fatores
library(lattice)
x <- fatores[,1]
y <- fatores[,2]
xyplot(y ~ x, xlab="Fator 1", ylab="Fator 2",
       par.settings = list(axis.line = list(col="transparent")),
       panel = function(x, y,...) {
         panel.xyplot(x, y, col=1, pch=1, cex=.7)
         panel.rug(x, y, col=1, x.units = rep("snpc", 2), y.units = rep("snpc", 2), ...)})


### LOAD LIBRARIES -----------------------------------------------------------------------------------------
library("gplots")
library("RColorBrewer")
library("stringr")

### SET PATHS ----------------------------------------------------------------------------------------------
#dir.wrk <- file.path("//jbrcsrv009/CollinsGroup/Raunak/projects/MESO_peritoneal/task/03_enrichment_analysis")
dir.wrk <- file.path("/Data/Raunak/projects/MESO_peritoneal/task/03_enrichment_analysis")
dir.data <- file.path(dir.wrk, "data")
dir.plot <- file.path(dir.wrk, "plot")
dir.enrichment <- file.path(dir.wrk, "enrichment")

### DEFINE FILE --------------------------------------------------------------------------------------------
file.name <- "enrichment_c5.bp.v5.0.symbols.txt"

### DEFINE ENVIRONMENT -------------------------------------------------------------------------------------
batch <- "MESO_OUTLIERS_p01_NEW"
dir.batch <- file.path(dir.enrichment, batch)
dir.patients <- list.dirs(path=dir.batch, full.names=T, recursive=F)
ids.patients <- list.dirs(path=dir.batch, full.names=F, recursive=F)

### PROCESS EACH PATIENT DATA ------------------------------------------------------------------------------
list.dat <- list()
for(i in 1:length(ids.patients)){
	file.dat <- file.path(dir.patients[i], file.name)

	if(!file.exists(file.dat)) next

	dat <- read.delim(file.dat, header=T, stringsAsFactors=F)
	#dat$Category <- unlist(lapply(str_split(dat$Category, "_"), function(x) paste(x[2:length(x)], collapse=" ")))
	dat$ngenes <- unlist(lapply(str_split(dat$overlap.genes, ","), function(x) length(x)))

	dat <- subset(dat, dat$ngenes >=2)

	if(nrow(dat) != 0){
		list.dat[[i]] <- data.frame(SampleID=ids.patients[i],
									Category=dat$Category,
									pvalue=dat$pvalue,
									fdr=dat$fdr,
									EnrichmentScore=-log10(dat$fdr),
									genes=dat$overlap.genes)
	} else{
		list.dat[[i]] <- data.frame(NULL)
	}
}
df <- do.call(rbind.data.frame, list.dat)
df$SampleID <- as.character(df$SampleID)
df$Category <- as.character(df$Category)
df$genes <- as.character(df$genes)

### CONSTRUCT PATHWAY MATRIX ----------------------------------------------------------------------------------
pathways <- unique(df$Category)
patients <- unique(df$SampleID)
mat <- matrix(0, nrow=length(pathways), ncol=length(ids.patients), dimnames=list(pathways, ids.patients))

for(i in 1:nrow(df)){
	x <- df$Category[i]
	y <- df$SampleID[i]
	mat[x,y] <- df$EnrichmentScore[i]
}

write.table(mat, file.path(dir.data, "MESO_OUTLIERS_p01_pathway_enrichment_gobp.tsv"), sep="\t", row.names=T, col.names=NA, quote=F)

### PLOT PATHWAYS HEATMAP ----------------------------------------------------------------------------------
jColFun <- colorRampPalette(brewer.pal(n = 9, "Greys"))

file.plot <- file.path(dir.plot, "MESO_OUTLIERS_p01_pathway_heatmap_GOBP.pdf")
pdf(file.plot, height=6, width=6)
	heatmap.2(as.matrix(mat),
          col = jColFun(256),
          Colv=TRUE, Rowv=TRUE,
          dendrogram ="both", trace="none",  scale="none",
          cexCol=0.5, cexRow=0.5, margins = c(5,20),
          hclustfun = function(x) hclust(x, method = "ward.D2"),
          distfun = function(x) dist(x, method = "euclidean"),
          colsep=c(1:150), rowsep=c(1:150),
          sepcolor="white", sepwidth=c(0.0005,0.0005),
          key="TRUE", keysize=0.8, density.info="none")
dev.off()


require(data.table)
require(rstan)
require(EnvStats)
require(covid19AgeModel)

## command line parsing if any
args = list()
args[['location.index']] = 1
args[['with.flow']] = 1
args[['indir.results']] = '/rds/general/project/ratmann_covid19/live/age_renewal_usa/base_age_fsq_mobility_201015f8_cmdstanv-40states_tau10_Oct29_Levin/base_age_fsq_mobility_201015f8_cmdstanv-40states_tau10_Oct29_Levin-2558246[1].pbs'

args_line <-  as.list(commandArgs(trailingOnly=TRUE))
if(length(args_line) > 0)
{
  stopifnot(args_line[[1]]=='-indir.results')
  stopifnot(args_line[[3]]=='-location.index')
  stopifnot(args_line[[5]]=='-with.flow')
  args <- list()
  args[['indir.results']] <- args_line[[2]]
  args[['location.index']] <- args_line[[4]]
  args[['with.flow']] <- args_line[[6]]
}

#	print args
str(args)

#	read args
indir.results <- args$indir.results
location.index <- as.integer(args$location.index)
with.flow <- args$with.flow

#	read Stan input data and add location.index to parallelise computations
cat('\nReading Stan input data...')
infile.stanin <- list.files(indir.results, pattern='.*_stanin.RData$', recursive=TRUE)
stopifnot(length(infile.stanin)>0)
stopifnot(length(infile.stanin)<=1)
tmp <- load(file.path(indir.results, infile.stanin))
stopifnot(c('args','stan_data')%in%tmp)
stan_data$LOCATION_PROCESSING_IDX <- location.index
if(is.null(stan_data$counterfactual_school_effect)) stan_data$counterfactual_school_effect = -1

#	reset args
args[['work_dir']] <- getwd()

pkg.dir <- system.file(package = "covid19AgeModel" )

if(with.flow=='1')
{
  stan_data <- gqs_add_stan_data_for_flows(stan_data,dates)
}

if(is.null(stan_data$rev_iar_daysSinceInfection))
{
  stan_data <- gqs_add_stan_data_for_iar(stan_data)
}

#	read stanfits
cat('\nReading Stanfit ...')
infile.stanfits <- list.files(indir.results, pattern='.*_stanout.RData$', recursive=TRUE)
stopifnot(length(infile.stanfits)>0)
stopifnot(length(infile.stanfits)<=1)
tmp <- load(file.path(indir.results, infile.stanfits[1]))

#	find stan model and stan model for generating quantities
file_stanModel <- gsub('.*covid19AgeModel/(.*)','\\1',args$file_stanModel)
file_stanModel <- file.path(pkg.dir, file_stanModel)
file_stanModel_gqs <- gsub('cmdstanv','gqs',file_stanModel)
stopifnot( file.exists(file_stanModel_gqs) )

cat('\nCompiling gqs model file ...')
m2 <- rstan::stan_model(file_stanModel_gqs)

cat('\nGenerating quantities ...')
draws <- as.matrix(fit)
draws <- draws[,!grepl('rho0|Rt|RtByAge|E_deaths|E_deathsByAge|E_casesByAge|lp__', colnames(draws)) ]
fit2 <- rstan::gqs(m2, data=stan_data, draws=draws)
fit.gqs <- rstan::extract(fit2)

file <- file.path(indir.results, paste0(basename(args$job_dir), '_location',location.index,'_stangqs.RDS'))
io_saveRDS(fit.gqs, args[['work_dir']], dirname(file), basename(file), check_if_saved_n=10)

cat('\nFinished base-ages-generate-quantities.r ...')


#Load libraries
library(pacman)
p_load(tidyverse, tidylog, purrr, forcats, visdat, flextable, colorspace, gtsummary, tidymodels, tictoc) #Basic
p_load(textrecipes, tidytext) #Text processing helpers
p_load(parsnip, discrim, naivebayes, ranger, xgboost, kknn, keras, workflowsets, themis, stacks) #Models
doMC::registerDoMC(cores = parallel::detectCores(logical = FALSE)) #Parallel processing
set.seed(100)

#Load data
df <- readRDS("Data/2020 Mortality Data_clean.rds")

#Set-up outcomes list for map
outcomes.list <- c("Any Opioids", "Heroin", "Fentanyl", "Prescription.opioids", "Methamphetamine", "Cocaine",
                   "Benzodiazepines", "Alcohol", "Others")

#Create training/testing dataset
data_split <- map(outcomes.list, ~
  initial_split(df,
                prop = 0.8,
                strata = .x)
)

# Create dataframes for the two sets:
training <- map(data_split, ~
                  training(.x)
)
testing <- map(data_split, ~
                 testing(.x)
)

#Cross validation
cv_folds <- map2(training, outcomes.list, ~ vfold_cv(.x, v = 10, strata = .y)
)

# Set metrics for classification problem
multi_met <- metric_set(f_meas, accuracy, kap, roc_auc, sens, spec, ppv, npv)

#Set outcomes list
outcomes.list <- c("Any Opioids", "Heroin", "Fentanyl", "Prescription.opioids", "Methamphetamine", "Cocaine",
                   "Benzodiazepines", "Alcohol", "Others")
outcomes <- outcomes.list

#Set lists for models
models.list <- c("Logistic regression", "Naive Bayes",  "Random forest", "XGBoost", "KNN", "MLP", "SVM")
recipe.model.list <- c("recipe_Logistic.regression", "recipe_Naive.Bayes", "recipe_Random.forest",
                       "recipe_XGBoost", "recipe_KNN",  "recipe_MLP", "recipe_SVM")

#Set-up specs for classifiers
log_spec <- logistic_reg() %>%
  set_engine(engine = "glm") %>%
  set_mode("classification") # model mode
nb_spec <- naive_Bayes() %>%
  set_mode("classification") %>%
  set_engine("naivebayes")
rf_spec <- rand_forest(min_n = tune(), trees = tune(), mtry  = tune()) %>%
  set_engine("ranger", importance = "impurity") %>%
  set_mode("classification")
xgb_spec <- boost_tree(trees = tune(), tree_depth = tune(), mtry  = tune()) %>%
  set_engine("xgboost") %>%
  set_mode("classification")
knn_spec <- nearest_neighbor(neighbors = tune(), weight_func = tune()) %>%
  set_engine("kknn") %>%
  set_mode("classification")
svm_spec <- svm_linear(cost = tune()) %>%
  set_mode("classification") %>%
  set_engine("kernlab")
nnet_spec <-  mlp(hidden_units = tune(), penalty = tune(), epochs = tune()) %>%
  set_mode("classification") %>%
  set_engine("nnet")

#Model over lists
rec.list <- pmap(list(outcomes, outcomes.list, training), ~
                  recipe(. ~ text, data = ..3 %>% select(.data[[..1]], text)) %>%
                  #update_role(one_of(.x), new_role = "outcome") %>%
                  update_role(text, new_role = "predictor") %>%
                  step_tokenize(text,
                                options = list(lowercase = TRUE,
                                               strip_punct = TRUE)) %>%
                  step_tokenfilter(text, min_times = 5) %>%
                  step_stopwords(text) %>%
                  step_tfidf(text)
)

#Set-up workflow
wflw_set.list <- map(rec.list, ~ workflow_set(
      preproc = list(.x),
      models = list(Logistic.regression = log_spec, Naive.Bayes = nb_spec, Random.forest = rf_spec,
                    XGBoost = xgb_spec, KNN = knn_spec, SVM = svm_spec, MLP = nnet_spec))
)

#Set up parameter tunning
grid_ctrl <-
   control_grid(
      save_pred = TRUE,
      parallel_over = "everything",
      save_workflow = FALSE
   )

#Run workflow - very slow
tic()
grid_results.list <- map2(wflw_set.list, cv_folds, ~
   .x %>%
   workflow_map(
      seed = 100,
      resamples = .y,
      grid = 10,
      control = grid_ctrl,
      metrics = metric_set(recall, precision, f_meas, accuracy, kap, roc_auc, sens, spec, ppv, npv),
      )
)
time.training <- toc()

#Save/Load to local harddrive
saveRDS(grid_results.list, paste0("Output/grid_results", as.character(Sys.Date()),"tfidf.rds"))

###Collect metrics
#Create table with all results
results.list <- map2(cross2(1:length(outcomes), recipe.model.list),
             cross2(outcomes, models.list),
             ~ {
               extract_workflow_set_result(grid_results.list[[.x[[1]]]], id = .x[[2]]) %>% collect_metrics() %>% mutate(outcome = .y[[1]], model = .y[[2]])
               }
             )
results.tbl.w <- bind_rows(results.list) %>% pivot_wider(
  id_cols = c(.config, outcome, model),
  names_from = .metric,
  values_from = mean
)

#Summary statistics
statistic.plot.list <-  map2(1:length(outcomes), outcomes, ~ {
  grid_results.list[[.x]] %>%
  autoplot() +
    scale_y_continuous(limits = c(0, 1)) +
    labs(title = "Metrics",
       subtitle = paste(.y)) +
    theme_minimal()
})

statistic.best.plot.list <-  map2(1:length(outcomes), outcomes, ~ {
  grid_results.list[[.x]] %>%
  autoplot(select_best = TRUE) +
    scale_y_continuous(limits = c(0, 1)) +
    labs(title = "Metrics",
       subtitle = paste(.y)) +
    theme_minimal()
})

#Rank models
rank_res <- map2(1:length(outcomes), outcomes, ~ {
  rank_results(grid_results.list[[.x]],
               rank_metric = "f_meas",
               select_best = TRUE) %>% mutate(outcome = .y)
})

rank_res.table <- map(1:length(outcomes), ~ {
  rank_res[[.x]] %>% filter(.metric == "f_meas")
})
rank_res.table <- bind_rows(rank_res.table)

#Create table for word
table.train.all.ranked <- flextable::flextable(rank_res.table %>% mutate(across(where(is.numeric), ~round(.x, 3))) %>%
                       select(Substance = outcome, `Model` = model,
                              `Mean\nF-score` = mean, SE = std_err)) %>%
  set_caption(caption =  "Table. F-score in 10-fold cross validation of training dataset") %>%
  autofit() %>% theme_zebra(odd_header = "transparent", even_header = "transparent")
table.train.all.ranked

#Create ROC curves by model/outcome
roc.list <- map2(1:length(outcomes), outcomes, ~ {
  grid_results.list[[.x]] %>% collect_predictions() %>%
  group_by(model) %>%
  roc_curve(truth = .data[[.y]], estimate = .pred_1) %>%
  autoplot() +
  labs(
    title = "Receiver operator curve - Training",
    subtitle = paste(.y))
}
)

#Create PR curve by model/outcome
pr.list <-  map2(1:length(outcomes), outcomes, ~ {
  grid_results.list[[.x]] %>% collect_predictions() %>%
  group_by(model) %>%
  pr_curve(truth = .data[[y]], .pred_1) %>%
  autoplot() +
  labs(
    title = "Precision-recall curve - Training",
    subtitle = paste(.y))
}
)

#Table of best models
best_results.table <- map(1:length(outcomes), ~ {
  rank_res[[.x]] %>% filter(.metric == "f_meas" & rank < 4)
}
)
best_results.table <- bind_rows(best_results.table)

#Create table for word
table.train.best <- flextable::flextable(best_results.table %>% mutate(across(where(is.numeric), ~round(.x, 3))) %>%
                       select(Substance = outcome, `Model` = model,
                              `Mean\nF-score` = mean, SE = std_err)) %>%
  set_caption(caption =  "Table. Best performing models in 10-fold cross validation of training dataset") %>%
  autofit() %>% theme_zebra(odd_header = "transparent", even_header = "transparent")
table.train.best

###Set up for testing
#Select best model
best_results.list <- map2(1:length(outcomes), outcomes, ~ {
   grid_results.list[[.x]] %>%
   extract_workflow_set_result(rank_res[[.x]]$wflow_id[1]) %>%
   select_best(metric = "f_meas") %>% mutate(outcome = .y)
}
)

#Fit on test data
tic()
test_results <- map2(1:length(outcomes), data_split, ~ {
   grid_results.list[[.x]] %>%
   extract_workflow(rank_res[[.x]]$wflow_id[1]) %>%
   finalize_workflow(best_results.list[[.x]]) %>%
   last_fit(split = .y,
            metrics = metric_set(f_meas, accuracy, kap, roc_auc, sens, spec, ppv, npv))
}
)
time.testing <- toc()

#Save/Load to local harddrive
saveRDS(test_results, paste0("Output/test_results", as.character(Sys.Date()),"_tfidf.rds"))
#test_results <- readRDS("Output/test_results2021-08-22tfidf.rds")

#Table for test results
test_results.tbl <- map2(1:length(outcomes), outcomes, ~ {
  test_results[[.x]] %>% collect_metrics() %>% mutate(outcome = .y)
}
)

 test_results.tbl.w <- bind_rows(test_results.tbl) %>% pivot_wider(
  id_cols = c(outcome),
  names_from = .metric,
  values_from = .estimate
)

#Create table for word
table.test <- flextable::flextable(test_results.tbl.w %>% mutate(across(where(is.numeric), ~round(.x, 3))) %>%
                       select(Substance = outcome, `F-score` = `f_meas`, Accuracy = `accuracy`, Kappa = `kap`,
                              `Sensitivity\n(Recall)` = `sens`, Specificity = `spec`,
                              `Positive predictive value\n(Precision)` = `ppv`,
                              `Negative predictive value` = `npv`,
                              AUROC = `roc_auc`)) %>%
  set_caption(caption =  "Table. Diagnostic metrics of best performing models in test dataset") %>%
  autofit() %>% theme_zebra(odd_header = "transparent", even_header = "transparent")
table.test

###Error analysis
#Confusion matrix by model/outcome
test_CM_table <- map2(1:length(outcomes), outcomes, ~ {
test_results[[.x]] %>% collect_predictions() %>%
 conf_mat(.y, .pred_class)  %>%
  autoplot(type = "heatmap") +
  labs(
    title = "Confusion matrix",
    subtitle = paste(.y)
  )
})

#Error analysis from test set
error_analysis <- map2(1:length(outcomes), outcomes, ~ {
test_results[[.x]]$.predictions[[1]] %>% #filter(.data[[.y]] != .pred_class) %>%
    mutate(Error = ifelse(.data[[.y]] != .pred_class,1,0))
})

error_analysis_text <- map(1:length(outcomes), ~ {
  error_analysis[[.x]] %>% left_join(df %>% mutate(.row = row_number()) %>% select(.row, text), by = ".row")
})

#Save excel file with one df per sheet
p_load(openxlsx)
openxlsx::write.xlsx(error_analysis_text, paste0("Error/error_analysis_df_", Sys.Date(), ".xlsx"))

###Bootstrapping
#Confidence intervals
boot_test <- map(testing, ~ bootstraps(.x, times = 1000, apparent = TRUE)
)

tic()
bootstrap_results <- map2(1:length(outcomes), boot_test, ~ {
   grid_results.list[[.x]] %>%
   extract_workflow(rank_res[[.x]]$wflow_id[1]) %>%
   finalize_workflow(best_results.list[[.x]]) %>%
   fit_resamples(resamples = .y,
            metrics = metric_set(recall, precision, f_meas, accuracy, kap, roc_auc, sens, spec, ppv, npv))
}
)
time.bootstrap <- toc()

#Save/Load to local harddrive
saveRDS(bootstrap_results, paste0("Output/bootstrap_results", as.character(Sys.Date()),"_tfidf.rds"))

bootstrap_CI_results <- map2(1:length(outcomes), outcomes, ~ {
  bootstrap_results[[.x]] %>% collect_metrics(summarize = FALSE) %>%
    group_by(.metric) %>%
    summarize(mean = mean(.estimate, na.rm = T),
                                  CI.lower = quantile(.estimate, probs = c(0.025), na.rm = T),
                                  CI.upper = quantile(.estimate, probs = c(0.975), na.rm = T)
                                  ) %>%
    mutate(outcome = .y)
})

CI_results.tbl.w <- bind_rows(bootstrap_CI_results) %>% pivot_wider(
  id_cols = c(outcome),
  names_from = .metric,
  values_from = c(mean, CI.lower, CI.upper)
)

table.95CI <- flextable::flextable(CI_results.tbl.w %>% mutate(across(where(is.numeric), ~round(.x, 3))) %>%
  select(Substance = outcome,
         `F-score` = mean_f_meas, Lower = CI.lower_f_meas, Upper = CI.upper_f_meas,
         `Accuracy` = mean_accuracy, aLower = CI.lower_accuracy, aUpper = CI.upper_accuracy,
         `Kappa` = mean_kap, kLower = CI.lower_kap, kUpper = CI.upper_kap,
         `Sensitivity\n(Recall)` = `mean_sens`, sLower = CI.lower_sens, sUpper = CI.upper_sens,
         Specificity = `mean_spec`, spLower = CI.lower_spec, spUpper = CI.upper_spec,
         `Positive predictive value\n(Precision)` = `mean_ppv`, ppLower = CI.lower_ppv, ppUpper = CI.upper_ppv,
         `Negative predictive value` = `mean_npv`, npLower = CI.lower_npv, npUpper = CI.upper_npv,
         AUROC = `mean_roc_auc`, auLower = CI.lower_roc_auc, auUpper = CI.upper_roc_auc)) %>%
  set_caption(caption = "Table. Bootstrapped diagnostic metrics and 95% confidence intervals of best performing models in test dataset") %>%
  autofit() %>% theme_zebra(odd_header = "transparent", even_header = "transparent")
table.95CI

###Export to word
#Final tables/plots
tables.list <- list(table.train.all.ranked, table.train.best, table.test, table.95CI, error.tables.list)

plot.list <- list(p.heat, p.heat2, test_CM_table)

# write function
p_load(officer, flextable)
write_word_table <- function(var, doc){
  doc %>%
    body_add_flextable(var) %>%
    body_add_break() }

write_word_plot <- function(var, doc){
  doc %>%
    body_add_gg(var, style = "centered", height = 6, width = 8) %>%
    body_end_section_landscape()
    }
# list of tables and the doc
my_doc1 <- officer::read_docx()

# use walk (the invisible function of map) to include all tables in one doc
walk(tables.list, write_word_table, my_doc1)

# use walk to include plots
write_word_plot(statistic.plot.list, my_doc1)
write_word_plot(statistic.best.plot.list, my_doc1)
write_word_plot(test_CM_table, my_doc1)

#Create word doc
print(my_doc1, target = paste0("Tables/NLP_tables_", Sys.Date(), "_tf_idf.docx")) %>% invisible()


#!/usr/bin/Rscript

library(gsheet);
library(ggplot2);
library(grid);

## see https://stackoverflow.com/questions/22873602/importing-data-into-r-from-google-spreadsheet

## load metadata from google spreadsheet [for paper]
data.tbl <- gsheet2tbl("docs.google.com/spreadsheets/d/1480qh5zNRN5ghm0qWisfcf6pCLoPs4xuzs5aMSeKg5Q");
#### load metadata from google spreadsheet [for live version]
##data.tbl <- gsheet2tbl("docs.google.com/spreadsheets/d/19Tl5Cv_SnQ4gA2zcGAMxmxqLz6lyGnSp0sG_r9h7z2E");

## custom cleaning of data
data.tbl <- data.tbl[-1,]; # remove first line (very short run)
data.tbl$`Flowcell run time` <- as.numeric(sub(" h$","",data.tbl$`Flowcell run time`)); # convert run time to hours
data.tbl$`Final library input [ng]` <- # set negative input to 0
    as.numeric(sub("^< ","",data.tbl$`Final library input [ng]`));
data.tbl$`Size selection?` <- # replace long strings
    sub("freeze.*$","freeze/thaw",data.tbl$`Size selection?`);

## Set up X-Y dotplots
data.plots <- lapply(seq_len(ncol(data.tbl)), function(ci){
    xCol = "GB data called";
    plot.res <- ggplot(data.tbl, aes_string(x=as.name(colnames(data.tbl)[ci]),
                                            y=as.name("GB data called"))) + geom_point() +
        geom_quantile(formula = y ~ x);
    if(is.numeric(data.tbl[[ci]])){ # add correlation test for numeric values
        res <- cor.test(data.tbl$`GB data called`, as.numeric(data.tbl[[ci]]));
        rval <- round(res$estimate,2);
        ## http://www.cs.utexas.edu/~cannata/dataVis/Class%20Notes/Beautiful%20plotting%20in%20R_%20A%20ggplot2%20cheatsheet%20_%20Technical%20Tidbits%20From%20Spatial%20Analysis%20&%20Data%20Science.pdf
        plot.res <- plot.res + annotation_custom(grobTree(textGrob(label=sprintf("r = %0.2f", rval), just="right",
                                                                   x=0.5, y=0.1, hjust=0, gp=gpar(fontsize=15))));
    }
    plot.res;
 });

pdf("out_MUG.pdf", width=16, height=12);
##png("out_MUG.png", width=1600, height=1200);
## Create matrix for plot output
## based on http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/
layout.mat <- matrix(seq(1,length(data.plots)), ncol=ceiling(sqrt(length(data.plots))));
grid.newpage();
pushViewport(viewport(layout = grid.layout(nrow(layout.mat), ncol(layout.mat))));
## Write plots to matrix output
for(ci in 1:length(layout.mat)){
    poss <- as.data.frame(which(layout.mat == ci, arr.ind=TRUE));
    print(data.plots[[ci]], vp = viewport(layout.pos.row=poss$row,
                                          layout.pos.col=poss$col));
}
invisible(dev.off());


#cd /proj/sens2016007/nobackup/Zhiwei/SummerProject/SelectPacBio
#changeP_SigCNVR="/proj/sens2016007/nobackup/Zhiwei/SummerProject/FormatCNVbedFolder/estimateP_folder/SigCNVR_size_changePvalue.bed"
# population raw output: less -S  /proj/nobackup/sens2016007/Zhiwei/BAManalyses/CNVnatorMain/OptBinSize_q0/PopulationMatrixFolder/changeName_biomarkAssFolder/CNV_1021.collapse.bed

# module load R/3.4.3
# module load R_packages/3.4.3
#R:
setwd("/proj/sens2016007/nobackup/Zhiwei/SummerProject/SelectPacBio")
rm(list = ls())
CNVbed <- readRDS("/proj/nobackup/sens2016007/Zhiwei/BAManalyses/CNVnatorMain/OptBinSize_q0/PopulationMatrixFolder/changeName_biomarkAssFolder/CNVbed.rds")
Sigbed <- read.table("/proj/sens2016007/nobackup/Zhiwei/SummerProject/FormatCNVbedFolder/estimateP_folder/SigCNVR_size_changePvalue.bed", sep = "\t")
colnames(Sigbed) <- c("CNVR_CHROM", "CNVR_Start", "CNVR_End", "CNVR_Size")
# for population matrix: set negative value(low quality) to NA:
CNVbed[CNVbed<0] <- NA
# fileter the Sig CNVRs by 2kb
Sigbed <- Sigbed[Sigbed$CNVR_Size >= 2000, ]

SelectBed_df <- data.frame()
for(i in 1:nrow(Sigbed)) {
  print(paste0("Formatting CNVR NO.", i))
  dat <- subset(CNVbed, CHROM==Sigbed[i,"CNVR_CHROM"] & Start>=Sigbed[i,"CNVR_Start"] & End<=Sigbed[i,"CNVR_End"])
  # calculate the mean copy number for each CNVR, individuals with one or more 'NA' will have NA copy number genotype in the CNVR
  dat_average <- apply(dat[,4:ncol(dat)], 2, function(x){mean(x)} ) #sum(is.na(SelectBed_df)): with na.omit=TRUE:145 with out: 925
  SelectBed <- data.frame(Sigbed[i, ], data.frame(t(dat_average), check.names=FALSE), check.names=FALSE)
  SelectBed_df <- rbind(SelectBed_df, SelectBed)
}
# exclude MHC regions:
# vector with sample names and number of Ref/NA regions, sort from low(best) to high value.
noMHC <- sort(apply(SelectBed_df[c(1:17,26),5:ncol(SelectBed_df)], 2, function(x) {sum(x==2|is.na(x))} ))
write.table(noMHC, "noMHC_Ref_NA_countt.txt", sep="\t")
# noMHC <- sort(apply(SelectBed_df[c(1:17,26),5:ncol(SelectBed_df)], 2, function(x) {sum(x==2|is.na(x))} ))[1:64]
# withMHC <- sort(apply(SelectBed_df[,5:ncol(SelectBed_df)], 2, function(x) {sum(x==2|is.na(x))} ))[1:64]
# check_both <- names(noMHC) %in% names(withMHC)
# names(noMHC)[check_both]
# prioritisation list:
#Priority_df <- cbind(SelectBed_df[,1:4], SelectBed_df[names(noMHC)[check_both]])
Priority_df <- cbind(SelectBed_df[,1:4], SelectBed_df[,names(noMHC)])
# NA_2_count <- c("NO","MHC","Ref/NA","Count",noMHC)
# names(NA_2_count)[1:4] <-  c("CNVR_CHROM", "CNVR_Start", "CNVR_End", "CNVR_Size")
# test_df <- rbind(NA_2_count, Priority_df)
# save the prioritisation list:
write.table(Priority_df, "PriorityOrder_list.txt", sep="\t", row.names = F)
saveRDS(Priority_df, "PriorityOrder_list.rds")
# reorder whole population:
#order_SelectBed_df <- cbind(SelectBed_df[,1:4], SelectBed_df[,order])
#


library(shiny)
library(ggplot2)
library(plyr)
library(leaflet)
library(raster)
library(rgdal)
#library(mailR)
library(dygraphs)
library(xts)
library(zoo)
library(reshape2)
library(DT)
library(shinyjs)
library(xlsx)
library(shinythemes)
library(shinyBS)
library(rhandsontable)
library(scales)
library(tools)
library(openssl)
library(xts)
#library(randomcoloR)
library(RSQLite)
library(reshape)
library(showtext)

source("bin/ETmodel.R", chdir=T)
source("bin/waterbalancemodel.R", chdir=T)

showtext_auto()

## Read db.sql for liveNDVI data
data_db <- dbConnect(drv = RSQLite::SQLite(), dbname="data-ndvi/guantao-ndvi.sql")
data_root_path <- "data-ndvi/ndvi-tifs/"

## Load translation files
dictionary=as.data.frame(read.csv("data/dictionary.csv",header=TRUE,
                                  colClasses = "character",sep='\\',
                                  check.names=FALSE))
dictionaryUI=as.data.frame(read.csv("data/dictionary_UI.csv",header=TRUE,
                                    colClasses = "character",sep='\\',
                                    check.names=FALSE))
rownames(dictionary) <- dictionary[,1]
dictionary[,1] <- NULL
rownames(dictionaryUI) <- dictionaryUI[,1]
dictionaryUI[,1] <- NULL

crop <- read.table("data/croptypes.csv",header=TRUE,row.names = 1,sep=",")
soil <- read.table("data/soiltypes.csv",header=TRUE,row.names = 1,sep=",")
irrigationefficiency<-read.table("data/irrigationefficiency.csv",header=TRUE,
                                 sep=",")
conveyanceefficiency<-read.table("data/conveyanceefficiency.csv",header=TRUE,
                                 sep=",")
watersourcenorm<-read.table("data/watersource.csv",header=TRUE,sep=",")
norm <- read.table("data/irrigationnorm.csv", header=TRUE, sep=",")

## Select region shaepfile
init_shp<-readOGR("data/shapefiles/NAME_3_Guantao.shp")
bbox = extent(init_shp)

## Define & Load local meteodata
datafiles<-list("data/meteodata/GUANTAO_ST.csv",
                "data/meteodata/user_dummy.csv")
names<-list("guantaostationlabel","userstationlabel")
lats<-list(36.53313,36.6)
lons<-list(115.3111,115.25)
alt <- list(57,57)
meteo_df <- do.call(rbind, Map(data.frame, NAME=names, DATAFILE=datafiles,
                               LAT=lats, LON=lons, ALT=alt))
rm(list = c("names","lats","lons","alt"))

## Pre-compute ET0 for all stations
clim <- list()
loc <- list()
for (item in 1:(length(meteo_df$NAME))) {
  temp_clim <- read.csv(as.character(meteo_df[item,"DATAFILE"]),header = TRUE,
                        stringsAsFactors = FALSE)
  loc[[item]] <- data.frame(LAT=meteo_df[item,"LAT"],LON=meteo_df[item,"LON"],
                            ALT=meteo_df[item,"ALT"])
  temp_clim$RAD <- monthly.radiation(temp_clim,loc[[item]])
  temp_clim$ET <- as.numeric(monthly.PenmanFAO(temp_clim,loc[[item]]))
  if (!("PRCP_25" %in% colnames(temp_clim))) {
    temp_clim$PRCP_25 <- c(1:12)*NA
  }
  clim[[item]] <- temp_clim
}
default_climate <- clim
default_location <- loc
rm(list = c("clim","loc","item","temp_clim"))

## Record App access in logfile. TODO: This feature does not work with SSL. Need to figure out why
logfile = "log/access.log"
if (!file.exists(logfile)) {
  if (!dir.exists(dirname(logfile))) {
    dir.create(dirname(logfile))
  }
  write(paste('TIME','USER IP','LOCATION','COUNTRY','CITY',sep='\t'),
        file=logfile)
}

## Some Constants
outputtypes <- c("ETo","ETc","PRCP","PRCPeff","Water_Deficit","PRCP_25",
                 "PRCPeff_25","Water_Deficit_25","CROPDAYS")
outputcolors <- c("#E41A1C","#FF7F00","#253494","#1F78B4","#1B9E77","#80b1d3",
                  "#a6cee3","#a6d854","#4D4D4D")
irrigationstrategies <- c("monthly","minimum")
monthnames <- c<-c("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct",
                   "Nov","Dec")

# User Database
db <- dbConnect(drv = RSQLite::SQLite(), dbname="data/userdb.sql")
if (length(dbListTables(db))==0) {
  query <- dbSendStatement(conn = db,"CREATE TABLE user (ID INTEGER PRIMARY KEY, username TEXT,password TEXT, email TEXT, dataid INTEGER)")
  dbClearResult(query)
  query <- dbSendStatement(conn = db,"CREATE TABLE data (ID INTEGER PRIMARY KEY, username TEXT, data BLOB, summary BLOB, IDcounter BLOB, colors BLOB)")
  dbClearResult(query)
}

## Some Helper Functions
doy2date <- function(doy,year) {
  # argument doy can be a vector, year must be a single value
  origin = as.Date(paste(year,'-01-01',sep=''))-1
  func <- function(x) {
    date <- origin + x
    if (year(date)!=year) {
      return(NA)
    } else {
      return(date)
    }
  }
  as.Date(sapply(doy, func))
}

captchachoices <- 6
generatecaptcha <- function() {
    randvec <- runif(5, 0, 1)
    vec <- randvec/mean(randvec)*round(runif(1,1,captchachoices))  #generate 5 random numbers with mean between 1 and the value of captchachoices, solution is the mean
    return(vec)
}


library(xts)
predict.cases <- function(x=d$`新增本土确诊（含无症状）`, date=d$date) {
    x <- xts(x, date)
}