###########################################################################################
## Nighttime light in Mexican states at analytical units                                 ##
##                                                                                ##
## Code to export municipal- and electoral sección-level statistics using INE's polygons ##
## (see https://github.com/emagar/luminosity for details)                                ##
##                                                                                ##
## Prepared by Eric Magar 30apr2021                                                      ##
## emagar at itam dot mx                                                                 ##
###########################################################################################

## # OJO: when using spTranform in script, use line below for google earth, or next line for OSM/google maps
#x.map <- spTransform(x.map, CRS("+proj=longlat +datum=WGS84"))
#x.map <- spTransform(x.map, osm()) # project to osm native Mercator

# to use osm backgrounds
library(rJava)
library(OpenStreetMap)
library(rgdal)
library(raster)

# geospatial data
#library(spdep);
library(maptools)
# used to determine data's datum
library(rgdal)
#gpclibPermit()

rm(list = ls())

# my state abbrevs
edos <- c("ags", "bc", "bcs", "cam", "coa", "col", "cps", "cua", "df", "dgo", "gua", "gue", "hgo", "jal", "mex", "mic", "mor", "nay", "nl", "oax", "pue", "que", "qui", "san", "sin", "son", "tab", "tam", "tla", "ver", "yuc", "zac")

rd <- c("~/Dropbox/data/mapas/luminosity/")
#md <- c("~/Dropbox/data/elecs/MXelsCalendGovt/redistrict/ife.ine/mapasComparados/loc/maps/0code/")
#md <- c("~/Dropbox/data/elecs/MXelsCalendGovt/redistrict/ife.ine/mapasComparados/")                 # uses 2017 INE maps
md <- c("~/Dropbox/data/mapas/cartografia-2020/")                                                    # uses 2020 INE maps

for (e in 29){
#e <- 13

# select state to process
edon <- e; edo <- edos[edon]
print(paste("Will process", toupper(edo), "stats"))

# state's borders
#tmp <- paste(md, "fed/shp/disfed2018/", edo, sep = "") # archivo con mapas 2017
tmp <- paste(md, edo, sep = "")                         # archivo con mapas 2018
ed.map <- readOGR(dsn = tmp, layer = 'ENTIDAD')
summary(ed.map)
# projects to a different datum with long and lat
ed.map <- spTransform(ed.map, osm())
#
# state's municipios
#tmp <- paste(md, "fed/shp/disfed2018/", edo, sep = "") # archivo con mapas 2017
tmp <- paste(md, edo, sep = "")                         # archivo con mapas 2018
mu.map <- readOGR(dsn = tmp, layer = 'MUNICIPIO')
summary(mu.map)
# projects to a different datum with long and lat
mu.map <- spTransform(mu.map, osm()) # project to osm native Mercator
#plot(mu.map)
#
# state's secciones
#tmp <- paste(md, "fed/shp/disfed2018/", edo, sep = "") # archivo con mapas 2017
tmp <- paste(md, edo, sep = "")                         # archivo con mapas 2018
se.map <- readOGR(dsn = tmp, layer = 'SECCION')
summary(se.map)
# projects to a different datum with long and lat
se.map <- spTransform(se.map, osm()) # project to osm native Mercator
#plot(se.map)
# prepare data.frame to receive luminosity seccion-level stats
dat <- se.map@data
dat$ord <- 1:nrow(dat)

# l will receive state/year's stats, then will be rbound to year's dataframe ly
l <- data.frame(ord = dat$ord, edon = dat$entidad, seccion = dat$seccion); l$median <- l$sd <- l$mean <- NA; l$note <- ""
ses <- l$seccion

calc.yr <- function(yr){
    #yr <- 2000 # debug
    ly <- data.frame()
    # open raster layer
    pth <- paste(rd, "raster/", edo, "/l", yr, ".tif", sep="") # archivo de luminosidad
    r <- raster(pth) # filenames 1992-2013
    # projects to a different datum with long and lat
    r <- projectRaster(r, crs=osm()) # project to osm native Mercator
    # clip raster to state
    r <- mask(r, ed.map)         # approximate poligon only
#drop maybe    r[is.na(r)] <- 0 # make NAs zeroes
    ## # verify
## #    png(file = "../pics/bc.png")
##     par(mar=c(.5,.5,2,1)) ## SETS B L U R MARGIN SIZES
##     plot(r, axes = FALSE, main = edo)
##     plot(ed.map, add = TRUE, lwd = .2)
## #    plot(se.map, add = TRUE, lwd = .1)
#    dev.off()
    #
    # copy master data.frame
    l.work <- l
    # fill row-by-row
    for (i in 1:length(ses)){
        #i <- 100 # debug
        ## if (
        ##   (edon==1  & ses[i] %in% c(318,603:607))  # secciones shapefiles appear to be corrupted
        ## | (edon==7  & ses[i] %in%   2042:2048)
        ## | (edon==16 & ses[i] %in% c(2080,2696:2703))
        ## ){
        ##     l.work$note[i] <- "shapefile corrupted"
        ##     next
        ## }
        message(sprintf("%spct of %s-%s: i=%s sección %s", round(i*100/length(ses),0), edo, yr, i, ses[i]))
        one.se <- subset(se.map, se.map@data$seccion==ses[i])
        #plot(one.se, main=paste("sección", ses[i]))
        # clip raster to seccion
        r.se <- crop(r, extent(one.se)) # crop to plot area
        #plot(r.se, main=paste("sección", ses[i]))
        r.se <- mask(r.se, one.se)         # approximate poligon
        ## # verify
        ## par(mar=c(.5,.5,2,4)) ## SETS B L U R MARGIN SIZES
        ## plot(one.se, main=paste("sección", ses[i]))
        ## plot(r.se, add = TRUE)
        ## plot(one.se, add = TRUE, lwd = .5)
        #
        v <- unlist(extract(r, one.se)) # get values inside poligon
        l.work$mean  [i] <- round(mean  (v),2)
        l.work$sd    [i] <- round(sd    (v),2)
        l.work$median[i] <- round(median(v),2)
    }
    ly <- rbind(ly, l.work)
    return(ly)
}

i <- 1992
for (i in 1992:2018){
    yr <- i
    ly <- calc.yr(yr=yr)
    ly <- ly[order(ly$seccion),] # sort
    ly$ord <- NULL # drop plotting order
    tail(ly)
    pth <- paste(rd, "data/secciones/", edo, "/lum", yr, ".csv", sep="") # archivo de luminosidad
    write.csv(ly, file = pth, row.names=FALSE)
}

# l will receive state/year's stats, then will be rbound to year's dataframe ly
dat.mu <- mu.map@data
dat.mu$ord <- 1:nrow(dat.mu)
l <- data.frame(ord = dat.mu$ord, edon = dat.mu$entidad, munn = dat.mu$municipio, mun = dat.mu$nombre); l$median <- l$sd <- l$mean <- NA; l$note <- ""
mus <- l$munn

calc.yr.mu <- function(yr){
    #yr <- 2000 # debug
    ly <- data.frame()
    # open raster layer
    pth <- paste(rd, "raster/", edo, "/l", yr, ".tif", sep="") # archivo de luminosidad
    r <- raster(pth) # filenames 1992-2013
    # projects to a different datum with long and lat
    r <- projectRaster(r, crs=osm()) # project to osm native Mercator
    # clip raster to state
    r <- mask(r, ed.map)         # approximate poligon only
#drop    r[is.na(r)] <- 0 # make NAs zeroes
    ## # verify
    ## plot(r)
    ## plot(ed.map, add = TRUE, lwd = .2)
    ## plot(se.map, add = TRUE, lwd = .1)
    #
    # copy master data.frame
    l.work <- l
    # fill row-by-row
    for (i in 1:length(mus)){
        #i <- 1 # debug
        ## if (
        ##   (edon==1  & ses[i] %in% c(318,603:607))  # secciones shapefiles appear to be corrupted
        ## | (edon==7  & ses[i] %in%   2042:2048)
        ## | (edon==16 & ses[i] %in% c(2080,2696:2703))
        ## ){
        ##     l.work$note[i] <- "shapefile corrupted"
        ##     next
        ## }
        message(sprintf("%spct of %s-%s: i=%s mun %s", round(i*100/length(mus),0), edo, yr, i, mus[i]))
        one.mu <- subset(mu.map, mu.map@data$municipio==mus[i])
        #plot(one.se, main=paste("sección", ses[i]))
        # clip raster to seccion
        r.mu <- crop(r, extent(one.mu)) # crop to plot area
        #plot(r.se, main=paste("sección", ses[i]))
        r.mu <- mask(r.mu, one.mu)         # approximate poligon
        ## # verify
        ## plot(one.mu)
        ## plot(r.mu, add = TRUE)
        ## plot(one.mu, add = TRUE, lwd = .2)
        #
        v <- unlist(extract(r, one.mu)) # get values inside poligon
        l.work$mean  [i] <- round(mean  (v),2)
        l.work$sd    [i] <- round(sd    (v),2)
        l.work$median[i] <- round(median(v),2)
    }
    ly <- rbind(ly, l.work)
    return(ly)
}

i <- 1992
for (i in 1992:2018){
    yr <- i
    ly <- calc.yr.mu(yr=yr)
    ly <- ly[order(ly$munn),] # sort
    ly$ord <- NULL # drop plotting order
    tail(ly)
    pth <- paste(rd, "data/municipios/", edo, "/lum", yr, ".csv", sep="") # archivo de luminosidad
    write.csv(ly, file = pth, row.names=FALSE)
}
}


#' Site selection method
#'
#' This function uses the method outlined in Roy et al (2012) and Isaac et al (2014) for selecting
#' well-sampled sites from a dataset using list length and number of years as selection criteria.
#'
#' @param taxa A character vector of taxon names, as long as the number of observations.
#' @param site A character vector of site names, as long as the number of observations.
#' @param time_period A numeric vector of user defined time periods, or a date vector,
#' as long as the number of observations.
#' @param minL numeric, The minimum number of taxa recorded at a site at a given time period
#' (list-length) for the visit to be considered well sampled.
#' @param minTP numeric, The minimum number of time periods, or if time_period is a date the minimum
#' number of years, a site must be sampled in for it be be considered well sampled.
#' @param LFirst Logical, if \code{TRUE} data is first filtered by list-length then time periods,
#' else time period then list-length
#' @return A data.frame of data that forefills the selection criteria
#' @export
#' @references needed
#' @examples
#' # Create data
#' n <- 150 #size of dataset
#' nyr <- 8 # number of years in data
#' nSamples <- 20 # set number of dates
#'
#' # Create somes dates
#' first <- as.POSIXct(strptime("2003/01/01", "%Y/%m/%d"))
#' last <- as.POSIXct(strptime(paste(2003+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
#' dt <- last-first
#' rDates <- first + (runif(nSamples)*dt)
#'
#' # taxa are set as random letters
#' taxa <- sample(letters, size = n, TRUE)
#'
#' # three sites are visited randomly
#' site <- sample(c('one', 'two', 'three'), size = n, TRUE)
#'
#' # the date of visit is selected at random from those created earlier
#' time_period <- sample(rDates, size = n, TRUE)
#'
#' # combine this to a dataframe
#' df <- data.frame(taxa, site, time_period)
#' head(df)
#'
#' # Use the site selection function on this simulated data
#' dfSEL  <- siteSelection(df$taxa, df$site, df$time_period, minL = 4, minTP = 3)

siteSelection <- function(taxa, site, time_period, minL, minTP, LFirst = TRUE){

  # Run error checks
  errorChecks(taxa = taxa, site = site, time_period = time_period)

  # If list length first
  if(LFirst){

    f_sub <- suppressWarnings(siteSelectionMinL(taxa, site, time_period, minL))
    s_sub <- suppressWarnings(siteSelectionMinTP(f_sub$taxa, f_sub$site, f_sub$time_period, minTP))

  } else {

    f_sub <- suppressWarnings(siteSelectionMinTP(taxa, site, time_period, minTP))
    s_sub <- suppressWarnings(siteSelectionMinL(f_sub$taxa, f_sub$site, f_sub$time_period, minL))

  }

  ## ADD IN CAPTURE AND OUTPUT OF THE ATTRIBUTES

  if(nrow(s_sub) == 0) warning('Filtering in siteSelection resulted in no data returned')
  return(s_sub)

}


setwd("/Users/erhv/Data_Sets/Fuel Economy/csv")
library(reshape)
options(stringsAsFactors = FALSE)

csv <- dir(".", pattern="[0-9]{4}\\.csv$")
years <- as.numeric(gsub("\\.csv", "", csv))

files <- lapply(csv, read.csv)
files <- mapply(function(df, y) transform(df, year = y), files, years, SIMPLIFY= FALSE)

cols <- sapply(files, function(x) names(x)[1:30])
write.table(cols, "col-names.csv", sep=",", quote=F, row=F)

mapping <- read.csv("col-mapping.csv")
newnames <- mapping$abbr
names(newnames) <- mapping$full

files <- lapply(files, rename, newnames)
names(files[[10]]) [30] <- "filler"
names(files[[11]]) [30] <- "filler"
mpg <- do.call("rbind.fill", files)

names(mpg) <- c("class", "manufacturer", "model", "displ", "cyl", "trans",
"drv", "cty", "hwy", "cmb", "ucty", "uhwy", "ucmb", "fl", "G",
"T", "S", "X2pv", "X2lv", "X4pv", "X4lv", "hpv", "hlv", "fcost",
"eng.dscr", "trans.dscr", "year", "vpc", "cls", "bidx", "x5c"
)

chr <- sapply(mpg, is.character)
mpg[chr] <- lapply(mpg[chr], tolower)
mpg$class <- gsub("spec purp veh - ", "", mpg$class)
mpg$class <- gsub("special purpose vehicle", "s.u.v. -", mpg$class)

mpg$class[grep("minivan", mpg$class)] <- "minivan"

# Convert old mpg to new (post-2008) mpg --------------------------------
new_city <- function(mpg, year) {
  ifelse(year < 2008, round(1 / (0.003259 + (1.1805 / round(mpg / 0.9)))), mpg)
}
new_highway <- function(mpg, year) {
  ifelse(year < 2008, round(1 / (0.001376 + (1.3466 / round(mpg / 0.78)))), mpg)
}

mpg <- transform(mpg,
  cty = new_city(cty, year),
  hwy = new_highway(hwy, year)
)

# Remove inconsistent variables ----------------------------------------
mpg$eng.dscr.1 <- NA
mpg$eng.dscr.2 <- NA

mpg$cmb <- NULL
mpg$fcost <- NULL
mpg$cls <- NULL
mpg$ucty <- NULL
mpg$uhwy <- NULL
mpg$ucmb <- NULL

#mpg$X2pv  <- NULL
#mpg$X2lv  <- NULL
#mpg$X4pv  <- NULL
#mpg$X4lv <- NULL

# Fix boolean labels -

mpg$T[is.na(mpg$T)] <- FALSE
mpg$G <- ifelse(mpg$G == "g", T, F)
mpg$S <- ifelse(mpg$S == "s", T, F)

#Create variables to match 1978-1983
names(mpg) [14:19] <-c( "twodoor.p", "twodoor.l", "fourdoor.p", "fourdoor.l", "hatch.p", "hatch.l")

# Remove bad rows

mpg <- subset(mpg, model != "")

write.table(mpg, "mpg.csv", sep=",", row=F)
write.table(mpg, "mpg.txt", sep="\t", row=F)


required_Packages = c("tximport", "readr", "DESeq2",
                      "rjson", "dplyr")
if(!all(required_Packages %in% installed.packages())){
	source("https://bioconductor.org/biocLite.R")
	biocLite(setdiff(required_Packages, installed.packages()))
}

require(tximport)
require(readr)
require(DESeq2)
require(rjson)
require(dplyr)

args=commandArgs(T)
design_path = args[1] # Path of design matrix
output = args[2] # Path of output file
ref = args[3] # Directory of reference file

design_mat = read.table(design_path, sep="\t", header=F)
gsm = as.vector(design_mat[,1])
condition = as.vector(design_mat[,2])
# gsm = c('GSM2746716', 'GSM2746717', 'GSM2746718', 'GSM2746719')
# output = '/data5/home/changxin/tmp/'
files = sapply(gsm, function(i){paste0(output, '/', i, '/quant.sf')})
# condition = c('Ctrl', 'Ctrl', 'Treat', 'Treat')
names = names(gsm)
sampleTable <- data.frame(sampleName = files, fileName = files, condition = condition)
txi_tx <- tximport(files, type="salmon", ,ignoreTxVersion = TRUE, txOut = TRUE, dropInfReps = TRUE)
dds_tx <- DESeqDataSetFromTximport(txi_tx,colData=sampleTable,design=~condition)
dds_tx <- dds_tx[rowSums(counts(dds_tx)) > 1, ]
dds_tx <- DESeq(dds_tx)
res_tx <- results(dds_tx, alpha = 0.05)
#de_new = na.omit(res_tx)
res_tx$padj[is.na(res_tx$padj)] = 1
de_new = res_tx
refseq =read.table(ref, sep = "\t", row.names = 1)

co_index = intersect(rownames(de_new), rownames(refseq))
result = cbind(de_new[co_index,], refseq[co_index,"V6"])
colnames(result)[7]  = "symbol"
result = result[order(result[,6]),]
result2 = distinct(as.data.frame(result), symbol, .keep_all = TRUE)
rownames(result2) = result2$symbol

write.table(result2[,1:6], paste0(output, '/DE_table.csv'), sep='\t', quote=F)


##' Helper function to convert a data frame of forecasts into a list of matrices
##'
##' @param x input data frame
##' @return list of matrices
##' @author Sebastian Funk
##' @importFrom dplyr select
##' @importFrom tidyr unite pivot_wider
##' @keywords internal
to_matrix <- function(x) {
  x %>%
    dplyr::select(-model) %>%
    tidyr::unite(prediction_date, creation_date, value_date) %>%
    tidyr::pivot_wider(names_from = "quantile", values_from = "value") %>%
    dplyr::select(starts_with("0")) %>%
    as.matrix()
}

##' Helper function to create a QRA ensemble
##'
##' @param preds predictions
##' @param qra_res QRA result
##' @return tibble
qra_create_ensemble <- function(preds, qra_res, iso = FALSE) {
  pred_matrices <- preds %>%
    dplyr::select(-weight) %>%
    dplyr::group_split(model) %>%
    lapply(to_matrix) %>%
    quantgen::combine_into_array()

  values <- predict(qra_res, pred_matrices, iso = iso)
  colnames(values) <- unique(preds$quantile)

  res <- preds %>%
    mutate(nmodels = length(unique(model))) %>%
    select(-model, -quantile, -weight, -value) %>%
    distinct() %>%
    cbind(as_tibble(values)) %>%
    tidyr::pivot_longer(matches("^0"),
                        names_to = "quantile", values_to = "value") %>%
    mutate(quantile = as.numeric(quantile))

  return(res)
}

##' Helper function to estimate weights for QRA.
##'
##' @param x input data frame containing \code{model}, \code{quantile}, \code{boundary},
##' \code{value}, \code{interval} columns.
##' @return data frame with weights per quantile (which won't vary unless
##' \code{per_quantile_weights} is set to TRUE), per model
##' @importFrom quantgen combine_into_array quantile_ensemble
##' @importFrom dplyr mutate select distinct group_split
##' @importFrom tidyr expand_grid unite
##' @keywords internal
qra_estimate_weights <-
  function(x, per_quantile_weights, intercept,
           enforce_normalisation = FALSE, ...) {

    pred_matrices <- x %>%
      dplyr::select(-data)

    pred_matrices <- pred_matrices %>%
      dplyr::group_split(model) %>%
      lapply(to_matrix) %>%
      quantgen::combine_into_array()

    data <- x %>%
      tidyr::unite(prediction_date, creation_date, value_date) %>%
      dplyr::group_by_at(dplyr::vars(-model, -quantile, -value, -data)) %>%
      dplyr::summarise(data = unique(data)) %>%
      .$data

    tau <- x %>%
      dplyr::select(quantile) %>%
      dplyr::distinct() %>%
      .$quantile

    if (per_quantile_weights) {
      tau_groups <- seq_along(tau)
    } else {
      tau_groups <- rep(1, length(tau))
    }

    qe <-
      quantgen::quantile_ensemble(pred_matrices, data, tau,
                                  tau_groups = tau_groups,
                                  nonneg = enforce_normalisation,
                                  unit_sum = enforce_normalisation,
                                  intercept = intercept,
                                  time_limit = 60,
                                  ...)
    ## retrieve weights from optimisation
    if (per_quantile_weights) {
      weights <- c(t(qe$alpha))
    } else if (intercept) {
      weights <- rep(qe$alpha[-1], each = length(unique(x$quantile)))
    } else {
      weights <- rep(qe$alpha, each = length(unique(x$quantile)))
    }

    ## create return tibble
    ret <- tidyr::expand_grid(model = unique(sort(x$model)),
                              quantile = unique(x$quantile)) %>%
      dplyr::mutate(weight = weights)

    return(tibble(weights = list(ret), res = list(qe)))
}

##' @name qra
##' @title Quantile Regression Average
##' Calculates a quantile regression average for forecasts.
##' @param forecasts data frame with forecasts; this is expected to have columns
##' \code{model} (a character string), \code{creation_date} (the date at which the
##' forecast was made), \code{value_date} (the date for which a forecsat was
##' created), \code{quantile} (the quantile level, between 0 and
##' 1) and \code{value} (the forecast at the quantile level)
##' @param data data frame with a \code{value} column, and otherwise matching columns
##' to \code{forecasts} (especially \code{value_date})
##' @param target_date the date for which to create a QRA; by default, will use
##' the latest \\code{creation_date} in \\code{forecasts}
##' @param min_date the minimum creation date for past forecasts to be included
##' @param max_date the maximum creation date for past forecasts to be included
##' @param history number of historical forecasts to include
##' @param pool any columns to pool as a list of character vectors (e.g.,
##' "horizon", "geography_scale", etc.) indicating columns in the \code{forecasts}
##' and \code{data} data frames; by default, will not pool across anything
##' @param quantiles Numeric - which quantiles to consider; by default will
##' consider the maximum spanning set. Options are determined by data but will be between
##' 0 and 1.
##' @param max_future Numeric - the maximum number of days of forecast to consider
##' @importFrom dplyr filter arrange desc inner_join mutate rename select bind_rows group_by_at starts_with
##' @importFrom tidyr complete nest
##' @importFrom rlang !!! syms
##' @importFrom readr parse_number
##' @importFrom tidyselect all_of
##' @importFrom purrr map
##' @inheritParams qra_estimate_weights
##' @return a list of \code{ensemble}, a data frame similar to the input forecast,
##' but with \\code{model} set to "Quantile regression average" and the values
##' set to the weighted averages; and \code{weights}, a data frame giving the weights
##' @export
qra <- function(forecasts, data, target_date, min_date, max_date, history,
                pool, quantiles, max_future = Inf,
                per_quantile_weights = FALSE, enforce_normalisation = TRUE,
                intercept = FALSE, ...) {

  ## set target date to last forecast date if missing
  if (missing(target_date)) {target_date <- max(forecasts$creation_date)}
  ## initialise pooling to empty vector if not given
  if (missing(pool)) {pool <- c()}

  if (!missing(history) && history > 0 && (!missing(min_date) || !missing(max_date))) {
    stop("If 'history' is given and > 0, 'min_date' and 'max_date' can't be." )
  }

  forecasts <- forecasts %>%
    dplyr::mutate(horizon = as.integer(value_date - creation_date)) %>%
    dplyr::arrange(dplyr::desc(creation_date), model, quantile)

  ## data frame with the forecasts that are being combined
  latest_forecasts <- forecasts %>%
    dplyr::filter(creation_date == target_date)

  ## prepare data frame containing data and predictions
  obs_and_pred <- forecasts %>%
    dplyr::filter(creation_date < target_date)

  ## data available at the time of target_date
  if ("truncation" %in% colnames(data)) {
    available_data <- data %>%
      filter(value_date + truncation <= target_date) %>%
      select(-truncation)
  } else {
    available_data <- data
  }

  creation_dates <- unique(obs_and_pred$creation_date)

  ## determine dates for training data set
  if (!missing(min_date)) {
    creation_dates <- creation_dates[creation_dates >= min_date]
  }
  if (!missing(max_date)) {
    creation_dates <- creation_dates[creation_dates <= max_date]
  }
  if (!missing(history) && history > 0) {
    if (history <= length(creation_dates)) {
      creation_dates <-
        creation_dates[seq_len(history)]
    } else {
      return(list(weights = NULL, ensemble = NULL))
    }
  }

  ## create helper vars for creating a complete set of models to be used for
  ## training below
  grouping_vars <-
    setdiff(colnames(obs_and_pred),
            c("creation_date", "value_date", "value", "model", "data", "quantile", pool))
  pooling_vars <-
    c("model", "creation_date", pool)

  latest_checked <- latest_forecasts %>%
    dplyr::group_by_at(tidyselect::all_of(grouping_vars)) %>%
    ## create complete tibble of all combinations of creation date, model
    ## and pooling variables
    tidyr::complete(!!!syms(setdiff(pooling_vars, "horizon"))) %>%
    ## check if anything is missing and filter out
    dplyr::group_by_at(
             tidyselect::all_of(c(grouping_vars, "model"))) %>%
    dplyr::mutate(any_na = any(is.na(value))) %>%
    dplyr::filter(!any_na) %>%
    dplyr::select(-any_na)

  if (nrow(latest_checked) == 0) {
    return(list(weights = NULL, ensemble = NULL))
  }

  present_models <- latest_checked %>%
    ## check present models
    dplyr::select_at(tidyselect::all_of(c("model", grouping_vars))) %>%
    dplyr::distinct()

  if (nrow(present_models) > 0) {

    ## create training data set
    obs_and_pred <- obs_and_pred %>%
      dplyr::filter(creation_date %in% creation_dates) %>%
      ## select present models
      dplyr::inner_join(present_models, by = colnames(present_models))

    ## maximum horizon by grouping variables - the last date on which all models
    ## are available
    max_horizons <- obs_and_pred %>%
      filter(horizon <= max_future) %>%
      dplyr::group_by_at(
               tidyselect::all_of(c(setdiff(grouping_vars, "horizon"),
                                    "creation_date", "model"))) %>%
      dplyr::mutate(max_horizon = max(horizon)) %>%
      dplyr::group_by_at(tidyselect::all_of(c(grouping_vars, "creation_date"))) %>%
      dplyr::summarise(max_horizon = min(max_horizon)) %>%
      dplyr::ungroup()

    obs_and_pred <- obs_and_pred %>%
      ## filter <= max horizon
      dplyr::left_join(max_horizons, by = c(grouping_vars, "creation_date")) %>%
      dplyr::filter(horizon <= max_horizon) %>%
      dplyr::select(-max_horizon)

  }

  obs_and_pred <- obs_and_pred %>%
      ## join data
      dplyr::inner_join(available_data,
                 by = setdiff(colnames(available_data), c("value"))) %>%
      dplyr::rename(value = value.x, data = value.y)

  ## check if only specific quantiles are to be used
  if (!missing(quantiles)) {
    obs_and_pred <- obs_and_pred %>%
      dplyr::filter(quantile %in% quantiles)
  }

  ## require a complete set of forecasts to be include in QRA
  complete_set <- obs_and_pred %>%
    dplyr::group_by_at(tidyselect::all_of(c(grouping_vars, "horizon"))) %>%
    ## create complete tibble of all combinations of creation date, model
    ## and pooling variables
    tidyr::complete(!!!syms(pooling_vars)) %>%
    ## check if anything is missing and filter out
    dplyr::group_by_at(
             tidyselect::all_of(c(grouping_vars, "model"))) %>%
    dplyr::mutate(any_na = any(is.na(value))) %>%
    dplyr::filter(!any_na) %>%
    dplyr::select(-any_na) %>%
    ungroup()

  ## perform QRA
  if (nrow(complete_set) > 0) {
    ensemble <- complete_set %>%
    filter(!is.na(data)) %>%
    tidyr::nest(test_data = c(-setdiff(grouping_vars, "creation_date"))) %>%
    dplyr::mutate(weights =
                    purrr::map(test_data, qra_estimate_weights,
                               per_quantile_weights = per_quantile_weights,
                               enforce_normalisation = enforce_normalisation,
                               intercept = intercept)) %>%
    tidyr::unnest(weights) %>%
    select(-test_data)

    if (nrow(ensemble) > 0) {

      weights <- ensemble %>%
        dplyr::select(-res) %>%
        tidyr::unnest(weights)

      pred <- latest_checked %>%
        dplyr::select(-horizon) %>%
        dplyr::mutate(creation_date = target_date) %>%
        ## only keep value dates which have all models present
        dplyr::group_by_at(
                 tidyselect::all_of(c(grouping_vars, "value_date", "quantile"))) %>%
        dplyr::mutate(n = n()) %>%
        dplyr::group_by_at(tidyselect::all_of(grouping_vars)) %>%
        dplyr::filter(n == max(n)) %>%
        dplyr::select(-n) %>%
        dplyr::ungroup() %>%
        ## join weights
        dplyr::inner_join(weights, by = c(setdiff(grouping_vars, "creation_date"),
                                          "model", "quantile")) %>%
        ## weigh quantiles
        tidyr::nest(predictions = c(-setdiff(grouping_vars, "creation_date"))) %>%
        dplyr::inner_join(ensemble %>% dplyr::select(-weights),
                          by = c(setdiff(grouping_vars, "creation_date"))) %>%
        dplyr::mutate(values = purrr::map2(predictions, res, qra_create_ensemble, ...)) %>%
        select(-predictions, -res) %>%
        tidyr::unnest(values)
    } else {
      weights <- NULL
      pred <- NULL
    }
  } else {
    weights <- NULL
    pred <- NULL
  }

  return(list(ensemble = pred, weights = weights))
}


## editted version of enrichPeakOverlap from CHIPSeeker package to
## 1) report FC statistic
## 2) test both over and under enrichment.
## calculate fold change statistic as ratio of obeserved overlap to mean overlap.

##' calculate overlap significant of ChIP experiments based on the genome coordinations
##'
##'
##' @title enrichPeakOverlap
##' @param queryPeak query bed file or GRanges object
##' @param targetPeak target bed file(s) or folder that containing bed files or a list of GRanges objects
##' @param TxDb TxDb
##' @param pAdjustMethod pvalue adjustment method
##' @param nShuffle shuffle numbers
##' @param chainFile chain file for liftOver
##' @param pool logical, whether pool target peaks
##' @param mc.cores number of cores, see \link[parallel]{mclapply}
##' @param verbose logical
##' @return data.frame
##' @export
##' @importFrom rtracklayer import.chain
##' @importFrom rtracklayer liftOver
##' @author G Yu
enrichPeakOverlap <- function(queryPeak, targetPeak, TxDb=NULL, pAdjustMethod="BH", nShuffle=1000,
                              chainFile=NULL, pool=TRUE, mc.cores=detectCores()-1, verbose=TRUE) {
    TxDb <- loadTxDb(TxDb)
    query.gr <- loadPeak(queryPeak)
    if (is(targetPeak[1], "GRanges") || is(targetPeak[[1]], "GRanges")) {
        target.gr <- targetPeak
        targetFiles <- NULL
    } else {
        targetFiles <- parse_targetPeak_Param(targetPeak)
        target.gr <- lapply(targetFiles, loadPeak)
    }

    if (!is.null(chainFile)) {
        chain <- import.chain(chainFile)
        target.gr <- lapply(target.gr, liftOver, chain=chain)
    }

    if (pool) {
        p.ol <- enrichOverlap.peak.internal(query.gr, target.gr, TxDb, nShuffle,
                                            mc.cores=mc.cores,verbose=verbose)
    } else {
        res_list <- lapply(1:length(target.gr), function(i) {
            enrichPeakOverlap(queryPeak = queryPeak,
                              targetPeak = target.gr[i],
                              TxDb = TxDb,
                              pAdjustMethod = pAdjustMethod,
                              nShuffle = nShuffle,
                              chainFile = chainFile,
                              mc.cores = mc.cores,
                              verbose = verbose)
        })
        res <- do.call("rbind", res_list)
        return(res)
    }

    if (is.null(p.ol$pvalueOver)) {
        p2 <- p1 <- padj <- NA
    } else {
        p1 <- p.ol$pvalueOver
		p2 <- p.ol$pvalueUnder
        padj <- p.adjust(p1, method=pAdjustMethod)
    }

    ol <- p.ol$overlap
	fc <- p.ol$foldchange
	fc.l95 <- p.ol$foldchangeL95
	fc.u95 <- p.ol$foldchangeU95

    if (is(queryPeak, "GRanges")) {
        qSample <- "queryPeak"
    } else {
        ## remove path, only keep file name
        qSample <- basename(queryPeak)
    }

    if (is.null(targetFiles)) {
        tSample <- names(target.gr)
        if(is.null(tSample)) {
            tSample <- paste0("targetPeak", seq_along(target.gr))
        }
    } else {
        tSample <- basename(targetFiles)
    }

    res <- data.frame(qSample=qSample,
                      tSample=tSample,
                      qLen=length(query.gr),
                      tLen=unlist(lapply(target.gr, length)),
                      N_OL=ol,
					  foldchange=fc,
					  foldchangeL95=fc.l95,
					  foldchangeU95=fc.u95,
                      pvalueOver=p1,
					  pvalueUnder=p2,
                      p.adjust=padj)

    return(res)
}

##' @import GenomeInfoDb
##' @importFrom utils txtProgressBar
##' @importFrom utils setTxtProgressBar
##' @importFrom parallel mclapply
##' @importFrom parallel detectCores
enrichOverlap.peak.internal <- function(query.gr, target.gr, TxDb, nShuffle=1000, mc.cores=detectCores()-1, verbose=TRUE) {
    if (verbose) {
        cat(">> permutation test of peak overlap...\t\t",
            format(Sys.time(), "%Y-%m-%d %X"), "\n")
    }

    idx <- sample(1:length(target.gr), nShuffle, replace=TRUE)
    len <- unlist(lapply(target.gr, length))

    if(Sys.info()[1] == "Windows") {
        qLen <- lapply(target.gr, function(tt) {
            length(intersect(query.gr, tt))
        })
    } else {
        qLen <- mclapply(target.gr, function(tt) {
            length(intersect(query.gr, tt))
        }, mc.cores=mc.cores)
    }
    qLen <- unlist(qLen)
    ## query ratio
    qr <- qLen/len

    if (nShuffle < 1) {
        res <- list(pvalueOver=NULL, pvalueUnder=NULL, overlap=qLen, foldchange=NULL, foldchangeL95 = NULL, foldchangeU95 = NULL)
        return(res)
    }

    if (verbose) {
        pb <- txtProgressBar(min=0, max=nShuffle, style=3)
    }
    if(Sys.info()[1] == "Windows") {
        rr <- lapply(seq_along(idx), function(j) {
            if (verbose) {
                setTxtProgressBar(pb, j)
            }
            i <- idx[j]
            tarShuffle <- shuffle(target.gr[[i]], TxDb)
            length(intersect(query.gr, tarShuffle))/len[i]
        })
    } else {
        rr <- mclapply(seq_along(idx), function(j) {
            if (verbose) {
                setTxtProgressBar(pb, j)
            }
            i <- idx[j]
            tarShuffle <- shuffle(target.gr[[i]], TxDb)
            length(intersect(query.gr, tarShuffle))/len[i]
        }, mc.cores=mc.cores,mc.preschedule = FALSE)
    }

    if (verbose) {
        close(pb)
    }

    rr <- unlist(rr) ## random ratio

	fc<-unlist(lapply(qr, function(q) q/mean(rr)))
	fc.l95<-unlist(lapply(qr, function(q) q/quantile(rr, 0.975)))
	fc.u95<-unlist(lapply(qr, function(q) q/quantile(rr, 0.025)))

    ## p <- lapply(qr, function(q) mean(rr>q))
	## this is calculation of one-side p for over enrichment
    p1 <- unlist(lapply(qr, function(q) (sum(rr>q)+1)/(length(rr)+1)))
	## add in calculation of one-sided p for under enrichment
	p2 <- unlist(lapply(qr, function(q) (sum(rr<q)+1)/(length(rr)+1)))

    res <- list(pvalueOver=p1, pvalueUnder=p2, overlap=qLen, foldchange=fc, foldchangeL95 = fc.l95, foldchangeU95 = fc.u95)
    return(res)
}

## additional utility functions that need to be loaded but not editted

loadPeak <- function(peak, verbose=FALSE) {
    if (is(peak, "GRanges")) {
        peak.gr <- peak
    } else if (file.exists(peak)) {
        if (verbose)
            cat(">> loading peak file...\t\t\t\t",
                format(Sys.time(), "%Y-%m-%d %X"), "\n")
        peak.gr <- readPeakFile(peak, as="GRanges")
    } else {
        stop("peak should be GRanges object or a peak file...")
    }
    return(peak.gr)
}

##' @importFrom TxDb.Hsapiens.UCSC.hg19.knownGene TxDb.Hsapiens.UCSC.hg19.knownGene
loadTxDb <- function(TxDb) {
    if ( is.null(TxDb) ) {
        warning(">> TxDb is not specified, use 'TxDb.Hsapiens.UCSC.hg19.knownGene' by default...")
        TxDb <- TxDb.Hsapiens.UCSC.hg19.knownGene
    }
    return(TxDb)
}

## function to count min overlap
countOverlapMin<-function(query, test, min = 0.5){
	## if provided as proportion then looking for overlap proportional to query region
	if(min < 1){
		whichOverlap<-findOverlaps(test,query)
		testLengths<-width(test[queryHits(whichOverlap)])
		thresLength<-min*testLengths

	} else {
		thresLength = min
	}
	return(sum(width(intersect(test, query)) > thresLength))
}


# P A R A M S
nShockspan <- 3
nServerDefaultLife <- 3
nSegments <- 1

# S T A N D A R D   S H O C K   F O R M A T T I N G
sPlotFile <- (  sprintf("shockspan%d",nShockspan)
            %+% sprintf("server%d",nServerDefaultLife)
            %+% sprintf("seg%d",nSegments)
            %+% ".png"
            )
fnGroupBy <- function(dfIn) {group_by(dfIn, copies, lifem
                                    , serverdefaultlife
                                    , shockfreq, shockspan, shockimpact
                                    , auditfrequency, auditsegments
                                    )}
fnSubset <- function(dfIn)  {subset(dfIn,
                                      serverdefaultlife==nServerDefaultLife * 10000
                                    & shockspan==nShockspan
                                    & copies>=5
                                    & auditfrequency==10000
                                    & auditsegments==nSegments
                                    )}
want.varnames <- c("copies","lifem","lost","docstotal","serverdefaultlife"
                ,"shockfreq","shockimpact","shockspan","shockmaxlife"
                ,"auditfrequency","audittype","auditsegments"
                ,"deadserversactive","deadserversall")
fnNarrow <- function(dfIn)  {dfIn[want.varnames]}

# G E T   D A T A
# Get the data into the right form for these plots.
alldat.df <- fndfGetGiantDataRaw("")
allnewdat <- alldat.df %>% fnNarrow() %>% fnGroupBy() %>%
summarize(losspct=round(mean(lost/docstotal)*100.0, 2), n=n())
newdat <- fnSubset(allnewdat)
trows <- newdat

sTitleLine <-   (   ""
                %+% "Shocks: "
                %+% sprintf("span=%d; ", nShockspan)
                %+% sprintf("ServerDefaultHalflife=%dyrs ", nServerDefaultLife)
                %+% " "
                %+% "\n"
                %+% "\n(Copies=5+; annual systematic auditing in "
                %+% sprintf("%d segment(s))", nSegments)
                )
sLegendLabel <- "  Number of \nAudited Copies"
lLegendItemLabels <- c("5","6","7")
sTimestamp <- fngettime()
sSamples <- sprintf("samples=%d ", min(trows$n))
sXLabel <- ("Shock Frequency (half-life) in hours "
            %+% "      (one metric year = 10,000 hours) "
            %+% "                           (less frequent shocks =====>)"
            )
sXLabel <- sXLabel %+% ("\n\n                                  " # cheapo rjust.
            %+% sprintf("          %s   %s   %s", sPlotFile,sTimestamp,sSamples)
            )
sYLabel <- ("probability of losing the entire collection (%)")
# ************ Also change summarize function and ggplot(color=...).
# E N D   O F   S T A N D A R D   F O R M A T T I N G


# rarefy unique function rarefies your file to only unique occurrence points
# input for rarefy_unique is a csv with columns lat, long
# example usage:
# source("rarefy_update.r")
# rarefy_unique("test.csv")

rarefy_unique <- function(file) {
	x <- as.matrix(read.csv(file))

	# keep only unique coordinates
	x <- rbind(c("Lat","Long"), unique(x))

	# write output
	write.table(x, file = paste(substr(file, 1, nchar(file) - 4), "_unique.csv", sep=""), row.names=F,
		col.names=F, quote=F, sep=",")
}

# rarefy function rarefies your file to points at least distance.km kilometers apart
# input for rarefy is a csv with columns lat, long
# example usage:
# source("rarefy_update.r")
# rarefy("test.csv", 5)

rarefy <- function(file, distance.km) {
	require(fossil)
	x <- as.matrix(read.csv(file))

	# ensure distance is numeric
	distance.km <- as.numeric(distance.km)

	# keep only unique coordinates
	x <- unique(x)

	# counter for continuing rarefication
	reps <- nrow(x) - 1

	# create output file
	output <- c()

	# create initial object for testing
	x2 <- x

	# if large dataset, subset first to narrow down
	if(reps > 1000) {
		writeLines(paste("There are many points, subsetting"))

		x3 <- x2
		s.reps <- as.integer(reps / 1000) + 1

		# create 1,000 point subsets
		subsets <- list()
		for(a in 1:s.reps) {
			if(a == s.reps) {
				subsets[[a]] <- x3
			} else {
				subsets[[a]] <- x3[1:1000, ]
				x3 <- x3[1001:nrow(x3),]
			}

		}

		# distance filter each subset
		output.temp <- list()
		for(a in 1:s.reps) {
			writeLines(paste("Subset a", a*1000, "of", s.reps*1000))
			reps.temp <- nrow(subsets[[a]])
			out.temp <- c()
			a.rep.temp <- subsets[[a]]
			# distance functions while > 20 points left (arbitrary number)
			while(reps.temp > 20) {
				a.rep <- as.vector(a.rep.temp[1,])
				a.rep.temp <- a.rep.temp[2:nrow(a.rep.temp),]
				out.temp <- rbind(out.temp, a.rep)
				testing <- apply(a.rep.temp, 1, distance, yy.value = a.rep)
				a.rep.temp <- a.rep.temp[testing > distance.km, ]
				if(!is.null(nrow(a.rep.temp))) {
					reps.temp <- nrow(a.rep.temp) - 1
				} else {
					reps.temp <- 1
				}

			}
			out.temp <- rbind(out.temp, a.rep.temp)
			output.temp[[a]] <- out.temp
		}
		# sum total number of points left
		total <- 0
		for(a in 1:s.reps) {
			total <- total + nrow(output.temp[[a]])
		}
		writeLines(paste("There are still", total, "points left"))

		# take all output and put in a new matrix
		new.x2 <- c()
		for(a in 1:s.reps) {
			new.x2 <- rbind(new.x2, output.temp[[a]])
		}
		x2 <- new.x2
		reps <- nrow(x2) - 1
	}

	# if still large dataset, subset again to narrow down
	if(reps > 1000) {
		writeLines(paste("There are many points, subsetting again"))

		x3 <- x2
		s.reps <- as.integer(reps / 1000) + 1

		# create 1,000 point subsets
		subsets <- list()
		for(a in 1:s.reps) {
			if(a == s.reps) {
				subsets[[a]] <- x3
			} else {
				subsets[[a]] <- x3[1:1000, ]
				x3 <- x3[1001:nrow(x3),]
			}

		}

		# distance filter each subset
		output.temp <- list()
		for(a in 1:s.reps) {
			writeLines(paste("Subset b", a*1000, "of", total))
			reps.temp <- nrow(subsets[[a]])
			out.temp <- c()
			a.rep.temp <- subsets[[a]]
			# distance functions while > 20 points left (arbitrary number)
			while(reps.temp > 20) {
				a.rep <- as.vector(a.rep.temp[1,])
				a.rep.temp <- a.rep.temp[2:nrow(a.rep.temp),]
				out.temp <- rbind(out.temp, a.rep)
				testing <- apply(a.rep.temp, 1, distance, yy.value = a.rep)
				a.rep.temp <- a.rep.temp[testing > distance.km, ]
				if(!is.null(nrow(a.rep.temp))) {
					reps.temp <- nrow(a.rep.temp) - 1
				} else {
					reps.temp <- 1
				}
			}
			out.temp <- rbind(out.temp, a.rep.temp)
			output.temp[[a]] <- out.temp
		}
		# sum total number of points left
		total <- 0
		for(a in 1:s.reps) {
			total <- total + nrow(output.temp[[a]])
		}
		writeLines(paste("There are still", total, "points left"))

		# take all output and put in a new matrix
		new.x2 <- c()
		for(a in 1:s.reps) {
			new.x2 <- rbind(new.x2, output.temp[[a]])
		}
		x2 <- new.x2
		reps <- nrow(x2) - 1
	}

	# while loop to keep going until filtered through entire file
	while(reps >= 1) {
		if(reps %% 50 == 0) {
			writeLines(paste("Final Countdown:", reps))
		}
		# distance functions while > 2 points left
		if(reps > 1) {
			a.rep <- as.vector(x2[1,])
			x2 <- x2[2:nrow(x2),]
			output <- rbind(output, a.rep)
			testing <- apply(x2, 1, distance, yy.value = a.rep)
			x2 <- x2[testing > distance.km, ]
			if(!is.null(nrow(x2))) {
				reps <- nrow(x2) - 1
			} else {
				if(length(x2) > 0) {
					x2 <- rbind(as.vector(x2), as.vector(x2))
					reps <- 1
				} else {
					reps <- 0
				}
			}
		} else if(reps == 1) { # finish if there is only one point left
			x2 <- x2[2:nrow(x2),]
			output <- rbind(output, as.vector(x2))
			reps <- 0
		}

	}

	# write output
	output <- rbind(c("Lat", "Long"), output)
	write.table(output, file = paste(substr(file, 1, nchar(file) - 4), "_", distance.km, "km_rarefy.csv",
		sep=""), row.names=F, col.names=F, quote=F, sep=",")

}

# function to be used with apply to get all distances from a matrix
# only used within other functions
distance <- function(xx.matrix, yy.value) {
	d.rep <- deg.dist(xx.matrix[2], xx.matrix[1], yy.value[2], yy.value[1])
	return(d.rep)
}


for (i in 0:1999) {
    jpeg(paste("jpg/",i,".jpg",sep=""),width=3000,height=3000);
        data<-read.csv(paste("csv/",i,".csv",sep=""));
         par(mar=c(0,0,0,0));
        plot(data$x,data$y,cex=0.01,xlim=c(-4000,4000),ylim=c(-4000,4000),xlab="",ylab="",bty="n", axes="F");
    dev.off();
    print(i);
}


#Uses devel version of AlphaSimR '0.3.0'
# > devtools::install_bitbucket("hickeyjohnteam/AlphaSimR", args = '--library=.')
library(AlphaSimR)

options(scipen=999)
args = commandArgs(trailingOnly=TRUE)
args = c("200", "1", "GBS")
nHD = as.numeric(args[1])
coverage = as.numeric(args[2])
parentStatus = args[3]

# print(args)
founderPop = runMacs(nInd = 100, nChr = 5, segSites = 200, inbred=FALSE, species="CATTLE")
# founderPop = runMacs(nInd = 100, nChr = 1, segSites = 1000, inbred=FALSE)

# ---- Set Simulation Parameters ----

SP = SimParam$new(founderPop)
SP$addSnpChip(nSnpPerChr=200)

gen0 = newPop(founderPop)

gen_parents = randCross(gen0, nCrosses = 10, nProgeny = 1)
ids = gen_parents@id

fathers = rep(1:5, each = 20)
mothers = rep(6:10, each = 20)

cross_plan = data.frame(fathers, mothers)

gen_offspring = makeCross(gen_parents, cross_plan)
output = c(gen_parents, gen_offspring)

write.table2 = function(x, file, ...) {
    write.table(x, paste0("example_map_file/", file), col.names=F, row.names=F,quote=F,...)
}

# PEDIGREE

ped_parents = data.frame(id = paste0("ind_", gen_parents@id), father = 0, mother = 0, stringsAsFactors = FALSE)
ped_offspring = data.frame(id = paste0("ind_", gen_offspring@id), father = paste0("ind_", gen_offspring@father), mother = paste0("ind_", gen_offspring@mother), stringsAsFactors = FALSE)
pedigree = rbind(ped_parents, ped_offspring)
write.table2(pedigree, "pedigree.txt")

# GENOTYPES

genotypes_parents = AlphaSimR::pullSnpGeno(gen_parents, 1)
genotypes_offspring = AlphaSimR::pullSnpGeno(gen_offspring, 1)
genotypes = AlphaSimR::pullSnpGeno(output, 1)
write.table2(cbind(pedigree[,1], genotypes), "genotypes.txt")

# HAPLOTYPES

haplotypes = AlphaSimR::pullSnpHaplo(output, 1)

# Swap the haplotype values to be consistent with other software
indexes = lapply(1:nrow(genotypes), function(index) {
    val0 = (index -1)*2 + 1
    val1 = (index -1)*2 + 2
    return(c(val1, val0))
})
indexes = do.call("c", indexes)
haplotypes = haplotypes[indexes,]

# write.table2(cbind(rep(pedigree[,1], each = 2), haplotypes), "truePhase.txt")
# write.table2(cbind(rep(pedigree[,1], each = 2), haplotypes)[1:4,], "truePhase-parents.txt")

gbsRandom = function(id, genotype, coverage) {
    nSnp = length(genotype)

    counts = rpois(nSnp, coverage)
    error = 0.001
    probs = (1-error) * as.numeric(genotype)/2.0 + error/2

    altReads = rbinom(nSnp, counts, prob = probs)
    values = matrix(c(id, counts-altReads, id, altReads), nrow = 2, byrow=TRUE)

    if(length(sequence) == 0) {
        sequence <<- values
    }
    else{
        sequence <<- rbind(sequence, values)
    }
}

sequence = c()

generate_sequence_data = function(pedigree, genotypes, coverage) {

    nInd = nrow(pedigree)
    for(i in 1:nInd){
        gbsRandom(pedigree[i, 1], genotypes[i,], coverage)
    }

}

if(parentStatus == "GBS") {
    generate_sequence_data(ped_parents, genotypes_parents, coverage)
}

if(parentStatus == "HD") {
    generate_sequence_data(ped_parents, genotypes_parents, 25)
}
if(parentStatus == "ND") {
    generate_sequence_data(ped_parents, genotypes_parents, 0)
}

generate_sequence_data(ped_offspring, genotypes_offspring, coverage)

write.table2(sequence, "sequence.txt")

options(scipen = 999);
map = data.frame(rep(1:5, each = 200), 1:200 * (1000000*100/200));
write.table2(map, "map.txt")


library(dplyr)
library(data.table)
library(glue)
library(stringr)
library(Matrix)
library(magrittr)
library(copykat)
library(IRdisplay)
library(parallel)

home_dir = '/home/tenggao'
devtools::load_all(glue('{home_dir}/numbat'))

cell_annot = fread(glue('{home_dir}/paper_data/cell_annotations/cell_annot_WASHU.tsv')) %>%
    mutate(sample_id = str_replace(sample_id, '-', '_')) %>%
    mutate(sample_id = ifelse(sample_id == '57075_Pre_transplant', '57075_Primary', sample_id)) %>%
    mutate(cell = paste0(sample_id, '_', barcode)) %>%
    split(.$sample_id)

con = readRDS(glue('{home_dir}/paper_data/conos_objects/conos_WASHU.rds'))

samples = c('47491_Primary', '27522_Relapse_2', '59114_Relapse_1', '37692_Primary', '58408_Primary')

count_mat = c()
df = c()

for (sample in samples) {
    count_mat[[sample]] = as.matrix(t(con$samples[[sample]]$misc$rawCounts))
    cells = intersect(cell_annot[[sample]]$cell, colnames(count_mat[[sample]]))
    cell_annot[[sample]] = cell_annot[[sample]] %>% filter(cell %in% cells)
    count_mat[[sample]] = count_mat[[sample]][,cells]
    df[[sample]] = fread(glue('{home_dir}/paper_data/processed/{sample}_allele_counts.tsv.gz'), sep = '\t') %>%
        filter(cell %in% cells)
}

ref = 'hca'
ref_types = c('NK', 'Macrophage', 'CD4+T', 'CD8+T', 'Myeloid', 'Monocyte', 'B', 'Plamsa', 'Dendritic')
ref_exp = ref_hca[,str_replace(ref_types, 'Plamsa', 'Plasma')]
ref_counts = ref_hca_counts[,rep(ref_types,2),drop=F]

colnames(ref_counts) = c(paste0(ref_types, '_', 1), paste0(ref_types, '_', 2))

print('Running copykat')
for (sample in samples) {

    genes_common = rownames(count_mat[[sample]]) %>% intersect(rownames(ref_counts))

    for (smooth in c(TRUE)) {

        win.size = 25
        KS.cut = 0.1
        out_dir = glue('{home_dir}/paper_data/copykat_out/{sample}_normal')

        dir.create(out_dir, recursive = TRUE, showWarnings = TRUE)
        setwd(out_dir)

        copykat.test <- copykat(
            rawmat = cbind(
                ref_counts[genes_common,],
                count_mat[[sample]][genes_common,]
            ),
            id.type="S",
            ngene.chr=0,
            win.size=win.size,
            KS.cut=KS.cut,
            sam.name=sample,
            distance="euclidean",
            norm.cell.names = colnames(ref_counts),
            n.cores=30
        )

    }

}

print('Running inferCNV')
for (sample in samples) {

    for (smooth in c(TRUE)) {

        if (smooth) {
            window_length = 101
            out_dir = glue('{home_dir}/inferCNV/{sample}/{ref}/smooth')
        } else {
            window_length = 1
            out_dir = glue('{home_dir}/inferCNV/{sample}/{ref}/no_smooth')
        }

        # preparing input
        dir.create(out_dir, showWarnings = FALSE, recursive = TRUE)
        annot_file = glue('{out_dir}/{sample}_annot.tsv')

        ref_groups = paste0(str_remove(colnames(ref_counts), '_1|_2'), '_ref')

        cell_annot[[sample]] %>%
        mutate(group = cell_type) %>%
        bind_rows(
            data.frame(
                cell = colnames(ref_counts),
                group = ref_groups
            )
        ) %>%
        select(cell, group) %>%
        fwrite(annot_file, sep = '\t', col.names = F)

        genes_common = rownames(count_mat[[sample]]) %>% intersect(rownames(ref_counts))

        # run
        infercnv_obj = infercnv::CreateInfercnvObject(
            raw_counts_matrix = cbind(
                    ref_counts[genes_common,,drop=F],
                    count_mat[[sample]][genes_common,]
            ),
            annotations_file = annot_file,
            delim="\t",
            gene_order_file=glue("{home_dir}/inferCNV/hg38_gene_order.txt"),
            ref_group_names = unique(ref_groups)
        )

        infercnv_obj = infercnv::run(
            infercnv_obj,
            num_threads = 30,
            cutoff=0.1,
            window_length = window_length,
            out_dir=out_dir,
            cluster_by_groups=F,
            denoise=TRUE,
            HMM=TRUE,
            HMM_report_by = "consensus",
            resume_mode=FALSE
        )
    }
}

print('Running Numbat')
for (sample in samples) {

    bulk_tumor = fread(glue('{home_dir}/paper_data/numbat_out/{sample}/bulk_tumor.tsv')) %>%
        mutate(CHROM = factor(CHROM)) %>%
        as.data.frame()
    segs_consensus = fread(glue('{home_dir}/paper_data/purple_out/{sample}/segs_consensus_dna.tsv')) %>%
        mutate(CHROM = factor(CHROM)) %>%
        as.data.frame()

    out_dir = glue('{home_dir}/paper_out/cnv_benchmark/{sample}')
    dir.create(out_dir, showWarnings = FALSE)

    exp_post = get_exp_post(
        segs_consensus,
        count_mat[[sample]],
        gtf_transcript,
        ref_exp,
        ncores = 64)$exp_post

    allele_post = get_allele_post(
        bulk_tumor,
        segs_consensus,
        df[[sample]]
    )

    joint_post = get_joint_post(
        exp_post,
        allele_post,
        segs_consensus)

    fwrite(exp_post, glue('{out_dir}/exp_post.tsv'), sep = '\t')
    fwrite(allele_post, glue('{out_dir}/allele_post.tsv'), sep = '\t')
    fwrite(joint_post, glue('{out_dir}/joint_post.tsv'), sep = '\t')
}


# A set of R functions for automated model fitting of random forest models to presence/absence data #
#
# Modified 12-2-09 to:  remove categorical covariates from consideration if they only contain one level
#                       ID factor variables based on "categorical" prefix and look for tifs in subdir
#                       Give progress reports
#                       write large output tif files in blocks to alleviate memory issues
#                       various bug fixes
#
# Adapted from existing pluggable BRT and GLM modules in April 2009 by Alan Swanson

# Libraries required to run this program #
#   PresenceAbsence - for ROC plots
#   XML - for XML i/o
#   rgdal - for geotiff i/o
#   RandomForest - duh
#   sp - used by rdgal library

options(error=NULL)

fit.rf.fct <- function(ma.name,tif.dir=NULL,output.dir=NULL,response.col="^response.binary",make.p.tif=T,make.binary.tif=T,
      debug.mode=F,responseCurveForm="pdf",xtest=NULL,ytest=NULL,n.trees=1000,mtry=NULL, samp.replace=FALSE, sampsize=NULL,nodesize=NULL,maxnodes=NULL,importance=FALSE,
      localImp=FALSE,nPerm=1,proximity=NULL,oob.prox=proximity,norm.votes=TRUE,do.trace=FALSE,keep.forest=NULL,keep.inbag=FALSE, make.r.curves=T,
      seed=NULL,script.name="rf.r",opt.methods=2,save.model=TRUE,UnitTest=FALSE,MESS=FALSE){
    # This function fits a boosted regression tree model to presence-absence data.
    # written by Alan Swanson, Jan-March 2009
    # uses code modified from that published in Elith et al 2008
    # # Maintained and edited by Marian Talbert September 2010-
    # Arguements.
    # ma.name: is the name of a .csv file with a model array.  full path must be included unless it is in the current
    #  R working directory #
    # tif.dir: is the directory containing geotiffs for each covariate.  only required if geotiffs output of the
    #   response surface is requested #    # cov.list.name: is the name of a text file with the names of covariates to be included in models (one per line).
    # output.dir: is the directory that output files will be stored in.  if not given, files will go to the current working directory.
    # response.col: column number of the model array containing a binary 0/1 response.  all other columns will be considered explanatory variables.
    # make.p.tif: T if a geotiff of the response surface is desired.
    # make.binary.tif: T if a geotiff of the response surface is desired.
    # simp.method: model simplification method.  valid methods include: "cross-validation", "rel-inf", and "none".  "cross-validation" uses the
    #   methods of Elith et al, 2008 for removing covariates that don't contribute to the model.  "rel-inf" simply removes covariates that contribute
    #  less than 1%.  cross-validation is very slow - it can add up to 10min to a run.
    # debug.mode: if T, output is directed to the console during the run.  also, a pdf is generated which contains response curve plots and perspective plots
    #    showing the effects of interactions deemed important.  if F, output is diverted to a text file and the console is kept clear
    #    except for final output of an xml file.  in either case, a set of standard output files are created in the output directory.
    # tc:  tree-complexity for brt fits.  if specified, this sets the tree-complexity of the final model fit.  A lower tree-complexity will be used for
    #    model selection steps.  if not set, this will be estimated loosely following the guidelines given by Elith et al, 2008.
    #

    # Value:
    # returns nothing but generates a number of output files in the directory
    # "output.dir" named above.  These output files consist of:
    #
    # brt_output.txt:  a text file with fairly detailed results of the final model.
    # brt_output.xml:  an xml-formatted text file with results from the final model.
    # brt_response_curves.xml:  an xml-formatted text file with response curves for
    #   each covariate in the final model.
    # brt_prob_map.tif:  a geotiff of the response surface
    # brt_bin_map.tif:  a geotiff of the binary response surface.  threhold is based on the roc curve at the point where sensitivity=specificity.
    # brt_log.txt:   a file containing text output diverted from the console when debug.mode=F
    # brt_auc_plot.jpg:  a jpg file of a ROC plot.
    # brt_response_curves.pdf:  an pdf file with response curves for
    #   each covariate in the final model and perspective plots showing the effect of interactions deemed significant.
    #   only produced when debug.mode=T
    #  seed=NULL                                 # sets a seed for the algorithm, any inegeger is acceptable
    #  opt.methods=2                             # sets the method used for threshold optimization used in the
    #                                            # the evaluation statistics module
    #  save.model=FALSE                          # whether the model will be used to later produce tifs
    #
    # when debug.mode is true, these filenames will include a number in them so that they will not overwrite preexisting files. eg brt_1_output.txt.
    #
    times <- as.data.frame(matrix(NA,nrow=8,ncol=1,dimnames=list(c("start","read data","model tuning","model fit",
            "model summary","response curves","tif output","done"),c("time"))))
    times[1,1] <- unclass(Sys.time())
    t0 <- unclass(Sys.time())
    #simp.method <- match.arg(simp.method)
    out <- list(
      input=list(ma.name=ma.name,
                 tif.dir=tif.dir,
                 output.dir=output.dir,
                 response.col=response.col,
                 save.model=save.model,
                 xtest=xtest,
                 ytest=ytest,
                 n.trees=n.trees,
                 mtry=mtry,
                 samp.replace=samp.replace,
                 sampsize=sampsize,
                 nodesize=nodesize,
                 maxnodes=maxnodes,
                 importance=importance,
                 localImp=localImp,
                 nPerm=nPerm,
                 proximity=proximity,
                 oob.prox=oob.prox,
                 norm.votes=norm.votes,
                 do.trace=do.trace,
                 keep.forest=keep.forest,
                 keep.inbag=keep.inbag,
                 make.p.tif=make.p.tif,
                 make.binary.tif=make.binary.tif,
                 model.type="random forest regression tree",
                 model.source.file=script.name,
                 model.fitting.subset=c(n.pres=50,n.abs=50),#subset used for response curves
                 run.time=paste(c(format(Sys.time(),"%Y-%m-%d"),format(Sys.time(),"%H:%M:%S")),collapse="T"),
                 sig.test="mean decrease in accuracy",
                 MESS=MESS),
      dat = list(missing.libs=NULL,
                 output.dir=list(dname=NULL,exist=F,readable=F,writable=F),
                 tif.dir=list(dname=NULL,exist=F,readable=F,writable=F),
                 tif.ind=NULL,
                 tif.names=NULL,
                 bname=NULL,
                 bad.factor.covs=NULL, # factorchange
                 ma=list( status=c(exists=F,readable=F),
                          dims=c(NA,NA),
                          n.pres=c(all=NA,complete=NA,subset=NA),
                          n.abs=c(all=NA,complete=NA,subset=NA),
                          ratio=NA,
                          resp.name=NULL,
                          factor.levels=NULL,
                          used.covs=NULL,
                          ma=NULL,
                          ma.subset=NULL,
                          train.xy=NULL,
                          test.xy=NULL,
                          site.weights=NULL),
                 ma.test=NULL),
      mods=list(parms=list(n.trees=n.trees,mtry=NULL),
                full.mod=NULL,
                simp.mod=NULL,
                final.mod=NULL,
                r.curves=NULL,
                tif.output=list(prob=NULL,bin=NULL),
                auc.output=NULL,
                interactions=NULL,
                summary=NULL),
      time=list(strt=unclass(Sys.time()),end=NULL),
      error.mssg=list(NULL),
      ec=0
      )

   if(!is.null(seed)) set.seed(seed)
    #if(simplify.brt==T) out$input$simp.method<-"cross-validation" else out$input$simp.method<-">1% rel. influence"
    # load libaries #
    out <- check.libs(list("randomForest","PresenceAbsence","rgdal","XML","sp","raster","tcltk2","foreign","ade4"),out)

    # exit program now if there are missing libraries #
    if(!is.null(out$error.mssg[[1]])){
          cat(saveXML(rf.to.xml(out),indent=T),'\n')
          return()
          }

    # check output dir #
    out$dat$output.dir <- check.dir(output.dir)
    if(out$dat$output.dir$writable==F) {out$ec<-out$ec+1
              out$error.mssg[[out$ec]] <- paste("ERROR: output directory",output.dir,"is not writable")
              out$dat$output.dir$dname <- getwd()

            }

    # generate a filename for output #
    if(debug.mode==T){
            outfile <- paste(bname<-paste(out$dat$output.dir$dname,"/rf_",n<-1,sep=""),"_output.txt",sep="")
            while(file.access(outfile)==0) outfile<-paste(bname<-paste(out$dat$output.dir$dname,"/rf_",n<-n+1,sep=""),"_output.txt",sep="")
            capture.output(cat("temp"),file=outfile) # reserve the new basename #
    } else bname <- paste(out$dat$output.dir$dname,"/rf",sep="")
    out$dat$bname <- bname

    # sink console output to log file #
    if(!debug.mode) {sink(logname <- paste(bname,"_log.txt",sep=""));on.exit(sink)} else logname<-NULL
    #options(warn=1)

    # check tif dir #
        # check tif dir #
    if(!is.null(tif.dir)){
      out$dat$tif.dir <- check.dir(tif.dir)
      if(out$dat$tif.dir$readable==F & (out$input$make.binary.tif | out$input$make.p.tif)) {
                out$ec<-out$ec+1
                out$error.mssg[[out$ec]] <- paste("ERROR: tif directory",tif.dir,"is not readable")
                if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
              cat(saveXML(brt.to.xml(out),indent=T),'\n')
              return()
              }
            }

    # find .tif files in tif dir #
    if(out$dat$tif.dir$readable)  out$dat$tif.names <- list.files(out$dat$tif.dir$dname,pattern=".tif",recursive=T)

    # check for model array #
    out$input$ma.name <- check.dir(out$input$ma.name)$dname
    if(UnitTest!=FALSE) options(warn=2)
    out <- read.ma(out)
    if(UnitTest==1) return(out)
    # exit program now if there are errors in the input data #
    if(!is.null(out$error.mssg[[1]])){
          if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
          cat(saveXML(rf.to.xml(out),indent=T),'\n')
          return()
          }
    t1 <- unclass(Sys.time())
    cat("\ndone processing data, t=",round(t1-t0,1),"sec\n")
    cat("\nbegin processing of model array:",out$input$ma.name,"\n")
    cat("\nfile basename set to:",out$dat$bname,"\n")
    if(debug.mode) flush.console()

    if(!debug.mode) {sink();cat("Progress:20%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("20%\n")}  ### print time

    ##############################################################################################################
    #  Begin model fitting #
    ##############################################################################################################

    # tune the mtry parameter - this controls the number of covariates randomly subset for each split #
    cat("\ntuning mtry parameter\n")

  x=out$dat$ma$ma[,-1]
  y=factor(out$dat$ma$ma[,1])
      if(is.null(mtry)){
     mtry <- try(tuneRF(x=out$dat$ma$ma[,-1],y=factor(out$dat$ma$ma[,1]),mtryStart=3,importance=TRUE,ntreeTry=100,
        replace=FALSE, doBest=F, plot=F),silent=T)
          mtry <- try(mtry[mtry[,2]==min(mtry[,2]),1][1])
          t2 <- unclass(Sys.time())
          if(!debug.mode) {sink();cat("Progress:30%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("30%\n")}

          cat("\ndone tuning random forest parameters, t=",round(t2-t1,1),"sec\n")
        }

    cat("\nnow fitting full random forest model using mtry=",mtry,"\n")
    if(debug.mode) flush.console()

     rf.full <- randomForest(x=out$dat$ma$ma[,-1],y=factor(out$dat$ma$ma[,1]),xtest=xtest,ytest=ytest,importance=TRUE, ntree=n.trees,
        mtry=mtry,replace=samp.replace,sampsize=ifelse(is.null(sampsize),(ifelse(samp.replace,nrow(x),ceiling(.632*nrow(x)))),sampsize),
        nodesize=ifelse(is.null(nodesize),(if (!is.null(y) && !is.factor(y)) 5 else 1),nodesize),maxnodes=maxnodes,
        localImp=localImp, nPerm=nPerm, keep.forest=ifelse(is.null(keep.forest),!is.null(y) && is.null(xtest),keep.forest),
        corr.bias=corr.bias, keep.inbag=keep.inbag)

              out$mods$parms$mtry<-mtry
              out$mods$final.mod <- rf.full

    t3 <- unclass(Sys.time())
    if(!debug.mode) {sink();cat("Progress:40%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("40%\n")}  ### print time

    cat("\nfinished fitting full model, t=",round(t2-t1,1),"sec\nnow computing output stats...\n")
    if(debug.mode) flush.console()

    ##############################################################################################################
    #  Begin model output #
    ##############################################################################################################

    # ROC plot #

      model.summary <- try(importance(out$mods$final.mod),silent=T)
    if(class(model.summary)=="try-error"){
        if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
        out$ec<-out$ec+1
        out$error.mssg[[out$ec]] <- paste("ERROR: can't generate summary of final model:",model.summary)
        cat(saveXML(rf.to.xml(out),indent=T),'\n')
        return()
    } else {
        model.summary<-model.summary[order(model.summary[,3],decreasing=T),]
        out$mods$summary <- model.summary
        }

   txt0 <- paste("Random Forest Modeling Results\n",out$input$run.time,"\n\n",
          "Data:\n\t",ma.name,
          "\n\tn(pres)=",out$dat$ma$n.pres[2],
          "\n\tn(abs)=",out$dat$ma$n.abs[2],
          "\n\tn covariates considered=",length(out$dat$ma$used.covs),
        "\n\n","Settings:",
        "\n\tn covariates considered at each split =",out$mods$parms$mtry,
        "\n\tn trees=",out$mods$parms$n.tree,
        "\n\ttotal time for model fitting=",round((unclass(Sys.time())-t0)/60,2),"min\n",sep="")
    txt1 <- "\nRelative performance of predictors in final model:\n\n"
    txt2 <- "\nDefault summary of random forest fit:\n"
    capture.output(cat(txt0),cat(txt1),print(round(model.summary,4)),cat(txt2),print(out$mods$final.mod),file=paste(bname,"_output.txt",sep=""))
    cat(txt0);cat(txt1);print(round(model.summary,4));cat(txt2);print(out$mods$final.mod);cat("\n\n")
    if(!is.null(out$dat$bad.factor.cols)){
        capture.output(cat("\nWarning: the following categorical response variables were removed from consideration\n",
            "because they had only one level:",paste(out$dat$bad.factor.cols,collapse=","),"\n"),
            file=paste(bname,"_output.txt",sep=""),append=T)
        cat("\nWarning: the following categorical response variables were removed from consideration\n",
            "because they had only one level:",paste(out$dat$bad.factor.cols,collapse=","),"\n\n")
        }

    auc.output <- make.auc.plot.jpg(out$dat$ma$ma,pred=tweak.p(as.vector(predict(out$mods$final.mod,type="prob")[,2])),
            plotname=paste(bname,"_auc_plot.jpg",sep=""),modelname="RF",opt.methods=opt.methods,weight=rep(1,times=dim(out$dat$ma$ma)[1]),out=out)

    if(class(auc.output)=="try-error"){
          out$ec<-out$ec+1
          out$error.mssg[[out$ec]] <- paste("Error making ROC plot:",auc.output)
    } else { out$mods$auc.output<-auc.output}

    #assign("out",out,envir=.GlobalEnv)

    # Text summary #

    if(!debug.mode) {sink();cat("Progress:70%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("60%\n")}  ### print time

    if(debug.mode) flush.console()

    # Response curves #
    t4 <- unclass(Sys.time())
    if(make.r.curves){

            r.curves <- list(names=row.names(out$mods$summary),preds=list(),resp=list())
            inc <- 10/length(r.curves$names)
            assign("r.curves",r.curves,envir=.GlobalEnv)

        if(is.null(responseCurveForm)){
          responseCurveForm<-0}

    if(debug.mode | responseCurveForm=="pdf"){
                nvar <- nrow(out$mods$summary)
                pcol <- min(ceiling(sqrt(nvar)),4)
                prow <- min(ceiling(nvar/pcol),3)
                pdf(paste(bname,"_response_curves.pdf",sep=""),width=11,height=8.5,onefile=T)
                par(oma=c(2,2,4,2),mfrow=c(prow,pcol))
                }
            for(i in 1:length(r.curves$names)){
                    assign("i",i,envir=.GlobalEnv)

                            x<-try(partialPlot(out$mods$final.mod,out$dat$ma$ma.subset,r.curves$names[i],n.pt=50,plot=T,main="",
                                    xlab=r.curves$names[i]))
                    if(class(x)=="try-error"){
                        if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))} else graphics.off()
                        out$ec<-out$ec+1
                        out$error.mssg[[out$ec]] <- paste("ERROR: can't generate response curves:",x)
                        cat(saveXML(rf.to.xml(out),indent=T),'\n')
                        return()
                    } else {
                        r.curves$preds[[i]] <- x$x
                        r.curves$resp[[i]] <- x$y
                        }
                     if(!debug.mode) {sink();cat(paste("Progress:",round(70+i*inc,1),"%\n",sep=""));flush.console();sink(logname,append=T)} else {cat("\n");cat(paste(round(70+i*inc,1),"%\n",sep=""))}  ### print time
                    }
            if(debug.mode) graphics.off()
            out$mods$r.curves <- r.curves
        }

    t5 <- unclass(Sys.time())
    #if(!debug.mode) {sink();cat("80%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("80%\n")}  ### print time
    cat("\nfinished with response curves, t=",round(t5-t4,2),"sec\n")
    if(debug.mode) flush.console()

    # Make .tif of predictions #
    out$mods$final.mod$contributions$var<-as.character(row.names(out$mods$summary))

    assign("out",out,envir=.GlobalEnv)
     save.image(paste(output.dir,"modelWorkspace",sep="\\"))
    if(out$input$make.p.tif==T | out$input$make.binary.tif==T){
        cat("\nproducing prediction maps...","\n","\n");flush.console()
        mssg <- try(proc.tiff(model=out$mods$final.mod,vnames=as.character(row.names(out$mods$summary)),
            tif.dir=out$dat$tif.dir$dname,filenames=out$dat$tif.ind,pred.fct=rf.predict,factor.levels=out$dat$ma$factor.levels,make.binary.tif=make.binary.tif,
            thresh=out$mods$auc.output$thresh,make.p.tif=make.p.tif,outfile.p=paste(out$dat$bname,"_prob_map.tif",sep=""),
            outfile.bin=paste(out$dat$bname,"_bin_map.tif",sep=""),tsize=50.0,NAval=-3000,fnames=out$dat$tif.names,logname=logname,out=out),silent=T)     #"brt.prob.map.tif"

        if(class(mssg)=="try-error" | mssg!=0){
          if(!debug.mode) {sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))}
          out$ec<-out$ec+1
          out$error.mssg[[out$ec]] <- paste("Error producing prediction maps:",mssg)
          cat(saveXML(rf.to.xml(out),indent=T),'\n')
          return()
        }  else {
            if(make.p.tif) out$mods$tif.output$prob <- paste(out$dat$bname,"_prob_map.tif",sep="")
            if(make.binary.tif) out$mods$tif.output$bin <- paste(out$dat$bname,"_bin_map.tif",sep="")
            t5 <- unclass(Sys.time())
            cat("\nfinished with prediction maps, t=",round(t5-t4,2),"sec\n");flush.console()
          }
        }
    if(!debug.mode) {sink();cat("Progress:90%\n");flush.console();sink(logname,append=T)} else {cat("\n");cat("90%\n")}  ### print time

  # Evaluation Statistics on Test Data#

    if(!is.null(out$dat$ma$ma.test)) Eval.Stat<-EvaluationStats(out,thresh=auc.output$thresh,train=out$dat$ma$ma,
        train.pred=tweak.p(as.vector(predict(out$mods$final.mod,type="prob")[,2])),opt.methods)

    # Write summaries to xml #
    assign("out",out,envir=.GlobalEnv)
    doc <- rf.to.xml(out)

    cat(paste("\ntotal time=",round((unclass(Sys.time())-t0)/60,2),"min\n\n\n",sep=""))
    if(!debug.mode) {
        sink();on.exit();unlink(paste(bname,"_log.txt",sep=""))
        cat("Progress:100%\n");flush.console()
        cat(saveXML(doc,indent=T),'\n')
        }
    capture.output(cat(saveXML(doc,indent=T)),file=paste(out$dat$bname,"_output.xml",sep=""))
    assign("fit",out$mods$final.mod,envir=.GlobalEnv)
    invisible(out)
}

rf.predict <- function(model,x) {
    # retrieve key items from the global environment #
    # make predictions from complete data only #
    y <- rep(NA,nrow(x))
    y[complete.cases(x)] <- as.vector(predict(model,newdata=x[complete.cases(x),],type="prob")[,2])

    # make predictions from full data #

    # encode missing values as -1.
    y[is.na(y)]<- NaN

    # return predictions.
    return(y)
    }

logit <- function(x) 1/(1+exp(-x))

file_path_as_absolute <- function (x){
    if (!file.exists(epath <- path.expand(x)))
        stop(gettextf("file '%s' does not exist", x), domain = NA)
    cwd <- getwd()
    on.exit(setwd(cwd))
    if (file_test("-d", epath)) {
        setwd(epath)
        getwd()
    }
    else {
        setwd(dirname(epath))
        file.path(getwd(), basename(epath))
    }
}
#file_path_as_absolute(".")

rf.to.xml <- function(out){
    require(XML)
    schema.http="http://www.w3.org/2001/XMLSchema-instance"
    schema.fname="file:/Users/isfs2/Desktop/Source/2008-04-09/src/gov/nasa/gsfc/quickmap/ModelBuilder/modelRun_output_v2.xsd"
    xml.out <- newXMLDoc()
    mr <- newXMLNode("modelRunOutput",doc=xml.out,namespaceDefinitions=c(xsi=schema.http,noNamespaceSchemaLocation=schema.fname))#,parent=xml.out
    sm <- newXMLNode("singleModel",parent=mr)
    bg <- newXMLNode("background",parent=sm)
        newXMLNode("mdsName",out$input$ma.name,parent=bg)
        newXMLNode("runDate",out$input$run.time,parent=bg)
        lc <- newXMLNode("layersConsidered",parent=bg)#, parent = xml.out)
        kids <- lapply(paste(out$dat$tif.dir$dname,"/",out$dat$tif.names,sep=""),function(x) newXMLNode("layer", x))
        addChildren(lc, kids)
    mo <- newXMLNode("modelOutput",parent=sm)
        newXMLNode("modelType",out$input$model.type,parent=mo)
        newXMLNode("modelSourceFile",out$input$model.source.file,parent=mo)
        newXMLNode("devianceExplained",out$mods$auc.output$pct_dev_exp,parent=mo,attrs=list(type="percentage"))
        newXMLNode("nativeOutput",paste(out$dat$bname,"_output.txt",sep=""),parent=mo)
        newXMLNode("binaryOutputFile",out$mods$tif.output[[2]],parent=mo)
        newXMLNode("probOutputFile",out$mods$tif.output[[1]],parent=mo)
        newXMLNode("auc",out$mods$auc.output$auc,parent=mo)
        newXMLNode("rocGraphic",out$mods$auc.output$plotname,parent=mo)
        newXMLNode("rocThresh",out$mods$auc.output$thresh,parent=mo)
        newXMLNode("modelDeviance",out$mods$auc.output$dev_fit,parent=mo)
        newXMLNode("nullDeviance",out$mods$auc.output$null_dev,parent=mo)
        if(is.null(out$mods$r.curves)) rc.name <- NULL else rc.name <- paste(out$dat$bname,"_response_curves.xml",sep="")
        newXMLNode("responsePlotsFile",rc.name,parent=mo)
        newXMLNode("significanceDescription",out$input$sig.test,parent=mo)
        mfp <- newXMLNode("modelFitParmas",parent=mo)
            newXMLNode("nTrees",out$mods$parms$n.tree,parent=mfp)
            newXMLNode("mTry",out$mods$parms$mtry,parent=mfp)

        sv <- newXMLNode("significantVariables",parent=mo)
        if(!is.null(out$mods$summary)) {
            t.table <- data.frame(significanceMeasurement=out$mods$summary[,3],row.names=row.names(out$mods$summary))
            for(i in 1:nrow(t.table)){
                x <- newXMLNode("sigVar",parent=sv)
                newXMLNode(name="name", row.names(t.table)[i],parent=x)
                kids <- lapply(1:ncol(t.table),function(j) newXMLNode(name=names(t.table)[j], t.table[i,j]))
                addChildren(x, kids)
                }
            }
    if(!is.null(out$mods$r.curves)){
        r.curves <-  out$mods$r.curves
        rc.out <- newXMLDoc()
        root <- newXMLNode("responseCurves",doc=rc.out,namespaceDefinitions=c(xsi=schema.http,noNamespaceSchemaLocation=schema.fname))
        for(i in 1:length(r.curves$names)){
            vartype <- ifelse(class(r.curves$preds[[i]])=="character","factor","continuous")
            x <- newXMLNode("responseCurve",attrs=list(covariate=r.curves$names[i],type=vartype),parent=root)
            kids <- lapply(1:length(r.curves$preds[[i]]),function(j){
                newXMLNode(name="responsePt",parent=x,.children=list(
                    newXMLNode(name="explanatory",r.curves$preds[[i]][j]),
                    newXMLNode(name="response",r.curves$resp[[i]][j])))})
            addChildren(x, kids)
            }
        saveXML(rc.out,rc.name,indent=T)
        }
    if(!is.null(out$error.mssg[[1]])) {
        kids <- lapply(out$error.mssg,function(j) newXMLNode(name="error",j))
        addChildren(mo,kids)
        }
    return(xml.out)
    }

get.cov.names <- function(model){
    return(attr(terms(formula(model)),"term.labels"))
    }

check.dir <- function(dname){
    if(is.null(dname)) dname <- getwd()
    dname <- gsub("[\\]","/",dname)
    end.char <- substr(dname,nchar(dname),nchar(dname))
    if(end.char == "/") dname <- substr(dname,1,nchar(dname)-1)
    exist <- suppressWarnings(as.numeric(file.access(dname,mode=0))==0) # -1 if bad, 0 if ok #
    if(exist) dname <- file_path_as_absolute(dname)
    readable <- suppressWarnings(as.numeric(file.access(dname,mode=4))==0) # -1 if bad, 0 if ok #
    writable <- suppressWarnings(as.numeric(file.access(dname,mode=2))==0) # -1 if bad, 0 if ok #
    return(list(dname=dname,exist=exist,readable=readable,writable=writable))
    }

get.image.info <- function(image.names){
    # this function creates a data.frame with summary image info for a set of images #
    require(rgdal)
    n.images <- length(image.names)

    full.names <- image.names
    out <- data.frame(image=full.names,available=rep(F,n.images),size=rep(NA,n.images),
        type=factor(rep("unk",n.images),levels=c("asc","envi","tif","unk")))
    out$type[grep(".tif",image.names)]<-"tif"
    out$type[grep(".asc",image.names)]<-"asc"
    for(i in 1:n.images){
        if(out$type[i]=="tif"){
            x <-try(GDAL.open(full.names[1],read.only=T),silent=T)
            suppressMessages(try(GDAL.close(x),silent=T))
            if(class(x)!="try-error") out$available[i]<-T
            x<-try(file.info(full.names[i]))
        } else {
            x<-try(file.info(full.names[i]))
            if(!is.na(x$size)) out$available[i]<-T
        }
        if(out$available[i]==T){
            out$size[i]<-x$size
            if(out$type[i]=="unk"){
                # if extension not known, look for envi .hdr file in same directory #
                if(file.access(paste(file_path_sans_ext(full.names[i]),".hdr",sep=""))==0)
                    out$type[i]<-"envi"
                }
        }
    }
    return(out)
}

tweak.p <- function(p){
	p[p==1]<-max(p[p<1])
	p[p==0]<-min(p[p>0])
	return(p)
	}

#

 # Interpret command line argurments #
# Make Function Call #
#Set defaults for optional commands
make.p.tif=T
make.binary.tif=T
responseCurveForm="pdf"
xtest=NULL
ytest=NULL
n.trees=1000
mtry=NULL
samp.replace=FALSE
sampsize=NULL
nodesize=NULL
maxnodes=NULL
importance=FALSE
localImp=FALSE
nPerm=1
proximity=NULL
oob.prox=proximity
norm.votes=TRUE
do.trace=FALSE
keep.forest=NULL
keep.inbag=FALSE
make.r.curves=T
seed=NULL
opt.methods=2
save.model=TRUE
seed=NULL
MESS=FALSE

Args <- commandArgs(trailingOnly=FALSE)

    for (i in 1:length(Args)){
     if(Args[i]=="-f") ScriptPath<-Args[i+1]
     }

    for (arg in Args) {
    	argSplit <- strsplit(arg, "=")
    	argSplit[[1]][1]
    	argSplit[[1]][2]
    	if(argSplit[[1]][1]=="c") csv <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="o") output <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="rc") responseCol <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="mpt") make.p.tif <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="mbt")  make.binary.tif <- argSplit[[1]][2]
      if(argSplit[[1]][1]=="xtst")  xtest <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="ytst")  ytest <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="ntree")  n.trees <- argSplit[[1]][2]
      if(argSplit[[1]][1]=="mtry")  mtry <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="sampR")  samp.replace <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="sampS")  sampsize <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="nodeS")  nodesize <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="maxN")  maxnodes <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="impt")  importance <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="locImp")  localImp <- argSplit[[1]][2]
 		  if(argSplit[[1]][1]=="nPerm")  nPerm <- argSplit[[1]][2]
 		  if(argSplit[[1]][1]=="prox")  proximity <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="oopp")  oop.prox <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="NVot")  norm.votes <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="Trce")  do.trace <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="kf")  keep.forest <- argSplit[[1]][2]
 			if(argSplit[[1]][1]=="Kbag")  keep.inbag <- argSplit[[1]][2]
 		  if(argSplit[[1]][1]=="curves")  make.r.curves <- argSplit[[1]][2]
 		  if(argSplit[[1]][1]=="om")  opt.methods <- argSplit[[1]][2]
      if(argSplit[[1]][1]=="savm")  save.model <- argSplit[[1]][2]
      if(argSplit[[1]][1]=="mes")  MESS <- argSplit[[1]][2]

    }
	print(csv)
	print(output)
	print(responseCol)

make.p.tif<-as.logical(make.p.tif)
make.binary.tif<-as.logical(make.binary.tif)
samp.replace<-as.logical(samp.replace)
importance<-as.logical(importance)
localImp<-as.logical(localImp)
norm.votes<-as.logical(norm.votes)
do.trace<-as.logical(do.trace)
keep.inbag<-as.logical(keep.inbag)
make.r.curves<-as.logical(make.r.curves)
save.model<-make.p.tif | make.binary.tif
n.trees<-as.numeric(n.trees)
opt.methods<-as.numeric(opt.methods)
ScriptPath<-dirname(ScriptPath)
MESS<-as.logical(MESS)

source(paste(ScriptPath,"LoadRequiredCode.r",sep="\\"))

fit.rf.fct(ma.name=csv,tif.dir=NULL,output.dir=output,response.col=responseCol,make.p.tif=make.p.tif,make.binary.tif=make.binary.tif,
      debug.mode=F,responseCurveForm="pdf",xtest=xtest,ytest=ytest,n.trees=n.trees,mtry=mtry,samp.replace=samp.replace, sampsize=sampsize,
      nodesize=nodesize,maxnodes=maxnodes,importance=importance,
      localImp=localImp,nPerm=nPerm,proximity=proximity,oob.prox=oob.prox,norm.votes=norm.votes,do.trace=do.trace,keep.forest=keep.forest,
      keep.inbag=keep.inbag,make.r.curves=make.r.curves,
      seed=seed,script.name="rf.r",opt.methods=opt.methods,save.model=save.model,MESS=MESS)