#' Function to detect year transitions and calculate cumulative age of model results
#'
#' Takes the result of iterative growth modeling and
#' transforms data from Julian Day (0 - 365) to cumulative
#' day of the shell age by detecting where transitions
#' from one year to the next occur and adding full years
#' (365 days) to simulations in later years.
#' @param resultarray Array containing the full results of
#' the optimized growth model
#' @param plotyearmarkers Should the location of identified year
#' transitions be plotted? \code{TRUE/FALSE}
#' @param export_peakid Should the result of peak identification
#' be plotted? \code{TRUE/FALSE}
#' @param path Export path (defaults to tempdir())
#' @return A new version of the Julian Day tab of the resultarray
#' with Julian Day model estimates replaced by estimates of
#' cumulative age of the record in days.
#' @references package dependencies: zoo 1.8.7; scales 1.1.0; graphics
#' function dependencies: peakid
#' @importFrom graphics plot
#' @importFrom stats median
#' @examples
#' testarray <- array(NA, dim = c(40, 36, 9)) # Create empty array
#' # with correct third dimension
#' windowfill <- seq(50, 500, 50) %% 365 # Create dummy simulation data
#' # (ages) to copy through the array
#' for(i in 6:length(testarray[1, , 1])){
#'     testarray[, i, 3] <- c(windowfill, rep(NA, length(testarray[, 1, 3]) -
#'         length(windowfill)))
#'     windowfill <- c(NA, (windowfill + 51) %% 365)
#' }
#' # Add dummy /code{D} column.
#' testarray[, 1, 3] <- seq(1, length(testarray[, 1, 3]), 1)
#' # Add dummy YEARMARKER column
#' testarray[, 3, 3] <- c(0, rep(c(0, 0, 0, 0, 0, 0, 1), 5), 0, 0, 0, 0)
#' # Add dummy d18Oc column
#' testarray[, 2, 3] <- sin((2 * pi * (testarray[, 1, 3] - 8 + 7 / 4)) / 7)
#' testarray2 <- suppressWarnings(cumulative_day(testarray, FALSE, FALSE, tempdir()))
#' # Apply function on array
#' @export
cumulative_day <- function(resultarray, # Align Day of year results from modeling in different windows to a common time axis
    plotyearmarkers = TRUE, # Plot peak fitting?
    export_peakid = TRUE, # Export data on how the boundaries between years were found?
    path = tempdir()
    ){

    dat <- resultarray[, 1:5, 3] # isolate original data

    # Recognition of the boundaries between years.
    # Method one: Apply sinusoidal function to the julian day simulations
    JDdat <- resultarray[, (length(dat[1, ]) + 1):length(resultarray[1, , 1]), 3] # Isolate julian day simulations
    JDdat <- matrix(sin(2 * pi * (JDdat + 365/4) / 365), ncol = ncol(JDdat)) # Convert julian day to sinusoidal value (end and start of year = 1)
    JDends <- data.frame(Depth = dat[, 1],
        Yearmarker = dat[, 3],
        YEsin = scales::rescale(rowSums(JDdat, na.rm = TRUE), c(0, 1)) # Create depth series of positions which most likely represent a year end, rescale to a scale from 0 to 1
    )

    # Method two: Give weight to the first and final days in reconstructions
    weightvector <- c(seq(10, 1, -1), rep(0, 346), seq(1, 10, 1)) # Create vector of weights to be given to days near the start and end of the year
    JDdat <- round(resultarray[, (length(dat[1, ]) + 1):length(resultarray[1, , 1]), 3]) # Isolate julian day simulations
    JDdat <- matrix(weightvector[JDdat + 1], ncol = ncol(JDdat)) # Apply weighting to starts and ends of the year
    JDends$YEweight <- scales::rescale(rowSums(JDdat, na.rm = TRUE), c(0, 1)) # Add normalized results to depth series

    # Method three: Use instances within the window simulations where the end of year is recorded
    JDdat <- resultarray[, (length(dat[1, ]) + 1):length(resultarray[1, , 1]), 3] # Isolate julian day simulations
    JDdat <- rbind(rep(NA, length(JDdat[1, ])), diff(JDdat) < 0) # Matrix of positions in individual windows where end of year (day 365) is recorded
    YEcount <- rowSums(JDdat, na.rm = TRUE) / max(rowSums(JDdat, na.rm = TRUE), na.rm = TRUE) # Aggregate the counted ends of years in simulations
    smoothfactor <- min(diff(which(JDends[, 2] == 1))) # Define smoothing factor for year end counts based on yearmarkers (take thickness of year with least growth to be conservative)
    YEcount <- c(rep(0, floor(smoothfactor / 2)), zoo::rollmean(YEcount, smoothfactor, align = "center"), rep(0, smoothfactor - floor(smoothfactor / 2) - 1)) # Smooth record of year end counts and pad with zeroes
    JDends$YEcount <- scales::rescale(YEcount, c(0, 1)) # Add normalized results to depth series

    # Method four: Use maxima in d18Oc in original data
    yearpos <- c(1, which(JDends[, 2] == 1), length(JDends$Depth)) # Extract positions of yearmarkers and include start and end of record
    yearpos <- unique(yearpos) # Remove duplicates in yearpos due to yearmarkers on beginning and/or end of record
    YE18O <- vector() # Create vector for the position of the maximum d18O value
    for(m in 1:(length(yearpos) - 1)){ # Loop through positions of yearmarkers
        if(m %in% 2:(length(yearpos) - 2)){ # central part of the record
            maxpos <- which(dat[yearpos[m] : (yearpos[m + 1] - 1), 2] == max(dat[yearpos[m] : (yearpos[m + 1] - 1), 2])) + yearpos[m] - 1 # Find the position of the maximum value in the d18O data in that year
            if(length(maxpos) > 1){
                maxpos = round(stats::median(maxpos)) # Prevent multiple values in maxpos (gives errors further in the calculations)
            }
            days <- seq(1, yearpos[m + 1] - yearpos[m], 1) * 365 / (yearpos[m + 1] - yearpos[m]) # Define sequence of "days" values with length = number of datapoints in the year
            sinusoid <- sin(2 * pi * (days - rep((maxpos - yearpos[m]) / (yearpos[m + 1] - yearpos[m]) * 365 - 365 / 4, length(days))) / 365) # Create sinusoid with peak at peak in d18Oc
            sinusoid[which(days > ((maxpos - yearpos[m]) / (yearpos[m + 1] - yearpos[m]) + 0.5) * 365 | days < ((maxpos - yearpos[m]) / (yearpos[m + 1] - yearpos[m]) - 0.5) * 365)] <- -1 # Assign lowest value (-1) to all datapoints more than 1/2 period away from the maximum to prevent false peaks
            YE18O <- append(YE18O, sinusoid) # add sinusoid values to running vector
        }else if(m == 1){ # beginning of the record
            maxpos <- which(dat[yearpos[m + 1] : (yearpos[m + 2] - 1), 2] == max(dat[yearpos[m + 1] : (yearpos[m + 2] - 1), 2])) + yearpos[m + 1] - 1 # Find the position of the maximum value in the d18O data of the next year (the first year that is complete)
            if(length(maxpos) > 1){
                maxpos = round(stats::median(maxpos)) # Prevent multiple values in maxpos (gives errors further in the calculations)
            }
            days <- seq(yearpos[m] - yearpos[m + 1] + 1, yearpos[m + 2] - yearpos[m + 1], 1) * 365 / (yearpos[m + 2] - yearpos[m + 1]) # Define sequence of "days" values
            sinusoid <- sin(2 * pi * (days - rep((maxpos - yearpos[m + 1]) / (yearpos[m + 2] - yearpos[m + 1]) * 365 - 365 / 4, length(days))) / 365) # Create sinusoid with peak at peak in d18Oc
            sinusoid[which(days > ((maxpos - yearpos[m + 1]) / (yearpos[m + 2] - yearpos[m + 1]) + 0.5) * 365 | days < ((maxpos - yearpos[m + 1]) / (yearpos[m + 2] - yearpos[m + 1]) - 0.5) * 365)] <- -1 # Assign lowest value (-1) to all datapoints more than 1/2 period away from the maximum to prevent false peaks
            YE18O <- append(YE18O, sinusoid[1:(yearpos[m + 1] - yearpos[m])]) # Add sinusoid values for first bit of record to the vector
        }else if(m == (length(yearpos) - 1)){ # end of the record
            maxpos <- which(dat[yearpos[m - 1] : (yearpos[m] - 1), 2] == max(dat[yearpos[m - 1] : (yearpos[m] - 1), 2])) + yearpos[m - 1] - 1 # Find the position of the maximum value in the d18O data of the previous year (the last year that is complete)
            if(length(maxpos) > 1){
                maxpos = round(stats::median(maxpos)) # Prevent multiple values in maxpos (gives errors further in the calculations)
            }
            days <- seq(1, yearpos[m + 1] - yearpos[m - 1], 1) * 365 / (yearpos[m] - yearpos[m - 1]) # Define sequence of "days" values
            sinusoid <- sin(2 * pi * (days - rep((maxpos - yearpos[m - 1]) / (yearpos[m] - yearpos[m - 1]) * 365 - 365 / 4, length(days))) / 365) # Create sinusoid with peak at peak in d18Oc
            sinusoid[which(days > ((maxpos - yearpos[m - 1]) / (yearpos[m] - yearpos[m - 1]) + 0.5) * 365 | days < ((maxpos - yearpos[m - 1]) / (yearpos[m] - yearpos[m - 1]) - 0.5) * 365)] <- -1 # Assign lowest value (-1) to all datapoints more than 1/2 period away from the maximum to prevent false peaks
            YE18O <- append(YE18O, sinusoid[(yearpos[m] - yearpos[m - 1]):(yearpos[m + 1] - yearpos[m - 1])]) # Add sinusoid values for last bit of record to the vector
        }
    }
    JDends$YE18O <- scales::rescale(YE18O, c(0, 1)) # Add normalized results to depth series
    JDends$YEcombined <- scales::rescale(rowSums(JDends[, -c(1,2)]), c(0, 1)) # Combine all four methods of peak recognition into one vector

    # Use peak ID algorhythm to find peaks in the combined vector of year end indicators to use as basis for cumulative day counting in the model results
    wmin <- round(min(diff(which(JDends[,2] == 1))) / 4) # Define starting window for peak recognition as one forth the minimum width of a year
    wmax <- round(min(diff(which(JDends[,2] == 1))) / 2) # Define maximum window for peak recognition as half the minimum width of a year
    YM <- length(which(JDends[,2] == 1)) # Extract number of years in record
    X <- list(w = vector(), p = vector()) # List for storing results
    w <- wmin # Start at minimum window size
    repeat{
        peaks <- peakid(JDends$Depth, JDends$YEcombined, w = w, span = 0.05) # Identify peaks based on current threshold
        if(length(peaks$x) == YM){ # Check if the number of years is correct and break loop if it is
            break
        }else if(w < wmax){ # Check if maximum window is reached
            X$w <- append(X$w, w) # Store window size
            X$p <- append(X$p, length(peaks$x)) # Store peak number
            w <- w + 1 # Increment window size
        }else{
            X$w <- append(X$w, w) # Store window size
            X$p <- append(X$p, length(peaks$x)) # Store peak number
            w <- max(X$w[which(abs(X$p - YM) == min(abs(X$p - YM)))]) # If no windows give the exact number of years, take the window that comes closer (prioritize larger windows in case of a tie)
            peaks <- peakid(JDends$Depth, JDends$YEcombined, w = w, span = 0.05) # Recalculate peak positions with the final chosen window size before breaking the loop
            break
        }
    }
    JDends$peakid <- rep(0, length(JDends[,1])) # Add column for peakid results
    JDends$peakid[peaks$i] <- 1 # Mark the location of peaks found in the time series

    if(plotyearmarkers == TRUE){
        dev.new()
        graphics::plot(JDends$Depth,
            JDends$YEcombined,
            type = "l",
            main = "Peak fitting results",
            xlab = "Depth",
            ylab = "Probability of end of year") # Plot aggregate of yearmarkers
        points(peaks$x, rep(1, length(peaks$x)), col = "red") # Plot location of yearmarkers
    }

    if(export_peakid == TRUE){
        write.csv(JDends, file.path(path, "peakid.csv"))
    }

    # Apply calculation of years in the model on the simulation results
    JDdat <- resultarray[, (length(dat[1, ]) + 1):length(resultarray[1, , 1]), 3] # Isolate julian day simulations
    for(col in 1:length(JDdat[1, ])){ # Loop through all simulation windows
        window <- JDdat[, col] # Isolate simulation window
        peakx <- head(which(peaks$x %in% dat[which(!is.na(window)), 1]), 1) # Find position of the first year end in the window column
        if(length(peakx) == 0){
            if(peaks$x[1] < dat[head(which(!is.na(window)), 1), 1]){ # If no global year transitions fall within the window, check if there are global year transitions before the window and find the last year transition before the first value in the window
                peakx <- max(which(peaks$x < dat[head(which(!is.na(window)), 1), 1])) # Find number of years before start of window
                JDpeak <- window[head(which(!is.na(window)), 1)] # Find the day of year of the first simulated value
                if(JDpeak < 182.5){
                    window <- window + peakx * 365 # If first simulated value co-occurs with first half of the year, add all years before the window
                }else{
                    window <- window + (peakx - 1) * 365 # If year first simulated value co-occurs with last half of the year, simulated values are assumed to belong to the previous year
                }
            } # If all year transitions happen after the window, no year number needs to be added to the window values
        }else{
            JDpeak <- JDdat[tail(which(dat[, 1] == peaks$x[peakx] & !is.na(window)), 1), col] # Find JD simulation belonging to the first year transition
            if(JDpeak < 182.5){
                window <- window + peakx * 365 # If year transition co-occurs with first half of the simulated year, all simulated values are assumed to belong to the next year
            }else{
                window <- window + (peakx - 1) * 365 # If year transition co-occurs with last half of the simulated year, all simulated values are assumed to belong to the previous year
            }
        }
        if(length(which(diff(window) < 0)) > 0){ # Check if year transitions occur within the simulation
            for(i in which(diff(window) < 0)){
                if(length(peakx) > 0){ # Check if global year transitions occur within the window
                    if(i < which(dat[, 1] == peaks$x[peakx])){
                        window[1:i] <- window[1:i] - 365 # If the transition happens before the reference point (peakx), subtract a year's worth of days from the values before to prevent adding a year twice.
                    }else{
                        window[(i + 1):length(window)] <- window[(i + 1):length(window)] + 365 # If the transition happens on or after the reference point (peakx), add one year's worth of days to simulations after each transition
                    }
                }else{
                    window[(i + 1):length(window)] <- window[(i + 1):length(window)] + 365 # If no global transitions occur within the window, add one year's worth of days to simulations after each local transition
                }
            }
        }
        JDdat[, col] <- window # Update the julian day data with the new cumulative day simulations
    }

    # Screen for extreme outliers in JD due to very bad simulations based on first and last modeled values
    firstval <- apply(JDdat, 2, min, na.rm = TRUE) # find first values of all modeling windows
    lastval <- apply(JDdat, 2, max, na.rm = TRUE) # find last values of all modeling windows
    badwindow <- rep(FALSE, ncol(JDdat)) # Vector indicating if window simulation is bad
    for(i in 2:(ncol(JDdat) - 1)){
        if(((abs(firstval[i] - firstval[i - 1]) > 365) & (abs(firstval[i + 1] - firstval[i])) > 365) | ((abs(lastval[i] - lastval[i - 1]) > 365) & (abs(lastval[i + 1] - lastval[i])))){ # Find windows with large (> 1 year) jumps in either first or last value
            badwindow[i] <- TRUE # Label these windows as bad
        }
    }
    JDdat[, badwindow] <- rep(NA, nrow(JDdat)) # Remove values from bad windows to prevent messing up the age model

    result <- resultarray[, , 3]
    result[, 6:length(result[1, ])] <- JDdat # Add the updated cumulative julian day results to the resultarray and export
    return(result)
}


# Copyright 2014-2019 Arnaud Poret
# This work is licensed under the BSD 2-Clause License.
# To view a copy of this license, visit https://opensource.org/licenses/BSD-2-Clause

# number of edges
nedge<-8

# vector declarations
# see below for their meaning
edgelab<-vector(mode="character",length=nedge)
r<-vector(mode="numeric",length=nedge)
w<-vector(mode="numeric",length=nedge)

# edge names
# only relevant if edge states are plotted
# plotting edge states is currently not implemented
edgelab[1]<-"EGF__EGFR"
edgelab[2]<-"HRG__EGFR"
edgelab[3]<-"EGFR__Raf"
edgelab[4]<-"AKT__Raf"
edgelab[5]<-"Raf__ERK"
edgelab[6]<-"EGFR__PI3K"
edgelab[7]<-"ERK__PI3K"
edgelab[8]<-"PI3K__AKT"

# edge reactivity
# for each edge and at each iteration of the simulation: the portion of its state which is updated
# here randomly selected between 0.3 and 0.7 as example
r[1]<-runif(1,0.3,0.7)# EGF__EGFR
r[2]<-runif(1,0.3,0.7)# HRG__EGFR
r[3]<-runif(1,0.3,0.7)# EGFR__Raf
r[4]<-runif(1,0.3,0.7)# AKT__Raf
r[5]<-runif(1,0.3,0.7)# Raf__ERK
r[6]<-runif(1,0.3,0.7)# EGFR__PI3K
r[7]<-runif(1,0.3,0.7)# ERK__PI3K
r[8]<-runif(1,0.3,0.7)# PI3K__AKT

# edge weakening
# for each edge and at each iteration of the simulation: the weakening coefficient applied on the updated portion of its state
# here randomly selected between 0.7 and 1 as example
w[1]<-runif(1,0.7,1)# EGF__EGFR
w[2]<-runif(1,0.7,1)# HRG__EGFR
w[3]<-runif(1,0.7,1)# EGFR__Raf
w[4]<-runif(1,0.7,1)# AKT__Raf
w[5]<-runif(1,0.7,1)# Raf__ERK
w[6]<-runif(1,0.7,1)# EGFR__PI3K
w[7]<-runif(1,0.7,1)# ERK__PI3K
w[8]<-runif(1,0.7,1)# PI3K__AKT

# edge updating function
# for all edges and at each iteration of the simulation: the function which calculates their updated states
fedge<-function(node,k,nedge) {
    y<-vector(mode="numeric",length=nedge)
    y[1]<-node[1,k]# EGF__EGFR
    y[2]<-node[2,k]# HRG__EGFR
    y[3]<-node[3,k]# EGFR__Raf
    y[4]<-node[7,k]# AKT__Raf
    y[5]<-node[4,k]# Raf__ERK
    y[6]<-node[3,k]# EGFR__PI3K
    y[7]<-node[5,k]# ERK__PI3K
    y[8]<-node[6,k]# PI3K__AKT
    return(y)
}


onefunction <- function()
{
    lm = lr(formula=(cf == 1) ~ age + pa, data=it)
}


#library(ggplot2)
library(data.table)
library(BiocParallel)
library(limma)
library(edgeR)
library(variancePartition)
library(dplyr)
library(Matrix)

pdf(file = "figures.pdf") # The height of the plot in inches

geneExpr = fread('./kegg/score_mean_tissue.csv')
metadata = geneExpr[, 1:7]
geneExpr = as.matrix(geneExpr[, 8:ncol(geneExpr)])

metadata$is_covid = factor(metadata$covid)
metadata$subject_id = factor(metadata$subject_id)
metadata$tissue = factor(metadata$tissue)
metadata$pid = factor(metadata$pid)
metadata$celltype = factor(metadata$celltype)
metadata$Biosample = factor(with(metadata, paste(subject_id, pid, tissue)))
metadata$aggr_unit = factor(with(metadata, paste(subject_id, pid, tissue_id,  celltype))) # tissue_id
metadata$ID = factor(with(metadata, paste(subject_id, pid, tissue, celltype)))

## dream
test_per_celltype = function(CT){
  idx = which(info$celltype == CT)
  form = ~ 0 + is_covid:tissue + (1|tissue) + (1|subject_id)
  L1  = getContrast(mat[,idx], form, info[idx,],
    c("is_covid1:tissuePFC",'is_covid0:tissuePFC'))
  L2  = getContrast(mat[,idx], form, info[idx,],
    c("is_covid1:tissuemedulla",'is_covid0:tissuemedulla'))
  L3  = getContrast(mat[,idx], form, info[idx,],
    c("is_covid1:tissuechoroidplexus",'is_covid0:tissuechoroidplexus'))
  L = data.frame(PFC = L1, medulla = L2, choroidpleus = L3)
  fit = dream(mat[,idx], form, info[idx,], L = L, BPPARAM=SnowParam(24, progressbar=TRUE))
  fit
    }

info = metadata
mat = t(geneExpr)

fitList = lapply( levels(info$celltype), test_per_celltype)
names(fitList) = levels(info$celltype)

resTab = lapply( names(fitList), function(CT){
  fit = fitList[[CT]]
  tabList = lapply( colnames(coef(fit))[1:3], function(tissue){
    tab = topTable(fit, coef=tissue, number=Inf)

    data.frame( Gene      = rownames(tab),
                Tissue    = tissue,
                CellType  = CT,
                logFC     = tab$logFC,
                P.Value   = tab$P.Value,
                z.std     = tab$z.std)
  })
  do.call(rbind, tabList)
})
resTab = data.table(do.call(rbind, resTab))
write.csv(resTab, 'kegg/dream_test.csv')

dev.off()


print(sample(1:3))
print(sample(1:3, size=3, replace=FALSE))  # same as previous line
print(sample(c(2,5,3), size=4, replace=TRUE)
print(sample(1:2, size=10, prob=c(1,3), replace=TRUE))


de_edger = function(path, meta_path, out_path, bNormal,bFilter, bPaired, group){
  pacman::p_load(limma,dplyr,edgeR)

  #Read DF
  raw_count = read.csv(path, check.names = F, header = TRUE, row.names = 1)
  metadata = read.csv(meta_path, check.names = F, header = TRUE, row.names = 1)
  ##Intersect
  lSample = intersect(rownames(metadata), colnames(raw_count))

  #Filter by Sample
  raw_count = raw_count[lSample]
  metadata = metadata[lSample,]
  print(head(raw_count))

  ##Create DGEList

  if (bNormal) {
    print("Applyin TMM")
    dgList = DGEList(counts = raw_count,
                     genes = rownames(raw_count))
    dgList <- calcNormFactors(dgList, method = "TMM")
      if (bFilter){
        drop <- which(apply(edgeR::cpm(dgList), 1, max) < 1)
        dgList = dgList[-drop,]
      }

    counts = voom(dgList)

  } else{

      if (bFilter){
        drop <- which(apply(edgeR::cpm(raw_count), 1, max) < 1)
        raw_count = raw_count[-drop,]
      }

    counts = raw_count
  }

  if (bPaired){
    design <- model.matrix(as.formula(sprintf("~sample+%s", group)), data = metadata)
  } else{
    design <- model.matrix(as.formula(sprintf("~%s", group)), data = metadata)
  }

  print(counts)
  vfit <- lmFit(counts, design)
  efit <- eBayes(vfit)
  dfPval = topTable(efit, number = Inf, coef = 2)

  write.csv(dfPval, out_path)

return(dfPval)
}

arguments = function(){
  pacman::p_load(optparse)
  option_list = list(
    make_option(c("-f", "--file"), type="character", default=NULL,
                help="dataset file name", metavar="character"),

    make_option(c("-m", "--metadata"), type="character", default=NULL,
                help="Metadata file name", metavar="character"),

    make_option(c("-o", "--out"), type="character", default=NULL,
                help="Metadata file name", metavar="character"),

    make_option(c("-n", "--normalize"), type="logical", default=NULL,
                help="Normalize data. If True the script applies TMM normalziation", metavar="bool"),

    make_option(c("-t", "--filter"), type="logical", default=NULL,
                help="Filter Low Expression", metavar="character"),

    make_option(c("-p", "--paired"), type="logical", default=FALSE,
                help="Paired Samples", metavar="character"),

    make_option(c("-g", "--group"), type="character", default="event",
                help="Group Header", metavar="character")
  );

  opt_parser = OptionParser(option_list=option_list);
  opt = parse_args(opt_parser);
  return(opt)
}
arg = arguments()

de_edger(path = arg$file,meta_path = arg$metadata, out_path = arg$out, bNormal = arg$normalize,  bFilter = arg$filter, bPaired = arg$paired, group = arg$group)


# if only two species change, what would happen?

#gam20151102.r
rm(list = ls()) # This clears everything from memory.
setwd("~/Dropbox/BCI_Turnover")
load("BCI_turnover20141213.RData")

library(mgcv)
library(ggplot2)
library(gridExtra)
library(grid)
library(spikeSlabGAM)
library(dplyr)

moge2 <- D20m[[1]][, c("PIPECO","POULAR")]
moge3 <- moge2 %>% as.data.frame %>% filter(PIPECO > 0)

D100m2 <- D100m
D20m2 <- D20m

WSG100m2 <- list()
WSG20m2 <- list()

# if the two species change do not change at 100m, what would happen?
# if the two species occurs all of the 20m quadrat at the first census, what would happen?

D20m2[[1]][, c("PIPECO","POULAR")] <- D20m[[1]][, c("PIPECO","POULAR")] + 4
for (i in 1:7){
  D100m2[[i]][, c("PIPECO","POULAR")] <- D100m[[1]][, c("PIPECO","POULAR")]
  WSG100m2[[i]] <- com.mean.ab(D100m2[[i]], trait, "WSG")
  WSG20m2[[i]] <- com.mean.ab(D20m2[[i]], trait, "WSG")
}

moge <- data.frame(Time = rep(1:7, each = 50), WSG = unlist(WSG100m2))
moge2 <- data.frame(Time = rep(1:7, each = 1250), WSG = unlist(WSG20m2),
  site = rep(1:1250, 7))

par(mfrow = c(1,2))
plot(WSG ~ Time, moge)
plot(WSG ~ Time, moge2)
par(mfrow=c(1,1))

res <- gamm(WSG ~  s(Time, k=4), random = list(site=~1), data = moge2, correlation = corAR1())

#
# summary(res$gam)
#
# Family: gaussian
# Link function: identity
#
# Formula:
# WSG ~ s(Time, k = 4)
#
# Parametric coefficients:
#              Estimate Std. Error t value Pr(>|t|)
# (Intercept) 0.5983184  0.0005318    1125   <2e-16 ***
# ---
# Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# Approximate significance of smooth terms:
#           edf Ref.df    F p-value
# s(Time) 2.995  2.995 1363  <2e-16 ***
# ---
# Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# R-sq.(adj) =   0.11
#   Scale est. = 0.00013794  n = 8750
#

#ind
n_sample <- unlist(WSG.ind) %>% length

moge_ind <- data.frame(WSG = unlist(WSG.ind),
         Time = c(rep(1, length(WSG.ind[[1]])),
              rep(2, length(WSG.ind[[2]])),
              rep(3, length(WSG.ind[[3]])),
              rep(4, length(WSG.ind[[4]])),
              rep(5, length(WSG.ind[[5]])),
              rep(6, length(WSG.ind[[6]])),
              rep(7, length(WSG.ind[[7]]))
              ))

res <- gam(WSG ~  s(Time, k=4),  data = moge_ind, correlation = corAR1())

res <- gamm(WSG ~  s(Time, k=4), random = list(site=~1), data = moge2, correlation = corAR1())

summary(res)
#
# Family: gaussian
# Link function: identity
#
# Formula:
# WSG ~ s(Time, k = 4)
#
# Parametric coefficients:
#              Estimate Std. Error t value Pr(>|t|)
# (Intercept) 5.997e-01  7.737e-05    7752   <2e-16 ***
# ---
# Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# Approximate significance of smooth terms:
#           edf Ref.df     F p-value
# s(Time) 2.997      3 853.1  <2e-16 ***
# ---
# Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# R-sq.(adj) =  0.00159   Deviance explained = 0.16%
# GCV = 0.0095875  Scale est. = 0.0095875  n = 1601745

par(mfrow = c(1, 3))
plot(WSG ~ Time, moge)
plot(WSG ~ Time, moge2)
# plot(WSG ~ Time, moge_ind)
par(mfrow=c(1,1))

moge_ind <- moge_ind %>%
  mutate(sp = as.character(WSG))

moge_ind2 <- moge_ind %>% count(sp, Time) %>%
  mutate(val = as.numeric(sp))

plot(val ~ Time, moge_ind2, cex = log(n) * 0.2)


cleanup()
incl.sp<-seq(15,23)                      # species number to be included. Numbers or "all"
incl.sp<-"all"
#incl.sp<-c(3,4)

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

dirs<-  c("NS_paper_single","NS_paper_uniform","NS_paper_uniform_confined","NS_paper_size","NS_paper_size_fixed","NS_paper_size_mesh")       # directories with output to compare
labels<-c("0) Single ss","1) Uniform","2) Uniform, confined","3) log-normal","4) log-normal, fixed parameters","5) log-normal, mesh selection")  # labes for each scenario (directory with data)

#dirs<-  c("NS_paper_uniform","NS_paper_uniform_confined","NS_paper_size","NS_paper_size_fixed","NS_paper_size_mesh")       # directories with output to compare
#labels<-c("1) Uniform","2) Uniform, confined","3) log-normal","4) log-normal, fixed parameters","5) log-normal, mesh selection")  # labes for each scenario (directory with data)

dirs<-  c("NS_paper_single","NS_paper_uniform_confined")       # directories with output to compare
labels<-c("0) Single ss","2) Uniform, confined",)  # labes for each scenario (directory with data)

for (dir in dirs) {
  if ( file.access(file.path(root,dir,"sms.dat"), mode = 0)!=0)  stop(paste('Directory',dir,'does not exist'))
}

Init.function() # get SMS.contol object  including sp.names
for (dir in dirs) {
  a<-Read.SMS.std(dir=file.path(root,dir))
  a$dir<-dir
  a$label<-labels[ which(dirs==dir)]
 if (dir==dirs[1]) aa<-a else aa<-rbind(aa,a)
}

###################
# SSB  or avg_F or recruitment

bb<-subset(aa,name=='hist_SSB')
#bb<-subset(aa,name=='avg_F')
bb<-subset(aa,name=='rec_sd')

bb$Species<-sp.names[bb$species]
bb$fam<-'multi'
bb[grep('Single',bb$label),"fam"]<-'single'

round(tapply(bb$std/bb$value*100,list(bb$Species,bb$year,bb$label),sum),0)
round(tapply(bb$std/bb$value*100,list(bb$label,bb$year,bb$Species),sum),1)
round(cbind( tapply(bb$std/bb$value*100,list(bb$label,bb$Species),mean),tapply(bb$std/bb$value*100,list(bb$label),mean)),2)

round(tapply(bb$std,list(bb$label,bb$Species),mean),2)

round(tapply(bb$std/bb$value*100,list(bb$fam),mean),2)

###################
# prey Vulnerability

bb<-subset(aa,name=='vulnera')
bb$Prey<-sp.names[bb$prey]
bb$Predator<-sp.names[bb$predator]

tapply(bb$CV.round,list(bb$Predator,bb$Prey,bb$label),sum)
################################

###################
#Preadtion mortality

bb<-subset(aa,name=='M2_sd0')
bb<-subset(aa,name=='M2_sd1')
#bb<-subset(aa,name=='M2_sd2')

bb$Species<-sp.names[bb$species]
bb$fam<-'all'
bb[grep('Uniform',bb$label),"fam"]<-'uniform'
bb[grep('log',bb$label),"fam"]<-'log-normal'

round(tapply(bb$std/bb$value*100,list(bb$Species,bb$year,bb$label),sum),0)
round(tapply(bb$std/bb$value*100,list(bb$label,bb$year,bb$Species),sum),1)

round(cbind( tapply(bb$std/bb$value*100,list(bb$label,bb$Species),mean),tapply(bb$std/bb$value*100,list(bb$label),mean)),2)

round(tapply(bb$std/bb$value*100,list(bb$fam),mean),2)


#' Global Linear Least Squares to Estimate Local ATE
#'
#' @description Estimate the local ATE
#'   at the treatment assignment threshold
#'   by the global least squares method.
#'
#' @param basemod baseline formula. `outcome ~ running variable`.
#' @param covmod (list of) one-sided formula with
#'   covariates on rhs.
#'   If NULL, covariates are not controlled.
#'   If missing, find `options("discRD.xmod")`
#' @param data data.frame which you want to use.
#' @param subset subset condition.
#' @param weights weight variable.
#' @param cluster cluster variable.
#' @param submod numeric vector.
#'   Which baseline model you want to use.
#' @param onlydmod logical (default is TRUE).
#'   Whether to estimate a model without covariates.
#' @param order numeric vector of global polynomial orders.
#' @param cutoff numeric of cutoff points
#'   If missing, try to find `getOption("discRD.cutoff")`.
#' @param assign assignment rule of treatment.
#'   If "greater",
#'   treated whose running variable is greater than or equal to cutoff.
#'   If "smaller",
#'   treated whose running variable is less than or equal to cutoff.
#'   If missing, try to find `getOption("discRD.assign")`.
#' @param se character.
#'   How to calculate robust variance-covariance matrix
#'   ("HC0", "HC1", "HC2", "HCj", "HC3", and "HC4")
#'   If "standard", calculate conventional variance-covariance matrix
#' @param cholesky logical (default is TRUE).
#'   When solving normal equation, use cholesky decomposition.
#'
#' @importFrom stats pnorm
#' @export
#' @examples
#' running <- sample(1:100, size = 1000, replace = TRUE)
#' cov1 <- rnorm(1000, sd = 2); cov2 <- rnorm(1000, mean = -1)
#' y0 <- running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y1 <- 2 + 1.5 * running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y <- ifelse(running <= 50, y1, y0)
#' bin <- ifelse(y > mean(y), 1, 0)
#' w <- sample(c(1, 0.5), size = 1000, replace = TRUE)
#' raw <- data.frame(y, bin, running, cov1, cov2, w)
#'
#' set_optDiscRD(
#'   y + bin ~ running,
#'   covmod = list(~cov1, ~ cov1 + cov2),
#'   discRD.cutoff = 50,
#'   discRD.assign = "smaller"
#' )
#'
#' global <- global_lm(data = raw)
#' str(global_lm(submod = 1, data = raw))
#' str(global_lm(submod = 1, order = 3, data = raw))
#' str(global_lm(data = raw, cutoff = 30))
#' est2 <- global_lm(data = raw, se = "HC1", weights = w)
#'
global_lm <- function(basemod,
                      covmod,
                      data,
                      subset,
                      weights,
                      cluster,
                      submod,
                      onlydmod = TRUE,
                      order = c(1, 2),
                      cutoff,
                      assign,
                      se = "HC0",
                      cholesky = TRUE) {
  # check basemod and covmod if missing
  if (missing(basemod)) basemod <- getOption("discRD.basemod")
  if (!is.list(basemod)) basemod <- list(basemod)
  if (length(basemod) == 0) stop("Not find basemod")

  if (missing(covmod)) covmod <- getOption("discRD.covmod")
  if (!is.list(covmod)) covmod <- list(covmod)
  if (onlydmod) covmod <- append(list(""), covmod)

  # model list
  if (missing(submod)) submod <- seq_len(length(basemod))
  usemod <- basemod[submod]

  mod <- expand.grid(basemod = usemod, covmod = covmod, order = order)
  mod <- mod[!duplicated(mod), ]
  if (nrow(mod) == 0) stop("Cannot construct model")

  output <- list()
  output$model.outline <- mod

  # collect arguments
  dtarg <- rlang::enquos(
    subset = subset,
    weights = weights,
    cluster = cluster
  )
  dtarg <- Filter(Negate(rlang::quo_is_missing), dtarg)

  if (!missing(cutoff)) dtarg$cutoff <- cutoff
  if (!missing(assign)) dtarg$assign <- assign
  dtarg$data <- data

  estarg <- list(
    se = se,
    cholesky = cholesky
  )

  # estimation
  est <- lapply(seq_len(nrow(mod)), function(i) {
    # data cleaning
    dtarg$basemod <- mod[i, "basemod"][[1]]
    coveq <- mod[i, "covmod"][[1]]
    if (coveq != "") dtarg$covmod <- coveq
    dtarg$order <- mod[i, "order"]
    useit <- do.call("clean_rd_data", dtarg)

    # treatment and control data
    d1 <- useit$data[useit$data$d == 1, ]
    d0 <- useit$data[useit$data$d == 0, ]

    # estimation
    y <- rlang::f_lhs(mod[i, "basemod"][[1]])
    treat <- do.call("fit_wls", append(estarg, list(data = d1, y = y)))
    ctrl <- do.call("fit_wls", append(estarg, list(data = d0, y = y)))

    # local ATE
    ate <- treat$estimate[1, 1] - ctrl$estimate[1, 1]
    ate_se <- sqrt(treat$vcov$matrix[1, 1] + ctrl$vcov$matrix[1, 1])
    ate_z <- abs(ate) / ate_se
    ate_p <- 2 * pnorm(ate_z, lower.tail = FALSE)
    ate_mat <- matrix(c(ate, ate_se, ate_z, ate_p), nrow = 1)
    colnames(ate_mat) <- c("Estimate", "Std.Err.", "z", "P(>|z|)")
    rownames(ate_mat) <- c("Local ATE")

    # output
    res <- list(
      outcome = rlang::as_label(y),
      RD.info = useit$RD.info,
      treat = treat,
      control = ctrl,
      local.ate = ate_mat
    )
    class(res) <- "global_lm"
    res
  })

  # output
  output$result <- est
  class(output) <- append("list_global_lm", class(output))
  output
}


# Source: https://towardsdatascience.com/how-to-implement-deep-learning-in-r-using-keras-and-tensorflow-82d135ae4889
# Author: Anish Singh Walia - https://towardsdatascience.com/@anishsingh20

# loading keras library
library(keras)

#loading the keras inbuilt cifar10 dataset
?dataset_cifar10
#to see the help file for details of dataset

cifar<-dataset_cifar10()

#TRAINING DATA
train_x<-cifar$train$x/255

#convert a vector class to binary class matrix
#converting the target variable to once hot encoded vectors using #keras inbuilt function 'to_categorical()

train_y<-to_categorical(cifar$train$y,num_classes = 10)

#TEST DATA
test_x<-cifar$test$x/255
test_y<-to_categorical(cifar$test$y,num_classes=10)

#checking the dimensions
dim(train_x)

cat("No of training samples\t",dim(train_x)[[1]],"\tNo of test samples\t",dim(test_x)[[1]])

#a linear stack of layers
model<-keras_model_sequential()
#configuring the Model

model %>%
  #defining a 2-D convolution layer
  layer_conv_2d(filter=32,kernel_size=c(3,3),padding="same", input_shape=c(32,32,3) ) %>%
  layer_activation("relu") %>%
  #another 2-D convolution layer

  layer_conv_2d(filter=32 ,kernel_size=c(3,3))  %>%
  layer_activation("relu") %>%

  #Defining a Pooling layer which reduces the dimentions of the
  #features map and reduces the computational complexity of the model
  layer_max_pooling_2d(pool_size=c(2,2)) %>%

  #dropout layer to avoid overfitting
  layer_dropout(0.25) %>%
  layer_conv_2d(filter=32 , kernel_size=c(3,3),padding="same") %>%
  layer_activation("relu") %>%
  layer_conv_2d(filter=32,kernel_size=c(3,3) ) %>%  layer_activation("relu") %>%
  layer_max_pooling_2d(pool_size=c(2,2)) %>%
  layer_dropout(0.25) %>%

  #flatten the input
  layer_flatten() %>%
  layer_dense(512) %>%
  layer_activation("relu") %>%

  layer_dropout(0.5) %>%

  #output layer-10 classes-10 units
  layer_dense(10) %>%

  #applying softmax nonlinear activation function to the output layer
  #to calculate cross-entropy
  layer_activation("softmax")

  #for computing Probabilities of classes-"logit(log probabilities)

#Model's Optimizer
#defining the type of optimizer-ADAM-Adaptive Momentum Estimation
opt<-optimizer_adam( lr= 0.0001 , decay = 1e-6 )

#lr-learning rate , decay - learning rate decay over each update
model %>%
  compile(loss="categorical_crossentropy",
          optimizer=opt,metrics = "accuracy")

#Summary of the Model and its Architecture
summary(model)
rm(cifar)
rm(opt)

#TRAINING PROCESS OF THE MODEL
data_augmentation <- T

if(!data_augmentation) {
  model %>% fit( train_x,train_y ,batch_size=32,
                 epochs=80,validation_data = list(test_x, test_y),
                 shuffle=TRUE)
} else {
  #Generating images

  gen_images <- image_data_generator(featurewise_center = TRUE,
                                     featurewise_std_normalization = TRUE,
                                     rotation_range = 20,
                                     width_shift_range = 0.30,
                                     height_shift_range = 0.30,
                                     horizontal_flip = TRUE  )

  #Fit image data generator internal statistics to some sample data
  gen_images %>% fit_image_data_generator(train_x)
  #Generates batches of augmented/normalized data from image data and
  #labels to visually see the generated images by the Model

  model %>% fit_generator(
    flow_images_from_data(train_x, train_y,gen_images,
                          batch_size=32,save_to_dir="CNNcifarimages/"),
    steps_per_epoch=as.integer(50000/32),epochs = 80,
    validation_data = list(test_x, test_y) )
}

#use save_to_dir argument to specify the directory to save the
#images generated by the Model and to visually check the Model's
#output and ability to classify images.


#Rscript

################################
##    Median and dispersion   ##
################################

#####Packages : Cowplot
#               ggplot2

#####Load arguments

args <- commandArgs(trailingOnly = TRUE)

if (length(args) == 0) {
    stop("This tool needs at least one argument")
}else{
    table <- args[1]
    hr <- args[2]
    var <- as.numeric(args[3])
    spe <- as.numeric(args[4])
    loc <- as.numeric(args[5])
    time <- as.numeric(args[6])
}

if (hr == "false") {
  hr <- FALSE
}else{
  hr <- TRUE
}

#####Import data
data <- read.table(table, sep = "\t", dec = ".", header = hr, fill = TRUE, encoding = "UTF-8")
data <- na.omit(data)
colvar <- colnames(data)[var]
colspe <- colnames(data)[spe]
colloc <- colnames(data)[loc]
coltime <- colnames(data)[time]

data <- data[grep("^$", data[, spe], invert = TRUE), ]
time <- as.integer(substring(data[, time], first = 1, last = 4))

#####Your analysis

####Median and data dispersion####

#Median
graph_median <- function(data, var) {
  graph_median <- ggplot2::ggplot(data, ggplot2::aes_string(y = var)) +
  ggplot2::geom_boxplot(color = "darkblue") +
  ggplot2::theme(legend.position = "none") + ggplot2::ggtitle("Median")

return(graph_median)

}

#Dispersion
dispersion <- function(data, var, var2) {
  graph_dispersion <- ggplot2::ggplot(data) +
  ggplot2::geom_point(ggplot2::aes_string(x = var2, y = var, color = var2)) +
  ggplot2::scale_fill_brewer(palette = "Set3") +
  ggplot2::theme(legend.position = "none", axis.text.x = ggplot2::element_text(angle = 90, vjust = 0.5, hjust = 1), plot.title = ggplot2::element_text(color = "black", size = 12, face = "bold")) + ggplot2::ggtitle("Dispersion")

return(graph_dispersion)

}

#The 2 graph
med_disp <- function(med, disp) {
  graph <- cowplot::plot_grid(med, disp, ncol = 1, nrow = 2, vjust = -5,  scales = "free")

  ggplot2::ggsave("Med_Disp.png", graph, width = 12, height = 20, units = "cm")
}

#### Zero problem in data ####

#Put data in form
make_table_analyse <- function(data, var, spe, var2, var3) {
    tab <- reshape(data
                  , v.names = var
                  , idvar = c(var2, var3)
                  , timevar = spe
                  , direction = "wide")
    tab[is.na(tab)] <- 0 ###### remplace les na par des 0 / replace NAs by 0

    colnames(tab) <- sub(var, "", colnames(tab))### remplace le premier pattern "abond." par le second "" / replace the column names "abond." by ""
    return(tab)
}
data_num <- make_table_analyse(data, colvar, colspe, colloc, coltime)
nb_spe <- length(unique(data[, spe]))
nb_col <- ncol(data_num) - nb_spe + 1
data_num <- data_num[, nb_col:ncol(data_num)]

#Presence of zeros in the data
mat_corr <- function(data) {
  cor(data)
}
p_mat <- function(data) {
  ggcorrplot::cor_pmat(data)
} # compute a matrix of correlation p-values

graph_corr <- function(data_num) {
  graph <- ggcorrplot::ggcorrplot(mat_corr(data_num), method = "circle", p.mat = p_mat(data_num), #barring the no significant coefficient
  ggtheme = ggplot2::theme_gray, colors = c("#00AFBB", "#E7B800", "#FC4E07"))

  ggplot2::ggsave("0_pb.png", graph)
}

##Med and disp
med <- graph_median(data, var = colvar)
disp <- dispersion(data, var = colvar, var2 = colspe)
med_disp(med = med, disp = disp)

##O problem
graph_corr(data_num)


setwd('~/Downloads/')

landuse_data<-read.csv("LanduseComplete.csv")
landuse_data<-data.frame(landuse_data)

library(dplyr)
averages = group_by(landuse_data, HUC8) %>%
    summarise(PFOR2 = mean(PFOR, na.rm = TRUE),
              PWETL2= mean(PWETL, na.rm = TRUE),
              PURB2= mean(PURB, na.rm = TRUE),
              PAGT2= mean(PAGT, na.rm = TRUE)) %>% write.csv("avg_landuse.csv")

head(averages)


#' Wrapper function to conduct retrospective analysis.
#'
#' Conducts standard retrospective analysis on predicted biomass index, inlcuding reporting Mohn's rho. Also examines retrospective analysis of multiplier (inclusing years prior to terminal year).
#' @param dat data frame of Year and avg (the biomass index)
#' @param od output directory where plots are saved (default=working directory)
#' @param my.title title for time series plot with loess smooth (default = "")
#' @param terminal.year last year used in smooth (allows easy retro analysis) (default = NA = most recent)
#' @param nyears number of years to use in loess (default = 33)
#' @param loess.span proportion time series used in smoothing (default = NA, calculates span=9.9/nyears)
#' @param npeels how many years to remove in retrospective analysis
#' @param saveretroplot true/false flag to save retrospective plot to od (default=FALSE)
#' @param showplots true/false flag to display plots in window (default=TRUE)
#' @param nameplots added to start of saved files (default=""), spaces not recommended
#' @export

RunRetro <- function(dat,
                     od            = ".",
                     my.title      = "",
                     terminal.year = NA,
                     nyears        = 33,
                     loess.span    = NA,
                     npeels        = 7,
                     saveretroplot = FALSE,
                     showplots     = TRUE,
                     nameplots     = ""){

  # determine ending years
  if(is.na(terminal.year)) terminal.year <- max(dat$Year, na.rm=T)
  term.years <- seq(terminal.year, terminal.year - npeels, -1)

  # loop through peels
  res <- list()
  for (ipeel in 1:(npeels+1)){
    res[[ipeel]] <- ApplyPlanBsmooth(dat,
                                     od            = od,
                                     my.title      = my.title,
                                     terminal.year = term.years[ipeel],
                                     nyears        = nyears,
                                     loess.span    = loess.span,
                                     saveplots     = FALSE,
                                     showplots     = showplots,
                                     nameplots     = nameplots)
  }

  # get data for retro plot
  ribbon <- data.frame(Year = res[[1]]$dat.use$Year,
                       avg  = res[[1]]$dat.use$avg,
                       pred = res[[1]]$pred_fit$fit,
                       loci = res[[1]]$pred_fit$fit - 1.96 * res[[1]]$pred_fit$se.fit,
                       hici = res[[1]]$pred_fit$fit + 1.96 * res[[1]]$pred_fit$se.fit,
                       peel = 0)
  for (ipeel in 2:(npeels+1)){
    rpeel <- data.frame(Year = res[[ipeel]]$dat.use$Year,
                        avg  = res[[ipeel]]$dat.use$avg,
                        pred = res[[ipeel]]$pred_fit$fit,
                        loci = res[[ipeel]]$pred_fit$fit - 1.96 * res[[ipeel]]$pred_fit$se.fit,
                        hici = res[[ipeel]]$pred_fit$fit + 1.96 * res[[ipeel]]$pred_fit$se.fit,
                        peel = ipeel - 1)
    ribbon <- rbind(ribbon, rpeel)
  }

  ribbon <- mutate(ribbon, loci0 = ifelse(loci < 0, 0, loci)) # to allow ggplot to show CI when low < 0

  # compute Mohn's rho for predicted biomass index
  rho.vals.B <- rep(NA, npeels)
  for (ipeel in 1:npeels){
    jval <- ipeel + 1
    myyear <- term.years[jval]
    check.val <- filter(ribbon, Year == myyear, peel == ipeel)$pred
    term.val <- filter(ribbon, Year == myyear, peel == 0)$pred
    if (length(check.val) == 1 & length(term.val) == 1){
      rho.vals.B[ipeel] <- (check.val - term.val) / term.val
    }
  }
  rho.B <- mean(rho.vals.B, na.rm=TRUE)

  # make retro plot for predicted biomass index
  year.range <- filter(ribbon, peel == 0)$Year

  ribbon <- filter(ribbon, Year >= min(year.range), Year <= max(year.range))

  retro_plot_biomass <- ggplot(ribbon, aes(x=Year, y=avg)) +
    geom_point() +
    geom_ribbon(data=filter(ribbon, peel == 0),
                aes(x=Year, ymin=loci0, ymax=hici), fill="grey50", alpha=0.3) +
    geom_line(data=ribbon, aes(x=Year, y=pred, color=as.factor(peel)), size=1.3) +
    scale_y_continuous(expand = c(0,0), limits = c(0, NA)) +
    ylab("Biomass Index") +
    labs(title = my.title, subtitle = paste0("Mohn's rho = ",round(rho.B,3))) +
    labs(color="Peel") +
    theme_bw()

  if(showplots) print(retro_plot_biomass)
  if(saveretroplot) ggsave(file.path(od, paste0(nameplots, "retro_plot_biomass.png")), retro_plot_biomass)

  # compute retro analysis of multiplier estimates
  mult.ribbon <- data.frame(Year = integer(),
                            peel = integer(),
                            mult = double())
  start.year <- max(year.range) - npeels - 3
  for (j in start.year:max(year.range)){
    mreg.dat <- filter(ribbon, Year >= (j - 2), Year <= j, peel == 0)
    if(dim(mreg.dat)[1] >= 2){
      llr_fit <- lm(log(pred) ~ Year, data=mreg.dat)
      mult <- exp(llr_fit$coefficients[2])
      mult.ribbon.step <- data.frame(Year = j,
                                     peel = 0,
                                     mult = mult)
      mult.ribbon <- rbind(mult.ribbon, mult.ribbon.step)
    }
  }
  for (ipeel in 1:npeels){
    for (j in start.year:term.years[(ipeel+1)]){
      mreg.dat <- filter(ribbon, Year >= (j - 2), Year <= j, peel == ipeel)
      if(dim(mreg.dat)[1] >= 2){
        llr_fit <- lm(log(pred) ~ Year, data=mreg.dat)
        mult <- exp(llr_fit$coefficients[2])
        mult.ribbon.step <- data.frame(Year = j,
                                       peel = ipeel,
                                       mult = mult)
        mult.ribbon <- rbind(mult.ribbon, mult.ribbon.step)
      }
    }
  }

  # make retro plot for multiplier
  retro_plot_multiplier <- ggplot(mult.ribbon, aes(x=Year, y=mult, color=as.factor(peel))) +
    geom_line() +
    geom_point() +
    scale_x_continuous(labels=seq(start.year,max(year.range)),breaks=seq(start.year,max(year.range))) +
    ylab("Multiplier") +
    labs(title = my.title) +
    labs(color="Peel") +
    theme_bw()

  if(showplots) print(retro_plot_multiplier)
  if(saveretroplot) ggsave(file.path(od, paste0(nameplots, "retro_plot_multiplier.png")), retro_plot_multiplier)

  # define list of returned variables and plots
  retres <- list(ribbon                = ribbon,
                 rho.vals.B            = rho.vals.B,
                 rho.B                 = rho.B,
                 mult.ribbon           = mult.ribbon,
                 retro_plot_biomass    = retro_plot_biomass,
                 retro_plot_multiplier = retro_plot_multiplier)

  return(retres)
}


#Import required packages
require('foreach')
require('tidyverse')
require('condSURV')
require('lmtest')
require('cowplot')
require('ggtext')
require('emdbook')
require('doParallel')

##############################################
############# Produce Figure 2 ###############
##############################################

#There are three major components that go into producing Figure 2:

#(A) A survival analysis of the data in Rocheleau 2018, Clin Microbiol Infect
# https://pubmed.ncbi.nlm.nih.gov/28652115/

## (A.1) First, we use the condSURV package to fit conditional survival estimates
## (i.e., the probably of no resistance in a given year).
## Note - this data is not *publicly available*. The running of this script must be
## coordinated with the BC Centre for HIV Excellence
## However, the output of this script is given in $filename, so you can still plot
## Fig 2 in its entirety.

source('conditional_survival_analysis_BCdata.r')

##(A. 2) Second, we fit exponential models to the data
source('fit_exponential_decay.r')

#(B) A breakdown of the number of mutations present in
#     initially drug naive, triple-drug treated, virologically-rebounding individuals
#(C) and the mutation present among individuals with one DRM

##For both of these analyses (B and C), we initially run a (slow) script to process
##  the raw data and call mutations
##Once these have been run once, they should print intermediate data formats that
##  don't require these to be re-run

source('initial_processing.r')
source('call_mutations.r')

##Then we determine the first mutation (and the total number of mutations)
## - this creates intermediate data structures that will be plot in Figure 2B and C

source('determine_first_mutation.r')

##We also perform statistical tests to test the significance of the NNRTI first
## (on NNRTI-based therapies) and 3TC first (on PI-based therapies) hypotheses
## To do this, we first need to calculate mutation rates:

source('CalculatingTargetSize_MutRate.R')
source('test_first_mutation.r')

##Figure 2: Once all of these pieces are in place, we plot everything

source('plot_figure_2.r')

##############################################
############# Produce Figure 5 ###############
##############################################

#This second section has the spatially- and temporally- varying models of Figure 5

#This code was originally run in parallel on a cluster

#These have drug specific parameter values that are called in both the spatial and temporal
#models
source('shared_functions.r')

#Temporal heterogeneity model
source('time_runner.r')

#Spatial heterogeneity model
source('space_runner.r')

#Now, we can plot these pieces together into Figure 5
source('plot_figure_5.r')


library(shiny)
library(shinydashboard)
library(shinyBS)
library(e1071)
library(randomForest)
library(caret)

header <- dashboardHeader(title="MlR")

dynamic_ui <- fluidRow(
        box(background = "blue",width=5,selectInput("class_algo",'Algorithm List',choices=c("Support Vector Machine"="c_svm","Random Forest"="c_rf","K Nearest Neighbor"="c_knn")),numericInput("cv","Cross Validation",value=1,step=1),sliderInput("split","Train Size",min=0.0,max=1.0,value=0.8)),
        column(width=5,uiOutput("ui_class"))
    )

body <- dashboardBody(
    mainPanel(
        tabsetPanel(
            tabPanel("Classification",dynamic_ui,id="class"),
            tabPanel("Model Results",h2(textOutput("cross_or_split")),dataTableOutput("model_results"))
        )
    )
)

sidebar <- dashboardSidebar(
fileInput("file","Upload CSV",accept=c("text/csv",".csv")),
div(style="display:inline-block;width:54%;text-align: center;",actionButton("data", label = "View Data", icon = icon("table")))
)

ui <- dashboardPage(header,sidebar,body)

server <- function(input,output){
e <- new.env()
#output$table <- renderDataTable(iris, list(lengthMenu = c(5, 30, 50), pageLength = 5))

output$ui_class<-renderUI({
switch(input$class_algo,
     "c_svm" = box(width=15,background = "blue",title="Algorithm Parameters",numericInput("cost","Cost",value=1,step=0.5),
                    selectizeInput("kernel","Kernel",choices=c("radial","linear","polynomial","sigmoid")),
                    numericInput("degree","Degree",value=3,step=0.5),
                    numericInput("coef0","Coef",value=0,step=0.5)
                   ),
    "c_rf"  = box(width=15,background = "blue",title="Algorithm Parameters",numericInput("ntree","No of trees",value=500,step=1)),
    "c_knn" = box(width=15,background = "blue",title="Algorithm Parameters",numericInput("k", "K",value = 3,step=2))
)
})

observeEvent(input$file,{
   assign("data",read.csv(input$file$datapath), envir = e)
})

output$model_results<-renderDataTable({
if(is.null(input$file)) { return(NULL) }
df = get("data", envir = e)
y = as.factor(df[,ncol(df)])  #assuming last column as target variable
x = as.matrix(df[,1:ncol(df)-1])
if(identical(input$class_algo,"c_svm")){
    model = svm(x,y,cross=input$cv)
    Summary = summary(model)
    accuracies = Summary$accuracies
    fold = 1:length(accuracies)
    tab = cbind(fold,accuracies)
    print(tab)
    as.data.frame(tab)   #showing results
}
})

output$cross_or_split<-renderText({
if(is.null(input$file)) { return(NULL) }
if(input$cv>1){"Cross Validation Results"}
else{"Test Set Results"}
})

observeEvent(input$data,{
showModal(
    modalDialog(
        #renderDataTable(read.csv(input$file$datapath), list(lengthMenu = c(5, 30, 50), pageLength = 5)),
        if(is.null(input$file))
        { "Please Upload File" }
        else
        {renderDataTable(get("data", envir = e), list(lengthMenu = c(5, 30, 50), pageLength = 5))},
        size="l",
        title = "Dataset")
    )
})

}

shinyApp(ui,server)


set.seed(123441)
source("~/quasr/suff_stats_quasr.r")
source("~/quasr/admm.r")

library(parallel)
library(huge)

nlist= floor(exp(seq(from=log(40),to=log(5000),length.out=5)))
#nlist=100000
d=5
m1=2
m2=4
source("~/trw/startup.r")
setwd("~/quasr")
rep=5
#h=huge.generaor(n=n,d=d,graph="random",prob=.9)
h=huge.generator(n=2*rep*max(nlist),d=d,graph="scale-free")
h$data<-scale(h$data,center=T,scale=T)/8+0.5
#h$data<- pbeta(h$data,2,1)
#h$data<-h$data-colMeans(h$data)
#h$data<-qexp(pnorm(h$data),rate=12)
h$data<- sign(h$data-.5)*(abs(h$data-.5))^.6
h$data<-scale(h$data,center=T,scale=T)/4+0.5

h$data[h$data>=1] = .95
h$data[h$data<=0] = .05

rpt=rpq=matrix(0,rep,length(nlist))
out=list()

simout=lapply(1:rep,function(r){
print(paste("rep number ",r))
ncount=1
kk=0
for(n in nlist){
kk=kk+1
dat=h$data[((r-1)*max(nlist)+1):(r*max(nlist)),]
test=h$data[(rep*max(nlist)+(r-1)*max(nlist)+1):(rep*max(nlist)+r*max(nlist)),]
ncount=ncount+n

#dat=matrix(runif(d*n),n,d)

lammax=max(abs(unlist(Kvec2(dat,m1,m2))))
lamseq=exp(seq(from=log(.01),to=log(lammax),length.out=25))

#admm=admmSel(dat,lam=lamseq,m1=m1,m2=m2,rho=1,n=n)
# Rprof(line.profiling=T)
# admm=admmSel(dat,lam=lamseq,m1=m1,m2=m2,rho=1,n=n)
# Rprof(NULL)
# summaryRprof(lines="show")

# ind=apply(admm[[14]]$ze,3,function(x)any(x!=0))
# g=graph.full(d)
# quasr=subgraph.edges(g,E(g)[ind])[]
# spar= sum(h$theta!=0)/2
#
# roc=array(0,dim=c(2,25,10))
# for(i in 1:10){
# admm=admmSel(dat[((i-1)*n+1):(i*n),],lam=lamseq,m1=m1,m2=m2,rho=1,n=n)
# 	roc[1,,i]<- unlist(lapply(1:25,function(i){
# 	indq=apply(admm[[i]]$ze,3,function(x)any(x!=0))
# 	quasr=subgraph.edges(g,E(g)[indq],delete.vertices=F)[]
# 	ind= row(quasr)<=(col(quasr)-1)
# 	1-sum( (h$theta[ind]!=0) & (quasr[ind]==0) )/spar
# 	}))
# 	roc[2,,i]<- unlist(lapply(1:25,function(i){
# 	indq=apply(admm[[i]]$ze,3,function(x)any(x!=0))
# 	quasr=subgraph.edges(g,E(g)[indq],delete.vertices=F)[]
# 	ind= row(quasr)<=(col(quasr)-1)
# 	1- sum( (quasr[ind]!=0) & (h$theta[ind]==0) )/(d*(d-1)/2-spar)
# 	}))
# }
# plot(apply(roc[1,,],1,mean),apply(roc[2,,],1,mean),xlim=c(0,1),ylim=c(0,1),
# 	type="l");dev.off()
#
# unlist(lapply(admm,function(x) sum(apply(x$ze,3,function(y)any(y!=0)))))
# Rprof(NULL)
# summaryRprof(lines="show")
#
#
# indq=apply(admm[[10]]$ze,3,function(x)any(x!=0))
# 	quasr=subgraph.edges(g,E(g)[indq],delete.vertices=F)[]

g<-graph.full(d,directed=F)
edgelist<- get.edgelist(g)
g=graph.adjacency(h$theta,mode="undirected")
edgelist=get.edgelist(g)
lammax=max(abs(unlist(Kvec2(dat,m1,m2,edgelist))))
lam=lammax/2
clust<- clusters(g)$membership
edge_mean <- edge.means(dat[1:n,], edgelist, m2, cores)
node_mean <- node.means(dat[1:n,] , m1,cores)
edge_mean_test <- edge.means(test[1:n,], edgelist, m2, cores)
node_mean_test <- node.means(test[1:n,] , m1,cores)
#weights<- rep(1, dim(edgelist)[1])  #rep(1,dim(edgelist)[1])
edge_coef<- array(0,dim=c(m2,m2,dim(edgelist)[1]))
node_coef<- matrix(0,d,m2)
#lam=.1
alpha_start=1
sub=g
tree_obj<-edge.Start(sub,burn.in=10)
wt<-E(tree_obj)$weight
#wt=rep(1,d*(d-1)/2)
# trwout=parallelTrwFit(edge_coef,node_coef,edge_mean,node_mean,
#                    edgelist,wt,lambda=lam,alpha_start,
#                    sub,cores=cores)

#apply(trwout$edge_c,3,function(x) any(x!=0))
#apply(admm$ze,3,function(x)any(x!=0))

edgelist=get.edgelist(graph.adjacency(h$theta))
lamseq=exp(seq(from=log(.001),to=log(lammax),length.out=25))
admm=admmSel(dat[1:n,],lam=lamseq,m1=m1,m2=m2,rho=1,elist=edgelist)
#trwpath<-trw_path(edge_coef,node_coef,node_mean,edge_mean,
#		edgelist,g=g,out_len=5,limit=d-2)
		#weights=NULL,alpha_start=alpha_start,
		#	g,cores=cores,limit=limit,relax=F,edge.opt=T,out_len=out_len)

risk_path_quasr<-lapply(admm,function(x){
	den1=rwrapper2(x$ze, x$zn,
		edge_mean,node_mean,edgelist,
    	wt, legen.Vec, legen.array, lam, alpha_start, alg = 0L)

	-trw_lik(node_mean_test,edge_mean_test,x$zn,x$ze,den1$part_fn)
})

risk_path_trw<-lapply(lamseq,function(l){
	ptf=parallelTrwFit(edge_coef,node_coef,edge_mean,node_mean,
                   edgelist,wt,lambda=l,alpha_start,
                   sub,cores=cores)
	return(list(lik=-trw_lik(node_mean_test,edge_mean_test,ptf$vert_c,ptf$edge_c,ptf$part_fn),trw=ptf))
})

rpt[r,kk]=min(unlist(lapply(risk_path_trw,function(x)x$lik)))
rpq[r,kk]=min(unlist(risk_path_quasr))

out[[kk]]=list(quasr=admm[[which.min(unlist(risk_path_quasr))]],
	trw=risk_path_trw[[which.min(unlist(lapply(risk_path_trw,function(x)x$lik)))]]
	)

}
return(list(rpt=rpt[r,kk],rpq=rpq[r,kk]))
})

rpt=lapply(simout,function(x)x$rpt)
rpq=lapply(simout,function(x)x$rpq)

save.image("scorematchpath.rdata")

pdf("riskpath.pdf")
plot(nlist,apply(rpt,2,mean,na.rm=T),col="red",type="l",
	ylim=range(apply(rpt,2,mean,na.rm=T),apply(rpq,2,mean,na.rm=T)[-3]),log="x",
	xlab="Number of samples",
	ylab="Held-out neg log lik",lty=1)
points(nlist,apply(rpq,2,mean,na.rm=T),type="l",col="blue",lty=6)
dev.off()

#pdf("bivdenrisk.pdf",width=10,height=7)
# for(i in 1:dim(out[[1]]$trw$trw$edge_den)[3]){
# par(mfcol=c(1,2))
#
# contour(out[[1]]$trw$trw$edge_den[,,i])
# den1=rwrapper2(out[[1]]$quasr$ze, out[[1]]$quasr$zn,
#  		edge_mean,node_mean,edgelist,
#      	wt, legen.Vec, legen.array, lam, alpha_start, alg = 0L)
# contour(den1$edge_den[,,i])
# }
# dev.off()

#
# contour(out[[10]]$trw$trw$edge_den[,,10])
# den1=rwrapper2(out[[10]]$quasr$ze, out[[10]]$quasr$zn,
#  		edge_mean,node_mean,edgelist,
#      	wt, legen.Vec, legen.array, lam, alpha_start, alg = 0L)
# contour(den1$edge_den[,,10])
# dev.off()


####----This code works for replicate 1 under scenario II, lines that need to be
####----modified to run another replicate/scenario are commented accordingly
####----Recall that Bayes DAG-Sel only works when n > m, which means that this code
####----is only used in scenario 1.

#setwd("")

#####################################################################################################
#####################################################################################################
########------------------------Program to read data from QMSim-----------------------------#########
#####################################################################################################
#####################################################################################################

#--To read genotypes

#replace "Pop1_qtl_001.txt" by "Pop1_qtl_00j.txt", j=2,3,4 to run another replicate

QTL1=read.table("Pop1_qtl_001.txt",header=F)

QTL1=as.matrix(QTL1[,-1])
QTL.Matrix=function(QTL){
  template=seq(1,ncol(QTL)-1,2)
  A=matrix(0,nrow=nrow(QTL),ncol=ncol(QTL))
  for(i in 1:nrow(QTL)){
    for(j in template){
      A[i,j]=QTL[i,j]+QTL[i,j+1]-3
    }
  }
  A=A[,template]
  return(A)
}

###---Reading phenotypes and total additive effects

#replace "Pop1_data_001.txt" by "Pop1_data_00j.txt", j=2,3,4 to run another replicate

data1=read.table("Pop1_data_001.txt",header=T)

W=QTL.Matrix(QTL=QTL1)
nloci=ncol(W)

#########################################################
###-----Create training and testing population-----######
#########################################################

data1.Training=data1[-which(data1$G==4), ]
W.Train=W[-which(data1$G==4), ]
n.train=nrow(W.Train)
data1.Test=data1[which(data1$G==4),]

###############################################################
########---Functions to build the adjacency matrices----#######
###############################################################

Adj=function(Nodes,nloci){
	library(Matrix)
	Adj=as(matrix(0,nrow=nloci,ncol=nloci),"dgTMatrix")
	for(i in 1:nrow(Nodes)){
		Adj[Nodes[i,1],Nodes[i,2]]=1
                              }
	return(Adj)
			       }

###############----Read multiple files with the DAG's from CSCS_EM-------###############

temp=list.files(pattern="*.txt")
Graphs=lapply(temp, read.table)
dim(Graphs[[1]])

ad=function(k){
 for(i in 1:nloci){
  for(j in 1:nloci){
    Graphs[[k]][i,j]=as.numeric(Graphs[[k]][i,j]!=0)
   }
  }
 return(Graphs[[k]])
}

Graphs=apply(matrix(c(1:length(Graphs))),1,ad)

################################################################################
################################################################################
##########-----Function to get posterior score based on DAG-Wishart n>m-----####
################################################################################
################################################################################

WTWInv=solve(crossprod(W.Train)+diag(0.01,nloci))
Ay=tcrossprod(WTWInv,W.Train)%*%data1.Training$Phen
U2=tcrossprod(Ay)+U

####---Function to define sets of parent nodes----######

##--Parents have smaller indices

pai=function(i){
 matrix(which(L[i,1:(i-1)]!=0))
}

getnodes=function(parents){
 seed=matrix(0,ncol=2)
  for(i in 1:length(parents)){
   if(length(parents[[i]])>0){
      b=cbind(rep(i+1,nrow(parents[[i]])),parents[[i]])
      e=rbind(seed,b)
     }
   seed=e
  }
 return(e[-1,])
}

###---Get the score----#####

zs=function(i,U2,pa,parents,alpha){
alf=(alpha[i]-pa[i]-2)*0.5
  num=gamma(alf)*(2^(alf+(pa[i]*0.5)))*(sqrt(pi)^pa[i])*(det(as.matrix(U2[parents[[i-1]],parents[[i-1]]]))^(alf-0.5))
  den=(det(as.matrix(U2[c(parents[[i-1]],i),c(parents[[i-1]],i)])))^alf
 z=num/den
return(z)
}

get.score2=function(alpha,parents,pa){
 alpha=alpha+1
  z1=(gamma((alpha[1]-2)*0.5)*(2^(alpha[1]*0.5-1))*det(U2))/(U2[1,1]^((alpha[1]-2)*0.5))
    Scores=0
   for(i in 2:nloci){Scores=Scores+log(zs(i,U2,pa,parents,alpha))}
  score=log(z1)+Scores
 return(score)
}

DAG.score2=function(L){
 parents=list(NA)
  for(i in 2:nrow(L)){parents[[i-1]]=matrix(which(L[i,1:(i-1)]!=0))}
   pa=matrix(0,nrow=nloci)
    pa[1]=0
    for(i in 2:nloci){pa[i]=length(parents[[i-1]])}
   alpha=as.matrix((rep((max(pa)+3),nloci)))
  score=get.score2(alpha,parents,pa)
 score
}

###############################################################################################################
###############################################################################################################
######---------Functions to perform the SSS algorithm of Ben-David et al. (2015)----###########################
###############################################################################################################
###############################################################################################################

getNgraphs <- function(D,N){
    N1 <- list()
    dimD <- dim(D)
    for(i in 1:N){
        N1[[i]] <- D
        x <- floor(runif(1,1,dimD[1]))
        y <- floor(runif(1,1,x))
        N1[[i]][x,y] = ifelse(N1[[i]][x,y]==0,1,0)
    }
    N1
}

getscores <- function(graphs){
    scores <- rep(0,length(graphs))
    for(i in 1:length(graphs)){
        scores[i]<- DAG.score2(L=graphs[[i]])
        }
    scores
}

getDnew <- function(gamma, scores2, graphs2){
    pvec <- exp(scores2^gamma)
    pvec <- pvec/sum(pvec)
    cpvec <- cumsum(pvec)
    u <- runif(1,0,1)
    Dind <- min(sum(u > cpvec) + 1,length(scores2))
    graphs2[[Dind]]
}

getLk <- function(gamma,M,N1,D0){

    graphs <- getNgraphs(D0,N1)
    scores <- getscores(graphs)
    D0 <- getDnew(gamma,scores,graphs)
    for(i in 2:M){
        graphs2 <- getNgraphs(D0,N1)
        scores2 <- getscores(graphs2)
        D0 <- getDnew(gamma,scores2,graphs2)
        graphs <- append(graphs,graphs2)
        scores <- append(scores,scores2)
    }
    return(list(graphs=graphs, scores=scores))
}

Largestscoregraph <- function(gamma,D,M,N1){
    L <- list()
    for(i in 1:length(D)){
        newL <- getLk(gamma,M,N1,D[[i]])
        L$graphs <- append(newL$graphs,L$graphs)
        L$scores <- append(newL$scores,L$scores)
    print(i)
    }
    L$graphs[[which.max(L$scores)]]
}

Sel.G=Largestscoregraph(gamma=0.5,D=Graphs,M=3,N1=10)

#Replace selDAG1.csv by selDAGj.csv when running a different replicate, j=2,3,4
write.table(sel.G,col.names=FALSE,row.names=FALSE,file="selDAG1.csv", sep=",")

##--This file (selDAG1.csv) is an input in program Gibbs_Sampler_General_Graph


##Ukázka 6=name
##R workshop=group
##vstupni_raster=raster
##velikost_okna=number 9
##vystupni_raster=output raster

raster_pasmo <- raster(vstupni_raster, layer = 1)

vystupni_raster <- focal(raster_pasmo,
						 w=matrix(1/(velikost_okna*velikost_okna),
						 nrow=velikost_okna,
						 ncol=velikost_okna))


#' Scale
#'
#' Centers and/or scales the columns of a distributed matrix.
#'
#' @section Communication:
#' The communication consists of two allreduce calls, each quadratic on the
#' number of columns.
#'
#' @param x
#' A shaq.
#' @param center
#' logical value, determines whether or not columns are zero centered
#' @param scale
#' logical value, determines whether or not columns are rescaled to unit variance
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(rnorm, 10, 3, mean=30, sd=10)
#'
#' x
#' scale(x)
#'
#' finalize()
#' }
#'
#' @name scale
#' @rdname scale
NULL

scale.shaq = function(x, center=TRUE, scale=TRUE)
{
  if (!center && !scale) # u dum
    return(x)

  cm = colMeans(x)

  if (center)
  {
    Data = base::scale(Data(x), center=cm, scale=FALSE)
    attr(Data, "scaled:center") = cm
  }

  if (scale) # this is disgusting, but it's the only way to do this without a million copies
  {
    if (!center)
      Data = Data(x)

    csd = sqrt(allreduce(base::colSums(Data*Data)) / (nrow(x)-1))

    Data = base::scale(if (center) Data else Data(x), center=FALSE, scale=csd)
    attr(Data, "scaled:scale") = csd
  }

  shaq(Data, nrow(x), ncol(x), checks=FALSE)
}

#' @rdname scale
#' @export
setGeneric(name="scale", useAsDefault=base::scale, package="kazaam")

#' @rdname scale
#' @export
setMethod("scale", signature(x="shaq", center="logical", scale="logical"), scale.shaq)


## Trabajo final MAPP Otoño. Métodos cuantitativos.
## Integrantes:
## Guadalupe Álvarez
## Ángel Carrillo
## Eduardo Muñiz

Sys.setlocale("LC_ALL", "es_ES.UTF-8") # Cambiar locale para prevenir problemas con caracteres especiales
options(scipen=999) # Prevenir notación científica
rm(list=ls()) #Limpia todas las variables y objetos creados

##### Paquetería ----
library(tidyverse)
library(ggplot2)
library(ggcorrplot)
library(ggthemes)

library(cluster)
library(dplyr)
library(pacman)
library(factoextra)
library(dendextend)
library(purrr)

##### Base de datos ----
computoeinegi <- read.csv("2021 computoeinegi.csv")
str(computoeinegi)
head(computoeinegi)

 View(computoeinegi)

###################################
####### Indice de cosas por hacer:
###################################

 # FECHA DE ENTREGA: 13 Y 14 DE DICIEMBRE

 #Distinguir entre tipos de variables:
 # Cuales te sirven para regresión: explicada y explicativas
 # variables taxonómicas: son las que caracterizan.
 # pensar como cuanti y cuali
 # qué variables explican mejor el fenómeno
 # qué variables caracterizan mejor a la población
 #

# Limpiar la base
# Estadistica descriptiva LALO
# ANOVA LUPITA
# Regresión lineal con variables explicativas CARILLO
 # Hito 1: DEBE ESTAR LISTO EL  25-NOV EN LA NOCHE
 # Ahí cordinarnos por mensajería sobre lo siguiente.

# Usar variables explicativas para analisis de componentes principales
 # crear subconjunto de variables
 # utilizar estas variables explicativas para:
 # Conglomerados
 # Nuevo grupos
 # con nuevos grupos analisis jerárquico.

##### Estadística descriptiva ----

gr_participacion <- ggplot( computoeinegi,
                   aes(x=distrito , y=participacion) )+
              geom_point(color=computoeinegi$id_entidad) +
              labs(title="Participación electoral",
                  subtitle="Proceso Electoral Federal 2021.",
                  x="Distrito electoral federal",
                  y="Porcentaje de participación",
                  caption="Elaboración propia con datos de INE(2021).") +
              theme_economist()+
              theme(axis.text.x=element_text(angle=50,size=12) )

plot(gr_participacion)

# Otro cambio de prueba

### Analisis de conglomerados ----

## para el análisis de conglomerados adaptamos la BD
row.names(computoeinegi)<-computoeinegi$distrito
computoeinegi<- computoeinegi[, -c(1,2,3,4,5,7)]
computoeinegi
View(computoeinegi)
str(computoeinegi)
computoeinegi$n_complejidad<-as.factor(computoeinegi$n_complejidad)


writexy <- function(file, x, y, xprecision=3, yprecision=3)
{
   #Format inputs as required, and join together
   fx <- formatC(x, digits=xprecision, format="g", flag="-")
   fy <- formatC(y, digits=yprecision, format="g", flag="-")
   dfr <- data.frame(fx, fy)
   #Write to file.  Note that this encloses the formatted number in quotes,
   write.table(dfr, file=file, sep="\t", row.names=FALSE)
   #... so we have to process the output
   str <- readLines(file)
   writeLines(gsub('"', '', str), file)
}

x <- c(1, 2, 3, 1e11)
y <- sqrt(x)
writexy('test.txt', x, y, yp=5)


test_that("define_slope_factor",{
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2")
  )
  slope_weights = c(0,3)
  result <- define_slope_factor(dat_new, 'bilbo', slope_weights)
  expect_equal(result, 'bilbo_slope =~ 0*factor1 + 3*factor2')
})

test_that("define_slope_factor - given NAs",{
  dat_new <- data.frame(
    factor1=c("var1","var2"),
    factor2=c("2var1","2var2"),
    factor3=c("2var1","2var2"),
    factor4=c("2var1","2var2")
  )
  slope_weights = c(0,NA,NA,5)
  result <- define_slope_factor(dat_new, 'bilbo', slope_weights)
  expect_equal(result, 'bilbo_slope =~ 0*factor1 + NA*factor2 + NA*factor3 + 5*factor4')
})


#' Population interpolation annual and single age in MSDem
#'
#' This function allows you to calculate population size by sex or by regions using the MSDem output
#' @param res1 data
#' @param agel lower limit - default is 0
#' @param ageu upper limit - default it 'max'
#' @param period specific periods - default is NULL
#' @param sex specific sex - default is NULL
#' @param bysex group by sex - default is FALSE
#' @param reg specific region(s)
#' @param byreg group by regions - default is FALSE
#' @param resi specific residence(s)
#' @param byresi group by residences - default is FALSE
#' @return R list with five data.table 1) var_def 2) state_space 3) mig_dom 4) mig_int 5) results
#' @keywords read
#' @export
#' @examples

# 1. The initial data as you have seen are for 5-year periods and 5-year intervals (on 1 july of each year),
#
# 2. so the interpolation is done first to create a cross-sectional annual time series of 5-year age groups
# (1-BeersOInterpol.r and IND_Pop2015B5_1.7.csv as sample input test data for India population both sexes for 2015 WPP revision),
#
# 3. and then it gets transformed into single ages (e.g., IND_Pop2015B1x1-step1-sprague.csv),
#
# 4. and interpolated by cohort for the pivotal years ending in 0 and 5 for which the estimates/projections are available
#     (2-SpragueSplit.r).
#
# At very old ages some alternative method with additional constraint needs to be added
# to avoid implausible negative populations (e.g., IND_Pop2015B1x1-step2-pchipGE90.csv).
#
# A special provision is needed to deal with the youngest age group and oldest age groups which cannot be
# interpolated by cohort.
#
# The cohort interpolation can be done using linear or exponential interpolation.
# In previous WPP revisions the interpolation used was linear, but exponential interpolation alleviates
# some of the artifact fluctuations.

popinterpkc <- function(x){
  x<<-x
  head(x)
  # stop()
  #1. The initial data as you have seen are for
  #5-year periods and 5-year intervals (on 1 july of each year),

  iage <- sort(unique(x$age))
  iper <- unique(x$period)
  x1<-x%>%select(period,age,pop)%>%spread(period,pop)%>%select(-age)

  # xx_8_90 <- x1[-19,8]*(x1[-1,8]/x1[-19,7])
  # xx_age0_4 <- (x1[1,8]/sum(x1[5:8,8]))*sum(xx_8_90[4:7,1])
  # x1[,9] <- rbind(xx_age0_4,xx_8_90)
  #colnames(x1)[6] <- 2036
  x1 <- as.matrix(x1)
  row.names(x1) <- iage

  # 2. so the interpolation is done first to create a cross-sectional annual time series of 5-year age groups
  # (1-BeersOInterpol.r and IND_Pop2015B5_1.7.csv as sample input test data for India population both sexes for 2015 WPP revision),
  tp <- t(x1)
  YEAR <- as.numeric(substr(rownames(tp),1,4))
  FYEAR <- min(YEAR) #2011
  LYEAR <- max(YEAR) #2021
  ## dimensions
  NY <- 5                        # Number of years in period
  NCOL <- dim(tp)[2]             # number of data columns/number of countries/time series
  NYEAR5 <- dim(tp)[1]           # number of five year period
  NYEAR1 <- (NYEAR5 - 1) * 5 + 1 # number of single years
  ## Beers Ordinary Interpol
  bc <- c(
    1.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.0000,
    0.6667,  0.4969, -0.1426, -0.1006,  0.1079, -0.0283,
    0.4072,  0.8344, -0.2336, -0.0976,  0.1224, -0.0328,
    0.2148,  1.0204, -0.2456, -0.0536,  0.0884, -0.0244,
    0.0819,  1.0689, -0.1666, -0.0126,  0.0399, -0.0115,
    0.0000,  1.0000,  0.0000,  0.0000,  0.0000,  0.0000,
    -0.0404,  0.8404,  0.2344, -0.0216, -0.0196,  0.0068,
    -0.0497,  0.6229,  0.5014, -0.0646, -0.0181,  0.0081,
    -0.0389,  0.3849,  0.7534, -0.1006, -0.0041,  0.0053,
    -0.0191,  0.1659,  0.9354, -0.0906,  0.0069,  0.0015,
    0.0000,  0.0000,  1.0000,  0.0000,  0.0000,  0.0000,
    0.0117, -0.0921,  0.9234,  0.1854, -0.0311,  0.0027,
    0.0137, -0.1101,  0.7194,  0.4454, -0.0771,  0.0087,
    0.0087, -0.0771,  0.4454,  0.7194, -0.1101,  0.0137,
    0.0027, -0.0311,  0.1854,  0.9234, -0.0921,  0.0117,
    0.0000,  0.0000,  0.0000 , 1.0000,  0.0000,  0.0000,
    0.0015,  0.0069, -0.0906 , 0.9354,  0.1659, -0.0191,
    0.0053, -0.0041, -0.1006 , 0.7534,  0.3849, -0.0389,
    0.0081, -0.0181, -0.0646 , 0.5014,  0.6229, -0.0497,
    0.0068, -0.0196, -0.0216 , 0.2344,  0.8404, -0.0404,
    0.0000,  0.0000,  0.0000,  0.0000,  1.0000,  0.0000,
    -0.0115,  0.0399, -0.0126, -0.1666,  1.0689,  0.0819,
    -0.0244,  0.0884, -0.0536, -0.2456,  1.0204,  0.2148,
    -0.0328,  0.1224, -0.0976, -0.2336,  0.8344,  0.4072,
    -0.0283,  0.1079, -0.1006, -0.1426,  0.4969,  0.6667,
    0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  1.0000
  )

  ## Format for Beers ordinary coefficients 26 x 6 fixed
  ##first part is added
  bm <- matrix(bc,26,6,byrow = T)

  # number of middle panels
  MP <- NYEAR5 - 5 #Issue, I have NYEARS = 3

  ## creating a beers coefficient matrix for single years
  bcm <- array(0, dim = c(NYEAR1,NYEAR5))

  ## inserting first two panels
  bcm[1:10,1:6] <- bm[1:10,]

  # inserting middle panels
  for (i in (1:MP))
  {
    # calculate the slices and add middle panels accordingly
    bcm[((i + 1)*NY + 1):((i + 2)*NY), i:(i + NY)] <- bm[11:15,]
  }
  ## insert last two panels
  bcm[((NYEAR5 - 3)*NY + 1):(NYEAR1),MP:(MP + NY)]<- bm[16:26,]
  options(max.print = 10000000)
  pop <- bcm %*% as.matrix(tp)
  colnames(pop) <- colnames(tp)
  rownames(pop) <- c(FYEAR:LYEAR)

  tp <-t(pop)
  Age5 <- as.numeric(row.names(tp))

  return(data.frame(age=Age5,tp))

}
# At very old ages some alternative method with additional constraint needs to be added
# to avoid implausible negative populations (e.g., IND_Pop2015B1x1-step2-pchipGE90.csv).
#
# A special provision is needed to deal with the youngest age group and oldest age groups which cannot be
# interpolated by cohort.
#
# The cohort interpolation can be done using linear or exponential interpolation.
# In previous WPP revisions the interpolation used was linear, but exponential interpolation alleviates
# some of the artifact fluctuations.

# births.interp <-function(x) {
#   ########################################################################
#   ## Interpolation of of event data (five year periods)
#   ## fifth/single years by Beers Modified six-term formula
#   ## (Siegel and Swanson, 2004, p. 729)
#   ## This formula applies some smoothing to the interpolant, which is
#   ## recommended for time series of events with some dynamic
#   ## R implementation by Thomas Buettner (21 Oct. 2015)
#   ########################################################################
#
#
#
#   x <<- x
#   tp <- x$births
#   #stop("..")
#   ## interpolation period
#   YEAR1 <- (x$year)
#   YEAR2 <- (x$year)+5
#   YEAR <- 0.5 + (YEAR1 + YEAR2)/2
#
#   FYEAR <- min(YEAR1) #1950
#   LYEAR <- max(YEAR2) #2100
#   LYEAR1 <- LYEAR - 1
#
#   ## dimensions
#   NCOL =1
#   #NCOL <- dim(tp)[2]   ## countries or trajectories
#   #NAG5 <- dim(tp)[1]   ## age or time
#   NAG5 = length(YEAR1)
#   # number of single year or single age groups
#   NAG1 <- NAG5 * 5
#
#   ## Beers Modified Split
#   bc <- c(
#     0.3332, -0.1938,  0.0702, -0.0118,  0.0022 ,
#     0.2569, -0.0753,  0.0205, -0.0027,  0.0006 ,
#     0.1903,  0.0216, -0.0146,  0.0032, -0.0005 ,
#     0.1334,  0.0969, -0.0351,  0.0059, -0.0011 ,
#     0.0862,  0.1506, -0.0410,  0.0054, -0.0012 ,
#
#     0.0486,  0.1831, -0.0329,  0.0021, -0.0009 ,
#     0.0203,  0.1955, -0.0123, -0.0031, -0.0004 ,
#     0.0008,  0.1893,  0.0193, -0.0097,  0.0003 ,
#     -0.0108,  0.1677,  0.0577, -0.0153,  0.0007 ,
#     -0.0159,  0.1354,  0.0972, -0.0170,  0.0003 ,
#
#     -0.0160,  0.0973,  0.1321, -0.0121, -0.0013 ,
#     -0.0129,  0.0590,  0.1564,  0.0018, -0.0043 ,
#     -0.0085,  0.0260,  0.1650,  0.0260, -0.0085 ,
#     -0.0043,  0.0018,  0.1564,  0.0590, -0.0129 ,
#     -0.0013, -0.0121,  0.1321,  0.0973, -0.0160 ,
#
#     0.0003, -0.0170,  0.0972,  0.1354, -0.0159 ,
#     0.0007, -0.0153,  0.0577,  0.1677, -0.0108 ,
#     0.0003, -0.0097,  0.0193,  0.1893,  0.0008 ,
#     -0.0004, -0.0031, -0.0123,  0.1955,  0.0203 ,
#     -0.0009,  0.0021, -0.0329,  0.1831,  0.0486 ,
#
#     -0.0012,  0.0054, -0.0410,  0.1506,  0.0862 ,
#     -0.0011,  0.0059, -0.0351,  0.0969,  0.1334 ,
#     -0.0005,  0.0032, -0.0146,  0.0216,  0.1903 ,
#     0.0006, -0.0027,  0.0205, -0.0753,  0.2569 ,
#     0.0022, -0.0118,  0.0702, -0.1938,  0.3332
#   )
#   ## standard format for Beers coefficients
#   bm <- matrix(bc,25,5,byrow = T)
#
#   ## Age vector
#   a <- seq(0, (NAG5 - 1)*5, by = 5)
#
#   # number of middle panels
#   MP <- NAG5 - 5 + 1
#
#   ## creating a beers coefficient matrix for 18 5-year age groups
#   bcm <- array(0, dim = c(NAG1,NAG5))
#
#   ## insert first two panels
#   bcm[1:10,1:5] <- bm[1:10,]
#
#   for (i in (1:MP))
#   {
#     # calculate the slices and add middle panels accordingly
#     bcm[((i + 1)*5 + 1):((i + 2)*5), i:(i + 4)] <- bm[11:15,]
#   }
#
#   ## insert last two panels
#   bcm[((NAG5 - 2)*5 + 1):(NAG5*5),MP:(MP + 4)] <- bm[16:25,]
#
#   options(max.print = 10000000)
#
#   pop <- bcm %*% as.matrix(tp)
#
#   ## write un-shifted results
#   ## write.csv(pops, ofn)
#
#   ## shifting the interpolant by half a year forward
#   ## In general, each interval is halved and the the halves are recombined to form a calendar year.
#   ## The first missing half year is assumed to be equal the half of the first interval.
#   ## This means simply that the first year is equal to the first (shifted) interval
#   ## The implementation used vector arithmetic by constructing a parallel data array
#   ## with the first element equal to the original first interval,
#   ## and filling the rest with the original data up to n-1 elements
#   ## Adding the two data structures and dividing the result by two
#   ## produces the shifted time reference.
#
#   pop2 <- array(0, dim = c(NAG1,NCOL))
#   pop2[1,] <- pop[1,]
#   pop2[2:NAG1,] <- pop[1:(NAG1 - 1),]
#   pops <- (pop + pop2)*0.5
#
#   return(data.frame(value=pops)%>%mutate(year=seq(FYEAR,LYEAR-1,by=1)))
#
# }


a<-Read.MCMC.detailed.data()
a<-subset(a,Year==2012,select=c(-Repetion, -Iteration))
names(a)
#[1] "Species"   "Species.n" "Year"      "Quarter"   "Age"       "N"  "F"         "M2"

# data used to update
aa<-subset(a,Quarter==1)
aa<-tapply(aa$N,list(aa$Species.n,aa$Age),sum)
cat('stock numbers at age, Remember to insert age 0=0\n')
aa*1000

M2.a<-tapply(a$M2,list(a$Species,a$Quarter,a$Age),sum)
N.a<-tapply(a$N,list(a$Species,a$Quarter,a$Age),sum)
ftable(round(M2.a,3))

b<-Read.summary.data(infile="OP_summary.out",read.init.function=F)
b<-subset(b,Year==2012)
M2.b<-tapply(b$M2,list(b$Species,b$Quarter,b$Age),sum)
ftable(round(M2.b,3))

N.b<-tapply(b$N,list(b$Species,b$Quarter,b$Age),sum)

ftable(round(N.a,0))
ftable(round(N.b/1000,0))

ftable(round(M2.a,3))
ftable(round(M2.b,3))

ftable(round(tapply(a$F,list(a$Species,a$Age),sum),3))
ftable(round(tapply(b$F,list(b$Species,b$Age),sum),3))


#!/usr/bin/env Rscript

#===========================================================
# R script for plotting different features of individual genomic bins - 1D plots

#Author: Sourya Bhattacharyya
#Vijay-Ay lab, LJI
#===========================================================
library(optparse)
library(ggplot2)
library(data.table)

options(scipen = 10)
options(datatable.fread.datatable=FALSE)

# variables depicting the dimension of plots
PlotWidth <- 10
PlotHeight <- 8
cexthr <- 0.05

#===================================================
# this function is useful for plotting X-Y distribution
# subject to a binning employed
# the number of bins are also provided as an input argument
PlotBinnedDistr <- function(var1, var2, plotfile, xlab, ylab, titlestr, nbin=100) {
	colorvec <- c("blue", "cyan", "green", "yellow", "orange", "brown", "violet", "red")
	curr_plot <- ggplot(data.frame(var1,var2), aes(x=var1,y=var2)) + geom_bin2d(bins = nbin) + scale_fill_gradientn(colours=colorvec) + labs(x = xlab, y = ylab, title = titlestr)
	ggsave(plotfile, plot = curr_plot, width=PlotWidth, height=PlotHeight)
}

#===========================================================
# function for plotting distribution (histogram style)
PlotDistr <- function(inpvec, plotfile, titlestr, xlabelstr, ylabelstr, xlimvec=c(), stepsize=0.1) {
	pdf(plotfile, width=PlotWidth, height=PlotHeight)
	# plot a histogram where X axis denotes the input vector and Y axis denotes the corresponding frequency
	# step size of the histogram is default 0.1 (unless specified as an input parameter)
	# limit of X axis may be specified with the input "xlimvec"
	if (length(xlimvec) == 2) {
		inpvec <- inpvec[which(inpvec>=xlimvec[1] & inpvec<=xlimvec[2])]
	}
	maxelem <- max(inpvec)
	no_of_breaks <- as.integer(maxelem / stepsize)
	hist(inpvec, main=titlestr, xlab=xlabelstr, ylab=ylabelstr, border="red", col="blue", breaks=no_of_breaks)
	dev.off()
}

# #===================================================
# # NEW function
# # to compute the bin specific interactions
# # where the bins are formed according to the distribution of values in the input data
# # parameters:
# # var1 and var2 are the two variables (data of two columns to be used for X and Y axis)
# # colorvar: variable which is used for coloring the heatmap (generally the contact count)
# # nbin: no of bins to be employed for each variable
# # xlab, ylab, colorlab: labels associated with individual variables
# # titlestr: title of the generated plot
# # UseLog: if 1, uses the log10 scale of the color quantity variable

# PlotBinnedCC <- function(var1, var2, colorvar, plotfile, xlab, ylab, colorlab, titlestr, UseLog=0, nbin=20) {
# 	quant_interval <- (1.0 / nbin)
# 	colorvec <- c("blue", "cyan", "green", "yellow", "orange", "brown", "violet", "red")
# 	# pointsize <- 0.01

# 	# the range which will be used for displaying the heatmap
# 	# every map should have identical range for comparison of the color map
# 	minrange <- 0
# 	maxrange <- 10

# 	# quantile of two input variables
# 	# to place them in equal occupancy bins
# 	var1_Quant_values <- unique(quantile(var1, probs=seq(0, 1, quant_interval)))
# 	var2_Quant_values <- unique(quantile(var2, probs=seq(0, 1, quant_interval)))

# 	var1.quant <- as.integer(cut(var1, var1_Quant_values, include.lowest=TRUE))
# 	var2.quant <- as.integer(cut(var2, var2_Quant_values, include.lowest=TRUE))

# 	# now analyze the vector depicting the heatmap
# 	TargetVec <- as.numeric(colorvar)

# 	# if log scale is used, first convert the input data into log2 scale
# 	if (UseLog == 1) {
# 		TargetVec <- log2(TargetVec)
# 	}

# 	# create a data frame
# 	# Note: simple cbind operation does not produce the data frame object
# 	df <- data.frame(var1Q=var1.quant, var2Q=var2.quant, contact=TargetVec)

# 	# the color variable (values) for the common bin pairs are averaged (using the FUN=mean argument)
# 	# a new data frame needs to be assigned
# 	# its column  names also need to be adjusted
# 	df1 <- aggregate(df$contact, by=list(var1Q=df$var1Q,var2Q=df$var2Q), FUN=mean)
# 	colnames(df1) <- colnames(df)

# 	# we shift the range of contact count distribution to set a fixed color scale
# 	range_mult <- (maxrange - minrange) / (max(df1$contact) - min(df1$contact))
# 	df1$contact <- df1$contact * range_mult
# 	offset <- minrange - min(df1$contact)
# 	df1$contact <- df1$contact + offset

# 	# compute the mean contact count (bin specific) and also the SAD of contact
# 	# with respect to all bins
# 	# after shifting the scale to the common color scale and range
# 	mean_contact <- mean(df1$contact)
# 	SAD_mean_contact <- sum(abs(df1$contact - mean_contact))
# 	titlestr <- paste0(titlestr, ' mean contact: ', mean_contact, ' SAD mean contact: ', SAD_mean_contact)

# 	# plot the generated aggregated data frame
# 	# the TargetVec is used for filling the colors
# 	curr_plot <- ggplot(df1, aes(x=var1Q, y=var2Q)) + geom_tile(aes(fill=contact),color="blue") + scale_fill_gradientn(colours=colorvec, limits=c(minrange, maxrange)) + labs(x = xlab, y = ylab, title = titlestr, colour = colorlab) + scale_x_continuous(expand = c(0, 0), breaks=1:length(var1_Quant_values), labels=paste(var1_Quant_values)) + scale_y_continuous(expand = c(0, 0), breaks=1:length(var2_Quant_values), labels=paste(var2_Quant_values)) + theme(axis.text.x = element_text(angle = 90, hjust = 1))

# 	ggsave(plotfile, plot = curr_plot, width=PlotWidth, height=PlotHeight)
# }

#===================================================
option_list = list(
  	make_option(c("--GenomeBinFile"), type="character", default=NULL, help="File containing the genome bins and associated features"),
  	make_option(c("--CommonDir"), type="character", default=NULL, help="directory storing the plots for non-bias related features"),
	make_option(c("--BiasSpecificDir"), type="character", default=NULL, help="directory storing the plots for bias specific features"),
	make_option(c("--OverWrite"), type="integer", action="store", default=0, help="if 1, overwrites the plots"),
  	make_option(c("--NoMappGC"), type="logical", action="store_true", default=FALSE, help="If TRUE, there is no Mappability, GC content, or RE sites information in the feature file. Default FALSE.")
);

opt_parser = OptionParser(option_list=option_list);
opt = parse_args(opt_parser);

# read the genome bins and associated normalization features
# Note: the file does not have header information
# InpData <- read.table(opt$GenomeBinFile, header=F, sep="\t", stringsAsFactors=F)
InpData <- data.table::fread(opt$GenomeBinFile, header=F, sep="\t", stringsAsFactors=F)
# colnames(InpData) <- c("chr1","s1","e1","coverage","isPeak", "Bias", "Mapp", "GCContent", "numREsites")

system(paste('mkdir -p', opt$CommonDir))
system(paste('mkdir -p', opt$BiasSpecificDir))

# find the indices corresponding to peak and non peaks
PeakIdx <- which(InpData[,5] == 1)
NonPeakIdx <- which(InpData[,5] == 0)

# note the indices having peak information and non zero coverage
PeakIDXNonZeroCoverage <- intersect(which(InpData[,4]> 0), which(InpData[,5]==1))

# note the indices of non peak and non zero coverage
nonPeakIDXNonZeroCoverage <- intersect(which(InpData[,4]> 0), which(InpData[,5]==0))

# Bias of the peak segments and non-zero coverage
BiasPeakVec <- InpData[PeakIDXNonZeroCoverage, 6]

# Bias of the non-peak segments and non-zero coverage
BiasNonPeakVec <- InpData[nonPeakIDXNonZeroCoverage, 6]

#=========================
# Plotting the distribution / histogram of bias with respect to the peak segments
#=========================
OutPlotFile <- paste0(opt$BiasSpecificDir, '/Peak_Bias.pdf')
if ((file.exists(OutPlotFile) == FALSE) | (opt$OverWrite == 1)) {
	PlotDistr(BiasPeakVec, OutPlotFile, "Bias distribution for peaks", "Bias (ratio w.r.t mean)", "Peak frequency", c(0,10))
}

#=========================
# Plotting the distribution / histogram of bias with respect to the non-peak segments
#=========================
OutPlotFile <- paste0(opt$BiasSpecificDir, '/NonPeak_Bias.pdf')
if ((file.exists(OutPlotFile) == FALSE) | (opt$OverWrite == 1)) {
	PlotDistr(BiasNonPeakVec, OutPlotFile, "Bias distribution for non-peaks", "Bias (ratio w.r.t mean)", "Non-Peak frequency", c(0,10))
}

#=========================
# Density Plot - GC content vs Coverage - for peaks, non peaks and for all segments
#=========================
if (opt$NoMappGC == FALSE) {

	plotfile <- paste0(opt$CommonDir, '/GCContent_vs_Coverage_ALL.pdf')
	if ((file.exists(plotfile) == FALSE) | (opt$OverWrite == 1)) {
		PlotBinnedDistr(InpData[,8], InpData[,4], plotfile, "GC content", "Coverage", "Variation between GC content and coverage for all segments", 10)
	}

	plotfile <- paste0(opt$CommonDir, '/GCContent_vs_Coverage_Peaks.pdf')
	if ((file.exists(plotfile) == FALSE) | (opt$OverWrite == 1)) {
		PlotBinnedDistr(InpData[PeakIdx,8], InpData[PeakIdx,4], plotfile, "GC content", "Coverage", "Variation between GC content and coverage for Peaks", 10)
	}

	plotfile <- paste0(opt$CommonDir, '/GCContent_vs_Coverage_NonPeaks.pdf')
	if ((file.exists(plotfile) == FALSE) | (opt$OverWrite == 1)) {
		PlotBinnedDistr(InpData[NonPeakIdx,8], InpData[NonPeakIdx,4], plotfile, "GC content", "Coverage", "Variation between GC content and coverage for Non peaks", 10)
	}
}

#=========================
# Density Plot - Mappability vs Coverage - for peaks, non peaks and for all segments
#=========================
if (opt$NoMappGC == FALSE) {
	plotfile <- paste0(opt$CommonDir, '/Mappability_vs_Coverage_ALL.pdf')
	if ((file.exists(plotfile) == FALSE) | (opt$OverWrite == 1)) {
		PlotBinnedDistr(InpData[,7], InpData[,4], plotfile, "Mappability", "Coverage", "Variation between Mappability and coverage for all segments", 10)
	}

	plotfile <- paste0(opt$CommonDir, '/Mappability_vs_Coverage_Peaks.pdf')
	if ((file.exists(plotfile) == FALSE) | (opt$OverWrite == 1)) {
		PlotBinnedDistr(InpData[PeakIdx,7], InpData[PeakIdx,4], plotfile, "Mappability", "Coverage", "Variation between Mappability and coverage for Peaks", 10)
	}

	plotfile <- paste0(opt$CommonDir, '/Mappability_vs_Coverage_NonPeaks.pdf')
	if ((file.exists(plotfile) == FALSE) | (opt$OverWrite == 1)) {
		PlotBinnedDistr(InpData[NonPeakIdx,7], InpData[NonPeakIdx,4], plotfile, "Mappability", "Coverage", "Variation between Mappability and coverage for Non peaks", 10)
	}
}