## Created on Monday, November  2, 2020 at 10:38pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2020, SomeWeekendReading.  All rights reserved.  As if you care.

##
## Research question: Does the MWRA's metagenomic measurement of SARS-COV-2 RNA in
## wastewater predict later hospitalization or death rates or positive test rates?
##
## Hypotheses: hospitalization & death rates might work; positive test rates probably
## won't, due to changes in test availability, test type, and testing policy.
##
## Data sources (2020-Nov-02):
## - Mass COVID hospitalization/death rates from:
##   https://covidtracking.com/data/state/massachusetts
## - MWRA metagenomics painfully extracted, almost by hand, from a PDF at:
##   http://www.mwra.com/biobot/biobotdata.htm
##
## Did not consider test positivity rates, since testing has changed from basically unavailable
## to somewhat available, and the reporting has been spotty enough to make the numbers useless.
##
## *** NB: on 2020-09-02 and -07, in hosp/death dataset, hospIncr is NEGATIVE!  This is in
## the orignal data, where hospitalizedIncrease on 2020-09-02 is -91, for some reason.
##

toolsDir <- "../../tools"                              # Various tools available from author
source(file.path(toolsDir, "pipeline-tools.r"))        # Pipeline construction tools
source(file.path(toolsDir, "graphics-tools.r"))        # Various graphics hacks

library("lubridate")                                   # For round_date()
library("zoo")                                         # For rollmean()

doit <- function(## Inputs
                 dataDir          = "./data",
                 mwraDataFile     = "MWRAData20201027-NSdata.tsv",
                 covidDataFile    = "massachusetts-history.csv",
                 covidDataEmpties = c("inIcuCumulative",

                                      "negativeTestsAntibody", "negativeTestsPeopleAntibody",
                                      "negativeTestsViral",

                                      "onVentilatorCumulative",

                                      "positiveTestsAntibody", "positiveTestsAntigen",
                                      "positiveTestsPeopleAntibody", "positiveTestsPeopleAntigen",

                                      "totalTestEncountersViral", "totalTestsAntibody",
                                      "totalTestsAntigen"),
                 waveDate         = as.Date("2020-07-01", format = "%Y-%m-%d"),

                 ## Outputs
                 resultsDir    = "./results",
                 txFile        = "mwra-covid-transcript.txt",
                 jointDataFile = "mwra-covid-joint-data.tsv",
                 nsPlotFile    = "plot-north-south.png",
                 medPlotFile   = "plot-med-loads-vs-RNA.png") {

  reportStructure <- function(df) {                    # Report structure of a dataframe
    cat(sprintf("\n  - Structure:\n    o %d rows\n    o %d columns: %s",
                nrow(df), ncol(df), paste(colnames(df), collapse = ", ")))
  }                                                    # Basically shape + column names

  loadMWRAData <- function(dataDir, mwraDataFile) {    # Load the MWRA's metagenomic data
    f  <- file.path(dataDir, mwraDataFile)             # Painfully hand-extracted from a PDF
    cat(sprintf("* Reading MWRA wastewater RNA data from %s", f))
    df <- subset(transform(read.table(f, sep = "\t", header = TRUE, comment.char = "#"),
                           Sample.Date = as.Date(as.character(Sample.Date), format = "%m/%d/%Y")),
                 select = c(Sample.Date, Southern.7.sample.avg, Northern.7.sample.avg))
    colnames(df)[1:3] <- c("Date", "South.7", "North.7")

    reportStructure(df)                                # See what fish we caught
    df                                                 # Return the data
  }                                                    #

  loadCOVIDData <- function(dataDir, covidDataFile, covidDataEmpties) {
    f  <- file.path(dataDir, covidDataFile)            #
    cat(sprintf("\n* Reading Mass COVID data from %s", f))
    df <- transform(read.table(f, sep = ",", header = TRUE),
                    date = as.Date(as.character(date), format = "%Y-%m-%d"))
    sapply(covidDataEmpties, function(emptyCol) { stopifnot(all(is.na(df[, emptyCol]))) })
    df <- subset(df, select = c(date, deathIncrease, hospitalizedIncrease))
    df <- df[order(df$"date"), ]                       # Sort by date, shorten column names
    colnames(df)[1:3] <- c("Date", "deadIncr", "hospIncr")

    weekMeanNDec <- function(x, n) { round(rollmean(x, 7, NA, align = "right"), digits = n) }
    stopifnot(all(diff(df$"Date") == 1))               # Check no missing dates
    df <- subset(transform(df,                         # 7 day rolling mean, exploit no missing dates
                           deadIncr.7 = weekMeanNDec(deadIncr, 1),
                           hospIncr.7 = weekMeanNDec(hospIncr, 1)),
                select = -c(deadIncr, hospIncr))       #

    reportStructure(df)                                # See what we caught
    df                                                 # Return the data
  }                                                    #

  makeJointData <- function(mwraData, covidData, resultsDir, jointDataFile) {
    cat("\n* Constructing inner join on dates")        # Combine RNA and medical load data
    df <- merge(mwraData, covidData, by = "Date", all = FALSE)
    df <- df[order(df$"Date"), ]                       # Sort it by date
    df <- subset(df, subset = complete.cases(df))      # Drop initial 6 rows (no 7 day average)
    cat("\n  - Complete cases only, to drop the initial 6 rows w/o 7 day trailing means")
    ## Combine North & South districts by mean to get overall RNA measure
    df <- transform(df, RNA.7 = round((North.7 + South.7) / 2.0, digits = 1))
    df <- df[, c("Date", "North.7", "South.7", "RNA.7", "hospIncr.7", "deadIncr.7")]

    f  <- file.path(resultsDir, jointDataFile)         # Save it away for peer review
    saveDataframe(df, f)                               #
    cat(sprintf("\n  - Saved to %s", f))               #

    reportStructure(df)                                # See what we caught
    df                                                 # Return the data
  }                                                    #

  plotNorthSouth <- function(jointData, resultsDir, nsPlotFile) {
    dateRange <- c(floor_date(min(jointData$"Date"), "month"),
                   ceiling_date(max(jointData$"Date"), "month"))
    f <- file.path(resultsDir, nsPlotFile)             #
    withPNG(f, 850, 400, FALSE, function() {           #
      withPars(function() {                            #
        rnaCols  <- c("blue",  "gray")                 #
        rnaNames <- c("North", "South")                #
        matplot(x = jointData$"Date",                  # North & south RNA vs time
                y = subset(jointData, select = sapply(rnaNames, function(c) { sprintf("%s.7", c) })),
                type = "p", pch = 21, col = "black", bg = rnaCols, log = "y", cex = 1.5,
                xaxt = "n", xlab = NA, ylab = "RNA (wk avg, log scale)",
                main = "RNA Levels vs Time")           #
        axis.Date(1, x = dateRange, format = "%Y-%m-%d")
        legend("topright", bg = "antiquewhite", inset = 0.01,
               pch = 21, pt.bg = rnaCols, pt.cex = 2, legend = rnaNames)

        scatterplotWithDensities(xs = jointData$"South.7", ys = jointData$"North.7",
                                 bgs = "steelblue", cex = 1.5, log = "xy",
                                 regressionColor = NULL, # doesn't work on log scale
                                 xlab = "South RNA (log scale)", ylab = "North RNA (log scale)",
                                 main = as.expression(bquote(bold(paste(
                                     "RNA Correlation: ",
                                     bolditalic(R)^2 == .(
                                       sprintf("%.0f", #
                                               100.0 * cor(jointData$"North.7",
                                                           jointData$"South.7")^2)),
                                     "%")))))          #

        title(main = "MWRA Wastewater RNA: North vs South", outer = TRUE)

      }, pty   = "m",                                  # Maximal plotting area
         bg    = "transparent",                        # Transparent background
         mar   = c(7, 4, 2, 1),                        # Margins (e.g., to hold date labels)
         mgp   = c(2.5, 0.5, 0),                       # Axis title, label, tick
         mfrow = c(1, 2),                              # 1x2 array of plots
         oma   = c(0, 0, 1, 0),                        # Make room at top for overall title
         ps    = 16,                                   # Larget type size for file capture
         las   = 2)                                    # Labels perpendicular to axes
    })                                                 # End file capture
    cat(sprintf("* Plot of north vs south RNA to %s", f))
    TRUE                                               # Flag that it was done
  }                                                    #

  plotMedLoadsVsRNA <- function(jointData, waveDate, resultsDir, medPlotFile) {
    dateRange <- c(floor_date(min(jointData$"Date"), "month"),
                   ceiling_date(max(jointData$"Date"), "month"))
    f         <- file.path(resultsDir, medPlotFile)    #
    withPNG(f, 850, 400, FALSE, function() {           #
      withPars(function() {                            #
        medNames <- c("hospIncr.7", "deadIncr.7")      #
        medCols  <- c("green", "red")                  #
        matplot(x = jointData$"Date",                  # Mean RNA, hospitalizations, deaths vs time
                y = subset(jointData, select = c("RNA.7", medNames)),
                type = "p", pch = 21, col = "black", bg = c("steelblue", medCols), cex = 1.5,
                xaxt = "n", xlab = NA, ylab = "Medical Loads & RNA",
                main = "Medical Loads & RNA vs Time")  #
        axis.Date(1, x = dateRange, format = "%Y-%m-%d")
        abline(v = waveDate, lty = "dashed", col = "black")
        text(x      = c(as.Date("2020-06-01", format = "%Y-%m-%d"),
                        as.Date("2020-08-01", format = "%Y-%m-%d")),
             y      = c(200, 200),                     #
             adj    = c(0.5, 0.5),                     #
             labels = c("Wave 1", "Wave 2"))           #
        text(x      = c(as.Date("2020-06-01", format = "%Y-%m-%d"),
                        as.Date("2020-09-01", format = "%Y-%m-%d")),
             y      = c(175, 175),                     #
             adj    = c(0.5, 0.5),                     #
             labels = c("Tracks RNA", "Does NOT Track RNA"))
        legend("topright", bg = "antiquewhite", inset = 0.01,
               pch = 21, pt.bg = c("steelblue", medCols), pt.cex = 2,
               legend = c("RNA", "Hospitalized", "Dead"))

        wave1Data <- subset(jointData, subset = Date <= waveDate)
        wave2Data <- subset(jointData, subset = Date >  waveDate)
        matplot(x = wave1Data$"RNA.7",                 # Hospitalizations, deaths, vs mean RNA
                y = subset(wave1Data, select = medNames),
                pch = 21, type = "p", col = "black", bg = medCols, cex = 1.5,
                xlim = range(jointData$"RNA.7"),       #
                ylim = range(subset(jointData, select = medNames)),
                xlab = "RNA (wk avg)", ylab = "Medical Load (wk avg)",
                main = "Medical Loads vs RNA")         #
        points(x = wave2Data$"RNA.7", y = wave2Data$"hospIncr.7",
               pch = 22, type = "p", col = "black", bg = "lightgreen", cex = 1.5)
        points(x = wave2Data$"RNA.7", y = wave2Data$"deadIncr.7",
               pch = 22, type = "p", col = "black", bg = "pink", cex = 1.5)
        text(x =  50, y = 150, labels = "Wave 1: Tracks RNA",        srt = 45)
        text(x = 160, y =   0, labels = "Wave 2: Does NOT Track RNA")
        legend("topleft", bg = "antiquewhite", inset = 0.01, ncol = 2, pt.cex = 2,
               pch    = c(21,      21,    22,      22),#
               pt.bg  = c(medCols, "lightgreen", "pink"),
               legend = c("Wave 1 Hospitalized", "Wave 1 Dead",
                          "Wave 2 Hospitalized", "Wave 2 Dead"))

        title(main = "MWRA Wastewater RNA and Medical Loads", outer = TRUE)

      }, pty   = "m",                                  # Maximal plotting area
         bg    = "transparent",                        # Transparent background
         mar   = c(7, 4, 2, 1),                        # Margins (e.g., to hold date labels)
         mgp   = c(2.5, 0.5, 0),                       # Axis title, label, tick
         mfrow = c(1, 2),                              # 1x2 array of plots
         oma   = c(0, 0, 1, 0),                        # Make room at top for overall title
         ps    = 16,                                   # Larget type size for file capture
         las   = 2)                                    # Labels perpendicular to axes
    })                                                 # End file capture
    cat(sprintf("\n* Plot of medical loads vs RNA to %s", f))
    TRUE                                               # Flag that it was done
  }                                                    #

  showWaveCorrelations <- function(jointData, waveDate) {

    cat("\n* Correlations, using all data:\n")         # Correlation matrix for all times
    print(round(cor(subset(jointData, select = -Date)), digits = 2))

    cat("\n* Correlations, first wave data:\n")        # Correlation matrix for first wave only
    print(round(cor(subset(jointData, subset = Date <= waveDate, select = -Date)), digits = 2))

    cat("\n* Correlations, second wave data:\n")       # Correlation matrix for second wave only
    print(round(cor(subset(jointData, subset = Date > waveDate, select = -Date)), digits = 2))
  }                                                    #

  withTranscript(dataDir, resultsDir, txFile, "MWRA COVID Analysis", function() {

    heraldPhase("Archival")                            # For peer review
    archiveAnalysisScript(resultsDir, "./2020-11-04-wastewater-coronavirus-rna-vs-medical-loads-analysis.r")

    heraldPhase("Loading datasets and constructing joint dataset")
    maybeAssign("mwraData",  function() { loadMWRAData(dataDir, mwraDataFile) })
    maybeAssign("covidData", function() { loadCOVIDData(dataDir, covidDataFile, covidDataEmpties) })
    maybeAssign("jointData", function() {              # Assemble via inner join on dates
      makeJointData(mwraData, covidData, resultsDir, jointDataFile)
    })                                                 #
    cat("\n")                                          #
    ## *** NB: missing dates, due to missing dates in MWRA RNA data:
    ## > diff(jointData$"Date")

    heraldPhase("Exploratory plots")                   # See the general shape of the data
    maybeAssign("nsPlotDone",  function() { plotNorthSouth(jointData, resultsDir, nsPlotFile) })
    maybeAssign("medPlotDone", function() {            #
      plotMedLoadsVsRNA(jointData, waveDate, resultsDir, medPlotFile)
    })                                                 #
    showWaveCorrelations(jointData, waveDate)          # Look @ change in correlations?!
    cat("\n")                                          #

    ## We would do something like this, except the data is clearly telling us we don't understand it!
    ## *** cross-correlation with time lags up to 21 days
    ## *** regressions
    ## *** time series MA(q) models

  })                                                   # End of transcript capture
}                                                      #


#### 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)
}


## Version of gamm using lme4 as fit engine. (c) Simon N. Wood 2009-20
## Reparameterization trick as Wood (2004,2006).
## fooling lmer using Fabian Scheipl's trick (now adapted for lme4 >1.0).

gamm4.setup<-function(formula,pterms,
                      data=stop("No data supplied to gamm.setup"),knots=NULL)
## set up the model matrix, penalty matrices and auxilliary information about the smoothing bases
## needed for a gamm4 fit.
## There is an implicit assumption that any rank deficient penalty does not penalize
## the constant term in a basis.
## 1. Calls gam.setup, as for a gam to produce object G suitable for estimating a gam.
## 2. Works through smooth list, G$smooth, modifying so that...
##    i) Smooths are reparameterized to have a sequence of (portion of) identity matrix
##       penalties.
##    ii) 'random' list is accumulated containing random effect model matrices for terms.
##    iii) Sparse version of full model matrix in original parameterization is also accumulated
##    iv) Various indices are created for moving between the parameterizations.
{
  ## first simply call `gam.setup'....

  G <- mgcv:::gam.setup(formula,pterms,
                 data=data,knots=knots,sp=NULL,
                 min.sp=NULL,H=NULL,absorb.cons=TRUE,sparse.cons=0,gamm.call=TRUE)

  if (!is.null(G$L)) stop("gamm can not handle linked smoothing parameters (probably from use of `id' or adaptive smooths)")
  # now perform re-parameterization...

  first.f.para <- G$nsdf+1

  random <- list()

  if (G$nsdf>0) ind <- 1:G$nsdf else ind <- rep(0,0)
  X <- G$X[,ind,drop=FALSE] # accumulate fixed effects into here

  xlab <- rep("",0)

  G$Xf <- as(X,"dgCMatrix") ## sparse version of full matrix, treating smooths as fixed

  first.para <- G$nsdf+1

  used.names <- names(data) ## keep track of all variable names already used

  if (G$m) for (i in 1:G$m) { ## work through the smooths

    sm <- G$smooth[[i]]
    sm$X <- G$X[,sm$first.para:sm$last.para,drop=FALSE]
    rasm <- mgcv::smooth2random(sm,used.names,type=2) ## convert smooth to random effect and fixed effects
    used.names <- c(used.names,names(rasm$rand))

    sm$fixed <- rasm$fixed

    ## deal with creation of sparse full model matrix
    if (!is.null(sm$fac)) {
      flev <- levels(sm$fac) ## grouping factor for smooth
      n.lev <- length(flev)
      for (k in 1:n.lev) {
        G$Xf <- cbind2(G$Xf,as(sm$X*as.numeric(sm$fac==flev[k]),"dgCMatrix"))
      }
    } else {
      n.lev <- 1
      G$Xf <- cbind2(G$Xf,as(sm$X,"dgCMatrix"))
    }

    ## now append random effects to main list
    n.para <- 0 ## count random coefficients
    #rinc <- rind <- rep(0,0)
    if (!sm$fixed) {
      for (k in 1:length(rasm$rand)) n.para <- n.para + ncol(rasm$rand[[k]])
      sm$lmer.name <- names(rasm$rand)
      random <- c(random,rasm$rand)
      sm$trans.D <- rasm$trans.D
      sm$trans.U <- rasm$trans.U ## matrix mapping fit coefs back to original
    }

    ## ensure stored first and last para relate to G$Xf in expanded version

    sm$last.para <- first.para + ncol(rasm$Xf) + n.para - 1
    sm$first.para <- first.para
    first.para <- sm$last.para + 1

    if (ncol(rasm$Xf)) {
      Xfnames <- rep("",ncol(rasm$Xf))
      k <- length(xlab)+1
      for (j in 1:ncol(rasm$Xf)) {
        xlab[k] <- Xfnames[j] <-
        new.name(paste(sm$label,"Fx",j,sep=""),xlab)
        k <- k + 1
      }
      colnames(rasm$Xf) <- Xfnames
    }

    X <- cbind(X,rasm$Xf) # add fixed model matrix to overall fixed X

    sm$first.f.para <- first.f.para
    first.f.para <- first.f.para + ncol(rasm$Xf)
    sm$last.f.para <- first.f.para - 1 ## note less than sm$first.f.para => no fixed

    ## store indices of random parameters in smooth specific array
    sm$rind <- rasm$rind
    sm$rinc <- rasm$rinc

    sm$pen.ind <- rasm$pen.ind ## pen.ind==i TRUE for coef penalized by ith penalty

    sm$n.para <- n.para

    sm$X <- NULL ## delete model matrix

    G$smooth[[i]] <- sm  ## replace smooth object with extended version
  }

  G$random <- random ## named list of random effect matrices
  G$X <- X  ## fixed effects model matrix

  G
} ## end of gamm4.setup

gamm4 <- function(formula,random=NULL,family=gaussian(),data=list(),weights=NULL,
      subset=NULL,na.action,knots=NULL,drop.unused.levels=TRUE,REML=TRUE,
      control=NULL,start=NULL,verbose=0L,...) {
# Routine to fit a GAMM to some data. Fixed and smooth terms are defined in the formula, but the wiggly
# parts of the smooth terms are treated as random effects. The onesided formula random defines additional
# random terms.

  if (!is.null(random)) {
    if (!inherits(random,"formula")) stop("gamm4 requires `random' to be a formula")
    random.vars <- all.vars(random)
  } else random.vars <- NULL

  # create model frame.....
  gp <- interpret.gam(formula) # interpret the formula

  mf <- match.call(expand.dots=FALSE)

  mf$formula <- gp$fake.formula
  mf$REML <- mf$verbose <- mf$control <- mf$start <- mf$family <- mf$scale <-
             mf$knots <- mf$random <- mf$... <-NULL ## mf$weights?
  mf$drop.unused.levels <- drop.unused.levels
  mf[[1]] <- as.name("model.frame")
  pmf <- mf
  gmf <- eval(mf, parent.frame()) # the model frame now contains all the data, for the gam part only
  gam.terms <- attr(gmf,"terms") # terms object for `gam' part of fit -- need this for prediction to work properly

  if (length(random.vars)) {
    mf$formula <- as.formula(paste(paste(deparse(gp$fake.formula,
            backtick = TRUE), collapse = ""), "+", paste(random.vars,
            collapse = "+")))
    mf <- eval(mf, parent.frame())
  } else mf <- gmf
  rm(gmf)

  if (nrow(mf)<2) stop("Not enough (non-NA) data to do anything meaningful")

  ## summarize the *raw* input variables
  ## note can't use get_all_vars here -- buggy with matrices
  vars <- all.vars(gp$fake.formula[-2]) ## drop response here
  inp <- parse(text = paste("list(", paste(vars, collapse = ","),")"))
  dl <- eval(inp, data, parent.frame())
  names(dl) <- vars ## list of all variables needed
  var.summary <- mgcv:::variable.summary(gp$pf,dl,nrow(mf)) ## summarize the input data

  ## lmer offset handling work around...
  mvars <- vars[!vars%in%names(mf)] ## variables not in mf raw -- can cause lmer problem
  if (length(mvars)>0) for (i in 1:length(mvars)) mf[[mvars[i]]] <- dl[[mvars[i]]] ## append raw versions to mf

  rm(dl) ## save space

  pmf$formula <- gp$pf
  pmf <- eval(pmf, parent.frame()) # pmf contains all data for non-smooth part
  pTerms <- attr(pmf,"terms")

  if (is.character(family)) family<-eval(parse(text=family))
  if (is.function(family)) family <- family()
  if (is.null(family$family)) stop("family not recognized")
  if (family$family == "gaussian" && family$link == "identity") linear <- TRUE else linear <- FALSE
  # now call gamm4.setup

  G <- gamm4.setup(gp,pterms=pTerms,data=mf,knots=knots)

  G$var.summary <- var.summary

  n.sr <- length(G$random) # number of random smooths (i.e. s(...,fx=FALSE,...) terms)

  if (is.null(random)&&n.sr==0)
  stop("gamm4 models must have at least 1 smooth with unknown smoothing parameter or at least one other random effect")

  offset.name <- attr(mf,"names")[attr(attr(mf,"terms"),"offset")]

  yname <- new.name("y",names(mf))
  eval(parse(text=paste("mf$",yname,"<-G$y",sep="")))
  Xname <- new.name("X",names(mf))
  eval(parse(text=paste("mf$",Xname,"<-G$X",sep="")))

  lme4.formula <- paste(yname,"~",Xname,"-1")
  if (length(offset.name))
  { lme4.formula <- paste(lme4.formula,"+",offset.name)
  }

  ## Basic trick is to call (g)lFormula to set up model, with simple i.i.d. dummy random effects for the
  ## penalized component of each smooth. This results in columns of Z being produced for these dummy's,
  ## which can be over-written with the right thing. NOTE: that lambdat could also be modified, I think!!

  ## Add the random effect dummy variables for the smooth
  r.name <- names(G$random)
  if (n.sr) for (i in 1:n.sr) # adding the constructed variables to the model frame avoiding name duplication
  { mf[[r.name[i]]] <- factor(rep(1:ncol(G$random[[i]]),length=nrow(G$random[[i]])))
    lme4.formula <- paste(lme4.formula,"+ (1|",r.name[i],")")
  }

  if (!is.null(random)) { ## append the regular random effects
    lme4.formula <- paste(lme4.formula,"+",
                    substring(paste(deparse(random,backtick=TRUE),collapse=""),first=2))
  }

  lme4.formula <- as.formula(lme4.formula)

  if (is.null(control)) control <- if (linear) lmerControl() else glmerControl()

  ## NOTE: further arguments should be passed here...
  b <- if (linear) lFormula(lme4.formula,data=mf,weights=G$w,REML=REML,control=control,...) else
                   glFormula(lme4.formula,data=mf,family=family,weights=G$w,control=control,...)

  if (n.sr) { ## Fabian Scheipl's trick of overwriting dummy slots revised for new structure
     tn <- names(b$reTrms$cnms) ## names associated with columns of Z (same order as Gp)
     ind <- 1:length(tn)
     sn <- names(G$random) ## names of smooth random components
     for (i in 1:n.sr) { ## loop through random effect smooths
       k <- ind[sn[i]==tn] ## which term should contain G$random[[i]]
       ii <- (b$reTrms$Gp[k]+1):b$reTrms$Gp[k+1]
       b$reTrms$Zt[ii,] <- as(t(G$random[[i]]),"dgCMatrix")
       b$reTrms$cnms[[k]] <- attr(G$random[[i]],"s.label")
     }
  }

  ## now do the actual fitting...
  ret <- list()
  #arg <- list(...)
  #arg <- arg[!(names(arg) %in% names(b))]
  #b <- c(b,arg) ## add '...' arguments for use with do.call
  b$control <- control; b$verbose=verbose; b$start=start
  if (linear) {
    ## Create the deviance function to be optimized:
    devfun <- do.call(mkLmerDevfun, b)
    ## Optimize the deviance function:
    opt <- optimizeLmer(devfun,start=start,verbose=verbose,control=control$optCtrl) ## previously bobyqa optimizer set, but now default
    ## Package up the results:
    ret$mer <- mkMerMod(environment(devfun), opt, b$reTrms, fr = b$fr)
  } else { ## generalized case...
    ## Create the deviance function for optimizing over theta:
    devfun <- do.call(mkGlmerDevfun, b)
    ## Optimize over theta using a rough approximation (i.e. nAGQ = 0):
    opt <- optimizeGlmer(devfun,start=start,verbose=verbose,control=control$optCtrl)
    ## Update the deviance function for optimizing over theta and beta:
    devfun <- updateGlmerDevfun(devfun, b$reTrms)
    ## Optimize over theta and beta:
    opt <- optimizeGlmer(devfun, stage=2,start=start,verbose=verbose,control=control$optCtrl)
    ## Package up the results:
    ret$mer <- mkMerMod(environment(devfun), opt, b$reTrms, fr = b$fr)
  }

  rm(b)

  ### .... fitting finished

  ## now fake a gam object

  object<-list(model=mf,formula=formula,smooth=G$smooth,nsdf=G$nsdf,family=family,
                 df.null=nrow(G$X),y=getME(ret$mer,"y"),
                 terms=gam.terms,pterms=G$pterms,xlevels=G$xlevels,
                 contrasts=G$contrasts,assign=G$assign,na.action=attr(mf,"na.action"),
                 cmX=G$cmX,var.summary=G$var.summary)
  pvars <- all.vars(delete.response(object$terms))
  object$pred.formula <- if (length(pvars)>0) reformulate(pvars) else NULL

  ## to unpack coefficients look at names(ret$lme$flist), ret$lme@Zt, ranef(), fixef()

    ## let the GAM coefficients in the original parameterization be beta,
    ## and let them be beta' in the fitting parameterization.
    ## Then beta = B beta'. B and B^{-1} can be efficiently accumulated
    ## and are useful for stable computation of the covariance matrix
    ## etc...

    B <- Matrix(0,ncol(G$Xf),ncol(G$Xf))
    diag(B) <- 1
    Xfp <- G$Xf
    ## Transform  parameters back to the original space....
    bf <- as.numeric(lme4::fixef(ret$mer)) ## the fixed effects
    br <- lme4::ranef(ret$mer) ## a named list
    if (G$nsdf) p <- bf[1:G$nsdf] else p <- array(0,0) ## fixed parametric componet
    if (G$m>0) for (i in 1:G$m) {
      fx <- G$smooth[[i]]$fixed
      first <- G$smooth[[i]]$first.f.para; last <- G$smooth[[i]]$last.f.para
      if (first <=last) beta <- bf[first:last] else beta <- array(0,0)
      if (fx) b <- beta else { ## not fixed so need to undo transform of random effects etc.
        b <- rep(0,0)
        for (k in 1:length(G$smooth[[i]]$lmer.name)) ## collect all coefs associated with this smooth
          b <- c(b,as.numeric(br[[G$smooth[[i]]$lmer.name[k]]][[1]]))
        b <- b[G$smooth[[i]]$rind] ## make sure coefs are in order expected by smooth
        b <- c(b,beta)
        b <- G$smooth[[i]]$trans.D*b
        if (!is.null(G$smooth[[i]]$trans.U)) b <- G$smooth[[i]]$trans.U%*%b ## transform back to original
      }
      p <- c(p,b)

      ## now fill in B...
      ind <- G$smooth[[i]]$first.para:G$smooth[[i]]$last.para
      if (!fx) {
         D <- G$smooth[[i]]$trans.D
         if (is.null(G$smooth[[i]]$trans.U)) B[ind,ind] <- Diagonal(length(D),D) else
         B[ind,ind] <- t(D*t(G$smooth[[i]]$trans.U))
      }
      ## and finally transform G$Xf into fitting parameterization...
      Xfp[,ind] <- G$Xf[,ind,drop=FALSE]%*%B[ind,ind,drop=FALSE]

    }

    object$coefficients <- p

    ## need to drop smooths from Zt and then
    ## form Z'phiZ + I \sigma^2

    vr <- lme4::VarCorr(ret$mer) ## list of ranef variance components in the same order as Gp

    scale <- as.numeric(attr(vr,"sc"))^2 ## get the scale parameter
    if (!is.finite(scale) || scale==1) { ## NOTE: better test???
      scale <- 1
      object$scale.estimated <- FALSE
    } else object$scale.estimated <- TRUE

    sp <- rep(-1,n.sr)

    Zt <- Matrix(0,0,ncol(getME(ret$mer,"Zt")))
    if (n.sr==0) sn <- NULL ## names by which smooths are known in mer
    rn <- names(vr)
    ind <- rep(0,0) ## index the non-smooth random effects among the random effects
    for (i in 1:length(vr)) {
      if (is.null(sn)||!rn[i]%in%sn) { ## append non smooth r.e.s to Zt
        Gp <- getME(ret$mer,"Gp") ## group index ends
        ind <- c(ind,(Gp[i]+1):Gp[i+1])
      } else if (!is.null(sn)) { ## extract smoothing parameters for smooth r.e.s
        k <- (1:n.sr)[rn[i]==sn] ## where in original smooth ordering is current smoothing param
        if (as.numeric(vr[[i]]>0)) sp[k] <- scale/as.numeric(vr[[i]]) else
        sp[k] <- 1e10
      }
    }

    if (length(ind)) { ## extract columns corresponding to non-smooth r.e.s
      Zt <- getME(ret$mer,"Zt")[ind,] ## extracting random effects model matrix
      root.phi <- getME(ret$mer,"Lambdat")[ind,ind] ## and corresponding sqrt of cov matrix (phi)
    }

    object$prior.weights <- G$w

    if (linear) {
      object$weights <- object$prior.weights
      V <- Diagonal(n=length(object$weights),x=scale/object$weights)
    } else {
     # mu <- getME(ret$mer,"mu")
     # eta <- family$linkfun(mu)
      object$weights <- ret$mer@resp$sqrtWrkWt()^2
      ## object$prior.weights*family$mu.eta(eta)^2/family$variance(mu)
      V <- Diagonal(x=1/object$weights)*scale
      #V <- Diagonal(x=scale*family$variance(mu)/object$prior.weights)
    }

    if (nrow(Zt)>0) V <- V + crossprod(root.phi%*%Zt)*scale ## data or pseudodata cov matrix, treating smooths as fixed now

    ## NOTE: Cholesky probably better in the following - then pivoting
    ##       automatic when solving....

    R <- Matrix::chol(V,pivot=TRUE);piv <- attr(R,"pivot")

    G$Xf <- as(G$Xf,"dgCMatrix")
    Xfp <- as(Xfp,"dgCMatrix")

    if (is.null(piv)) {
      WX <- as(solve(t(R),Xfp),"matrix")    ## V^{-.5}Xp -- fit parameterization
      XVX <- as(solve(t(R),G$Xf),"matrix")  ## same in original parameterization
    } else {
      WX <- as(solve(t(R),Xfp[piv,]),"matrix")    ## V^{-.5}Xp -- fit parameterization
      XVX <- as(solve(t(R),G$Xf[piv,]),"matrix")  ## same in original parameterization
    }
    qrz <- qr(XVX,LAPACK=TRUE)
    object$R <- qr.R(qrz);object$R[,qrz$pivot] <- object$R

    XVX <- crossprod(object$R) ## X'V^{-1}X original parameterization

    object$sp <- sp

    colx <- ncol(G$Xf)
    Sp <- matrix(0,colx,colx) # penalty matrix - fit param
    first <- G$nsdf+1
    k <- 1
    if (G$m>0) for (i in 1:G$m) { # Accumulate the total penalty matrix
      if (!object$smooth[[i]]$fixed) {
        ii <- object$smooth[[i]]$first.para:object$smooth[[i]]$last.para ## index this smooth's params
        for (j in 1:length(object$smooth[[i]]$S)) { ## work through penalty list
          ind <- ii[object$smooth[[i]]$pen.ind == j] ## index of currently penalized
          diag(Sp)[ind] <-  sqrt(object$sp[k]) ## diagonal penalty
          k <- k+1
        }														              }
      first <- last + 1
    }

    ## Alternative cov matrix calculation. Basic
    ## idea is that cov matrix is computed stably in
    ## fitting parameterization, and then transformed to
    ## original parameterization.
    qrx <- qr(rbind(WX,Sp/sqrt(scale)),LAPACK=TRUE)
    Ri <- backsolve(qr.R(qrx),diag(ncol(WX)))
    ind <- qrx$pivot;ind[ind] <- 1:length(ind)## qrx$pivot
    Ri <- Ri[ind,] ## unpivoted square root of cov matrix in fitting parameterization Ri Ri' = cov
    Vb <- B%*%Ri; Vb <- Vb%*%t(Vb)

    object$edf<-rowSums(Vb*t(XVX))

    object$df.residual <- length(object$y) - sum(object$edf)

    object$sig2 <- scale
    if (linear) { object$method <- "lmer.REML"
    } else { object$method <- "glmer.ML"}

    object$Vp <- as(Vb,"matrix")

    object$Ve <- as(Vb%*%XVX%*%Vb,"matrix")

    class(object) <- "gam"

    ## Restore original smooth list, if it was split to deal with t2 terms...
    if (!is.null(G$original.smooth)) {
      object$smooth <- G$smooth <- G$original.smooth
    }

    ## If prediction parameterization differs from fit parameterization, transform now...
    ## (important for t2 smooths, where fit constraint is not good for component wise
    ##  prediction s.e.s)

    if (!is.null(G$P)) {
      object$coefficients <- G$P %*% object$coefficients
      object$Vp <- G$P %*% object$Vp %*% t(G$P)
      object$Ve <- G$P %*% object$Ve %*% t(G$P)
    }

    object$linear.predictors <- predict.gam(object,type="link")
    object$fitted.values <- object$family$linkinv(object$linear.predictors)

    object$residuals <- residuals(ret$mer)

    if (G$nsdf>0) term.names<-colnames(G$X)[1:G$nsdf] else term.names<-array("",0)
    n.smooth<-length(G$smooth)
    if (n.smooth)
    for (i in 1:n.smooth)
    { k<-1
      for (j in object$smooth[[i]]$first.para:object$smooth[[i]]$last.para)
      { term.names[j]<-paste(object$smooth[[i]]$label,".",as.character(k),sep="")
        k<-k+1
      }
    }
    names(object$coefficients) <- term.names  # note - won't work on matrices!!
    names(object$edf) <- term.names
    names(object$sp) <- names(G$sp)

    object$gcv.ubre <- if (isREML(ret$mer)) REMLcrit(ret$mer) else deviance(ret$mer)

    if (!is.null(G$Xcentre)) object$Xcentre <- G$Xcentre ## any column centering applied to smooths

    ret$gam<-object
    class(ret) <- c("gamm4","list")
    ret

} ## end of gamm4

print.gamm4.version <- function()
{ library(help=gamm4)$info[[1]] -> version
  version <- version[pmatch("Version",version)]
  um <- strsplit(version," ")[[1]]
  version <- um[nchar(um)>0][2]
  hello <- paste("This is gamm4 ",version,"\n",sep="")
  packageStartupMessage(hello)
}

.onAttach <- function(...) {
  print.gamm4.version()

}

.onUnload <- function(libpath) {}


model_updatecalendar <- function (cumulTT = 741.510096671757,
         calendarMoments = c('Sowing'),
         calendarDates = c('2007/3/21'),
         calendarCumuls = c(0.0),
         currentdate = '2007/3/27',
         phase = 1.0){
    #'- Name: UpdateCalendar -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Calendar Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modeling development phase in the
    #'                Wheat Simulation Model SiriusQuality.
    #'                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    #'            * Institution: INRA Montpellier
    #'            * Abstract: Lists containing for each stage the date it occurs as well as a copy of all types of cumulated thermal times
    #'- inputs:
    #'            * name: cumulTT
    #'                          ** description : cumul thermal times at current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : -200
    #'                          ** max : 10000
    #'                          ** default : 741.510096671757
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: calendarMoments
    #'                          ** description : List containing apparition of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** default : ['Sowing']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarDates
    #'                          ** description : List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** default : ['2007/3/21']
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: calendarCumuls
    #'                          ** description : list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** default : [0.0]
    #'                          ** unit : °C d
    #'                          ** inputtype : variable
    #'            * name: currentdate
    #'                          ** description : current date
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DATE
    #'                          ** default : 2007/3/27
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'            * name: phase
    #'                          ** description :  the name of the phase
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 7
    #'                          ** default : 1
    #'                          ** unit :
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: calendarMoments
    #'                          ** description :  List containing apparition of each stage
    #'                          ** variablecategory : state
    #'                          ** datatype : STRINGLIST
    #'                          ** unit :
    #'            * name: calendarDates
    #'                          ** description :  List containing  the dates of the wheat developmental phases
    #'                          ** variablecategory : state
    #'                          ** datatype : DATELIST
    #'                          ** unit :
    #'            * name: calendarCumuls
    #'                          ** description :  list containing for each stage occured its cumulated thermal times
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLELIST
    #'                          ** unit : °C d
    if (phase >= 1.0 && phase < 2.0 && !('Emergence' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Emergence')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 2.0 && phase < 3.0 && !('FloralInitiation' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'FloralInitiation')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 3.0 && phase < 4.0 && !('Heading' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Heading')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase == 4.0 && !('Anthesis' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Anthesis')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase == 4.5 && !('EndCellDivision' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'EndCellDivision')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 5.0 && phase < 6.0 && !('EndGrainFilling' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'EndGrainFilling')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    else if ( phase >= 6.0 && phase < 7.0 && !('Maturity' %in% calendarMoments))
    {
        calendarMoments <- c(calendarMoments, 'Maturity')
        calendarCumuls <- c(calendarCumuls, cumulTT)
        calendarDates <- c(calendarDates, currentdate)
    }
    return (list ("calendarMoments" = calendarMoments,"calendarDates" = calendarDates,"calendarCumuls" = calendarCumuls))
}