####### Final plots

source("https://raw.githubusercontent.com/Cdevenish/R-Material/master/Functions/w.xls.r")

## Data from Thompson_method scripts
load("sightings.rdata")
years

dataX <- data.frame(years = years, PXt, Basis = "All records")
head(dataX)

load("specimen.rdata")

dataX <- rbind(dataX,data.frame(years = years, PXt, Basis = "Specimens"))
colnames(dataX) <- c("years", "sd_lwr", "PXt", "sd_upr", "PXt_min", "PXt_max", "Basis")

head(dataX)

w.xls(dataX)

library(ggplot2)

ggplot(dataX, aes(x = years, y = PXt, col= Basis))+
  geom_ribbon(aes(ymin=sd_lwr, ymax = sd_upr, fill = Basis), linetype = 0, alpha = 0.4)+
  geom_ribbon(aes(ymin=PXt_min, ymax = PXt_max, fill = Basis), linetype = 0, alpha = 0.2)+
  scale_color_manual(values = c("black", "darkred"))+
  scale_fill_manual(aesthetics = "fill", values = c("grey10", "grey50"))+
  geom_line(aes(linetype= Basis), size = 1)+
  ylim(c(0,1))+
  xlab("Years")+
  scale_x_continuous(breaks = seq(1810, 2030,10))+
  ylab("Probability that taxon is extant")+
  theme_light()+
  theme(legend.position = c(0.1,0.15))
ggsave("risk_2_on_1.png", width = 200, height = 150, units = "mm")


require(data.table)
require(PerformanceAnalytics)
require(scales)
require(Quandl)

# helper functions
pastePerc <- function(x) {return(paste0(comma(x),"%"))}
rowGsub <- function(x) {x <- gsub("NA%", "NA", x);x}

calendarReturnTable <- function(rets, digits = 3, percent = FALSE) {

  # get maximum drawdown using daily returns
  dds <- apply.yearly(rets, maxDrawdown)

  # get monthly returns
  rets <- apply.monthly(rets, Return.cumulative)

  # convert to data frame with year, month, and monthly return value
  dfRets <- cbind(year(index(rets)), month(index(rets)), coredata(rets))

  # convert to data table and reshape into year x month table
  dfRets <- data.frame(dfRets)
  colnames(dfRets) <- c("Year", "Month", "Value")
  monthNames <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  for(i in 1:length(monthNames)) {
    dfRets$Month[dfRets$Month==i] <- monthNames[i]
  }
  dfRets <- data.table(dfRets)
  dfRets <- data.table::dcast(dfRets, Year~Month)

  # create row names and rearrange table in month order
  dfRets <- data.frame(dfRets)
  yearNames <- dfRets$Year
  rownames(dfRets) <- yearNames; dfRets$Year <- NULL
  dfRets <- dfRets[,monthNames]

  # append yearly returns and drawdowns
  yearlyRets <- apply.yearly(rets, Return.cumulative)
  dfRets$Annual <- yearlyRets
  dfRets$DD <- dds

  # convert to percentage
  if(percent) {
    dfRets <- dfRets * 100
  }

  # round for formatting
  dfRets <- apply(dfRets, 2, round, digits)

  # paste the percentage sign
  if(percent) {
    dfRets <- apply(dfRets, 2, pastePerc)
    dfRets <- apply(dfRets, 2, rowGsub)
    dfRets <- data.frame(dfRets)
    rownames(dfRets) <- yearNames
  }
  return(dfRets)
}


backtest <- function(holding, weight='equal', bench='SPY', xtsrange=5, period='months',
                     twri, twrib, twri.ef,
                     plottype=c('twri', 'ab', 'twrc', 'rr', 'portfolio'),
                     standard.layout=TRUE, main=NULL) {

    ## simple input:
    ##     holding = vector of holdings        (e.g., c('SPY', 'IWM', 'EFA', 'AGG', 'SHV'))
    ##               if not provided, assume holding = names(twri)
    ##     weight  = vector of holding weights (e.g., c( 0.4,   0.2,   0.1,   0.3,   0.1))
    ##             = 'equal' sets holding weights to 1/(# of holdings)
    ##     bench   = benchmark                 (e.g., default is 'SPY')
    ##               if not provided, assume bench = names(twrib)[1] if provided
    ##     period  = 'days' (default), 'weeks', 'months', 'years'
    ##     xtsrange = requested date range to evaluate twri over (e.g., '2020-12-31/2021')
    ##              = 5 (default) for last 5 years
    ##              = # for last # years
    ##              = 0 for YTD

    ## alternate input options:
    ##     twri     = xts object with twri for holdings
    ##                if holding is also provided, will pull twri for holdings from twri
    ##                if not provided, will be obtained
    ##     twrib    = xts object with twri for benchmark
    ##                if bench is also provided, will pull twri for bench from twrib
    ##                if not provided, will be obtained
    ##     twri.ef  = xts object with twri for effective frontier symbols
    ##                if not provided, will be obtained
    ##     main     = title for some of the plots (default=NULL)
    ##     plottype = default plots everything
    ##              = twri  = incremental TWR
    ##              = twrc  = cumulative TWR
    ##              = ab    = alpha vs. beta
    ##              = rr    = risk/return (TWR vs. standard deviation)
    ##                        actual TWR if < 1 yr; cumulative TWR if > 1 yr
    ##              = portfolio = portfolio plots
    ##     standard.layout = TRUE (default) uses 2x2 plot space for i, c, ab, and rr
    ##                     = FALSE uses existing plot setup

    ## if not input, get twri for holdings, benchmark, and efficient frontier
    if (missing(holding)) holding <- names(twri)
    if (missing(twri))    twri  <- equity.twri(holding, refresh=TRUE, file=NA, period=period)
    if (missing(twrib))   twrib <- equity.twri(bench  , refresh=TRUE, file=NA, period=period)
    if (missing(twri.ef)) twri.ef <- ef(period=period, addline=FALSE)$twri

    ## check twri dates within xtsrange and convert everything to that if they do not match
    if (xtsrange == 0) {
        ## set to YTD
        start <- format(Sys.Date(), "%Y")
        end   <- Sys.Date()
        xtsrange <- paste(start, '/', end, sep='')
    } else if (is.number(xtsrange)) {
        ## set to requested number of years
        start <- Sys.Date() - 365.25 * xtsrange
        end   <- Sys.Date()
        xtsrange <- paste(start, '/', end, sep='')
    }
    twri <- twri[xtsrange]
    dates <- zoo::index(twri)
    twrib   <- twri.adjust(twrib  , d2m=FALSE, dates.new=dates, twri.input=TRUE)
    twri.ef <- twri.adjust(twri.ef, d2m=FALSE, dates.new=dates, twri.input=TRUE)

    ## check for NA in twri, twrib, and twri.ef
    twri_all <- cbind(twri, twrib, twri.ef)
    twri_all <- na.omit(twri_all)
    dates.all <- zoo::index(twri_all)

    ## if needed, trim all XTS objects to match range of twri_all
    if (dates[1] != dates.all[1]) {
        cat('\nWarning: Some holding likely has NA in first date.\n')
        print(twri[1,])
        xtsrange <- paste(min(zoo::index(twri_all)), '/', max(zoo::index(twri_all)), sep='')
        twri    <-    twri[xtsrange]
        dates   <- zoo::index(twri)
        twrib   <-   twrib[xtsrange]
        twri.ef <- twri.ef[xtsrange]
    }

    ## make sure dates are consistent between twri and all combined
    mismatch <- grep('FALSE', dates == dates.all)
    if (length(mismatch) > 1) {
        cat('\nFatal error: Select new date range. Some holdings have twri=NA.\n')
        return(twri_all)
    }

    ## calculate portfolio performance
    if (weight == 'equal') {
        nhold <- length(holding)
        weight <- rep(1/nhold, nhold)
    }
    port <- portfolio.calc(twri[xtsrange], weight=weight, twrib=twrib[xtsrange])

    ## plot portfolio performance
    if (isTRUE(standard.layout)) plotspace(2,2)
    duration <- as.numeric(diff.Date(range(dates)))
    if (!is.null(main)) main <- paste(main, '; ', sep='')
    if (grepl('twri', plottype) | grepl('ab', plottype) |
        grepl('twrc', plottype) | grepl('rr', plottype)) {
        ## at least one plot for individual holdings is requestedf
        if (duration > 365.25) {
            ## print annualized risk/return plot
            ## if requested plottype includes rr (risk/return), replace with rra (annualized risk/return)
            plottype <- str_replace(plottype, 'rr', 'rra')
            out <- portfolio.plot(twri=port$twri, twrc=port$twrc, perf=port$perf,
                                  twri.ef=twri.ef[xtsrange],
                                  plottype=plottype, pch.hold = 16,
                                  main=paste(main, 'Benchmark = ', names(twrib)[1], sep=''))
        } else {
            ## print non-annualized risk/return plot
            out <- portfolio.plot(twri=port$twri, twrc=port$twrc, perf=port$perf,
                                  twri.ef=twri.ef[xtsrange],
                                  plottype=plottype, pch.hold = 16,
                                  main=paste(main, 'Benchmark = ', names(twrib)[1], sep=''))
        }
    } else {
        ## no individual holding plots are requested
        out <- NA
    }

    if (grepl('portfolio', plottype)) {
        ## evaluate portfolio as if it were a mutural fund
        out.eq <- equity.eval(twri = port$twri$portfolio, twrib = twrib, period=period)
        ##                    bench='schwab_80_20', twrib = out$efdata.Schwab$eftwri$schwab_80_20)
    }

    if (is.na(out)) {
        return(list(port=port, efdata.Schwab=NA, efdata.simple=NA))
    } else {
        return(list(port=port, efdata.Schwab=out$efdata.Schwab, efdata.simple=out$efdata.simple, xtsrange=xtsrange))
    }
}
## xtsrange1 <- '2020-12-31/2021-12'
## xtsrange3 <- '2018-12-31/2021-12'
## xtsrange5 <- '2016-12-31/2021-12'

## ## holding <- c('SPY', 'IWM', 'EFA', 'AGG', 'SHV')
## holding <- c('SWPPX', 'PONAX')
## weight  <- c( 0.6,   0.4)
## bench   <- 'SPY'
## period  <- 'days'
## xtsrange <- xtsrange5
## out <- backtest(holding=holding, weight=weight, bench=bench,
##                 period=period, xtsrange=xtsrange)

## ## following not working right for some reason
## twri  <- equity.twri(holding, refresh=TRUE, file=NA, period=period)
## twrib <- equity.twri(bench  , refresh=TRUE, file=NA, period=period)
## twri.ef <- ef(period=period, addline=FALSE)$twri
## out <- backtest(twri=twri, weight=weight, twrib=twrib, twri.ef=twri.ef, xtsrange)


#' Create New Toolbox
#'
#' Create an R6 class object called "RCTtoolbox".
#'
#' @param baseline two-sided formula with
#' one or more outcome variables on LHS and
#' one treatment variable on RHS.
#' @param covariate (list of) one-sided formulas with
#' covariates used in regression and balance test on RHS.
#' @param data data.frame/tibble object you want to use.
#' @param treat_levels character vector. Levels of experimental arms.
#' The first element is control arm.
#' @param treat_labels character vector.
#' Labels of experimental arms corresponding to \code{treat_levels}.
#' Default is to use \code{treat_levels} as labels.
#'
#' @return R6 object with "RCTtoolbox" class.
#' The returned object has following fields and methods
#' \describe{
#'   \item{\code{data}}{Field.
#'     Store data.frame/tibble passed to \code{data} argument.
#'     You can access via \code{$data}}
#'   \item{\code{print()}}{Method.
#'     Print information about the returned object.
#'     Run \code{$print()}}
#'   \item{\code{ttest()}}{Method.
#'     Implement two-sided t-test or permutation test.
#'     Run \code{$ttest()}.
#'     See \link{ttest} for help.}
#'   \item{\code{power()}}{Method.
#'     Implement power analysis.
#'     Run \code{$power()}.
#'     See \link{power} for help.}
#'   \item{\code{balance()}}{Method.
#'     Implement balance test.
#'     Run \code{$balance()}.
#'     See \link{balance} for help.}
#'   \item{\code{lm()}}{Method.
#'     Estimate linear model.
#'     Run \code{$lm()}.
#'     See \link{lm} for help.}
#' }
#'
#' @section Private fields:
#' The created R6 object has also private fields.
#' You cannot access from the outside.
#' However, methods of RCTtoolbox use private fields.
#' A list of private fields is as follows:
#' \describe{
#'   \item{formula.yd}{List of two-sided formula
#'     \code{outcome ~ treatment}.
#'     If you pass \code{y1 + y2 ~ d} to
#'     the argument \code{baseline},
#'     \code{formula.yd} refers to
#'     \code{list(y1 ~ d, y2 ~ d)}.}
#'   \item{formula.x}{Lists of one-sided formula
#'     with covariates on RHS
#'     which is passed to the argument \code{covariate}.}
#'   \item{yvec}{Character vector of outcome variables.}
#'   \item{xvec}{Character vector of covariates.}
#'   \item{dvec}{Character of treatment.}
#'   \item{dvec.levels}{Character vector
#'     passed to the argument \code{treat_levels}.}
#'   \item{dvec.labels}{Character vector
#'     passed to the argument \code{treat_labels}.}
#' }
#'
#' @importFrom rlang f_lhs
#' @importFrom rlang f_rhs
#' @importFrom stats formula
#'
#' @export
#' @examples
#' \dontrun{
#' data(RubellaNudge)
#' create_RCTtoolbox(
#'   baseline = itest + ivacc ~ treat,
#'   covariate = ~ age + educ,
#'   data = RubellaNudge,
#'   treat_levels = LETTERS[1:7]
#' )
#' }
#'
#'
create_RCTtoolbox <- function(baseline = NULL,
                              covariate = NULL,
                              data = NULL,
                              treat_levels = NULL,
                              treat_labels = treat_levels
                              ) {
  # check arguments
  if (is.null(baseline)) abort_empty("baseline")
  if (is.null(data)) abort_empty("data")
  if (is.null(treat_levels)) abort_empty("treat_levels")
  if (length(treat_levels) != length(treat_labels)) {
    abort_length("`label`", length(treat_levels), treat_labels)
  }

  # parse baseline
  yvec <- all.vars(f_lhs(baseline))
  dvec <- all.vars(f_rhs(baseline))
  if (length(dvec) > 1) abort_length("RHS of `baseline`", 1, dvec)
  formula_yd <- lapply(yvec, function(x) formula(paste(x, "~", dvec)))

  # parse covariate
  xvec <- NULL
  if (!is.null(covariate)) {
    if (!is.list(covariate)) covariate <- list(covariate)
    xvec <- unique(unlist(lapply(covariate, all.vars)))
  }

  # crate R6 class
  rct <- RCTtoolbox$new(
    formula_yd,
    covariate,
    yvec,
    xvec,
    dvec,
    treat_levels,
    treat_labels,
    data
  )

  rct$print()
  invisible(rct)
}


#Create Cross Validation Folds
crossval.list <- function(dataset, labels, nfolds) {
  #Creates a stratified k-fold cross-validation
  positives <- which(labels == 1)
  negatives <- which(labels == 0)

  data.positives <- dataset[positives,]
  data.negatives <- dataset[negatives,]
  labels.positives <- labels[positives]
  labels.negatives <- labels[negatives]

  split <- 1/nfolds
  numpos <- round(split*length(positives))
  numneg <- round(split*length(negatives))

  data.pos <- list()
  data.neg <- list()
  labels.pos <- list()
  labels.neg <- list()
  idx.pos <- list()
  idx.neg <- list()

  for (i in 1:(nfolds-1)) {

    cv.fold.idx.pos <- sort(sample(dim(data.positives)[1], numpos, replace=FALSE))
    cv.fold.idx.neg <- sort(sample(dim(data.negatives)[1], numneg, replace=FALSE))

    fold.pos <- data.positives[cv.fold.idx.pos,]
    fold.neg <- data.negatives[cv.fold.idx.neg,]
    fold.labels.pos <- labels.positives[cv.fold.idx.pos]
    fold.labels.neg <- labels.negatives[cv.fold.idx.neg]

    data.positives <- data.positives[-cv.fold.idx.pos,]
    data.negatives <- data.negatives[-cv.fold.idx.neg,]
    labels.positives <- labels.positives[-cv.fold.idx.pos]
    labels.negatives <- labels.negatives[-cv.fold.idx.neg]

    data.pos[[i]] <- fold.pos
    data.neg[[i]] <- fold.neg
    idx.pos[[i]] <- cv.fold.idx.pos
    idx.neg[[i]] <- cv.fold.idx.neg
    labels.pos[[i]] <- fold.labels.pos
    labels.neg[[i]] <- fold.labels.neg
  }
  i <- i + 1

  data.pos[[i]] <- data.positives
  data.neg[[i]] <- data.negatives
  labels.pos[[i]] <- labels.positives
  labels.neg[[i]] <- labels.negatives

  #Data split, now create fold data
  train.data.folds <- list()
  test.data.folds <- list()
  train.labels.folds <- list()
  test.labels.folds <- list()

  for(i in 1:nfolds) {

    test.data <- rbind(data.pos[[i]], data.neg[[i]])
    test.labels <- c(labels.pos[[i]], labels.neg[[i]])

    train.data <- vector()
    train.labels <- vector()
    for(j in 1:nfolds) {
      if(j != i) {
        train.data <- rbind(train.data,
                            data.pos[[j]], data.neg[[j]])
        train.labels <- c(train.labels, labels.pos[[j]], labels.neg[[j]])
      }
    }

    train.data.folds[[i]] <- train.data
    train.labels.folds[[i]] <- train.labels

    test.data.folds[[i]] <- test.data
    test.labels.folds[[i]] <- test.labels
  }

  folds.lists <- list()
  folds.lists[[1]] <- train.data.folds
  folds.lists[[2]] <- test.data.folds
  folds.lists[[3]] <- train.labels.folds
  folds.lists[[4]] <- test.labels.folds
  folds.lists[[5]] <- idx.pos
  folds.lists[[6]] <- idx.neg
  folds.lists[[7]] <- positives
  folds.lists[[8]] <- negatives

  return(folds.lists)
}


#' @name check_par
#' @title Check parameter dimensions
#' @param p The parameter to check
#' @param nrx The number of resource/niche dimensions
#' @param nsp The number of species
#' @rdname check_par
#' @keywords internal
.check_scale = function(p, nsp) {
	if(length(p) == 1)
		p = rep(p, nsp)
	if(length(p) != nsp)
		stop("Scale parameters must be missing, a single value, or 1 value per species")
	p
}

#' @rdname check_par
#' @keywords internal
.check_ratio = function(r, nr) {
	if(!is.matrix(r))
		r = matrix(r, nrow=1)
	if(any(r %% 1 != 0) )
		stop("ratio niches must be indicated by a matrix of integer indices")
	if(any(r > nr))
		stop("All entries in ratio must be <= nr")
	if(ncol(r) != 2)
		stop("ratio must be a 2-column matrix")
	r
}

#' @rdname check_par
#' @keywords internal
.check_breadth = function(p, nsp, nrx) {
	if(length(p) == 1)
		p = rep(p, nsp)

	if(!is.list(p) && length(p) == nsp) {
		p = matrix(p, nrow = nsp, ncol = nrx)
	} else if(!is.list(p) && length(p) == nrx) {
		p = matrix(p, nrow = nsp, ncol = nrx, byrow = TRUE)
	}

	## univariate niches
	if(nrx == 1) {
		if(!(is.matrix(p) && nrow(p) == nsp && ncol(p) == 1))
			stop("Invalid niche breadth: must be a scalar, vector, or one-column matrix")
		## convert back to a vector so it plays nicely with mapply
		p = p[, 1]
	} else {
		## for multivariate niches
		p = .check_breadth_multi(p, nsp, nrx)
	}
	p
}

#' @rdname check_par
#' @keywords internal
.check_breadth_multi = function(p, nsp, nrx) {
	if(is.matrix(p)) {
		if(nrow(p) != nsp || ncol(p) != nrx)
			stop("Invalid niche breadth; see ?niches")
		p = lapply(1:nsp, function(i) {
			mat = matrix(0, nrow = nrx, ncol = nrx)
			diag(mat) = p[i, ]
			mat
		})
	}

	## test proper dimensions of the breadth param for multivariate niches
	## must be a list, one entry per species
	## each entry a square matrix with dimension nrx
	if(!(is.list(p) &&
		length(p) == nsp &&
		all(sapply(p, is.matrix)) &&
		all((sapply(p, nrow) - nrx) == 0) &&
		all((sapply(p, ncol) - nrx) == 0))) {
		stop("Invalid niche breadth; see ?metacommunity")
	}
	p
}

#' @rdname check_par
#' @keywords internal
.check_r_use = function(p, nsp, nrx, static) {
	if(length(p) == 1)
		p = rep(p, nsp)

	if(!is.matrix(p) && length(p) == nsp) {
		p = matrix(p, nrow = nsp, ncol = nrx)
	} else if(!is.matrix(p) && length(p) == nrx) {
		p = matrix(p, nrow = nsp, ncol = nrx, byrow = TRUE)
	}

	if(!(is.matrix(p) && nrow(p) == nsp && ncol(p) == nrx))
		stop("r_use must be a matrix with one row per species and one column per niche axis")

	if(length(static) > 0) {
		if(any(static > nrx) || any(static <= 0))
			stop("Indices in static must be <= to the number of resources")
		p[,static] = 0
	}

	# convert to a list, one entry per row
	lapply(seq_len(nrow(p)), function(i) p[i, ])
}

#' @rdname check_par
#' @keywords internal
.check_species_params = function(x) {
	loc = x$par_c$location
	bre = x$par_c$breadth
	csc = x$par_c$scale
	rsc = x$r_use
	esc = x$par_e$scale
	alpha = x$alpha
	beta = x$beta

	if(length(csc) != 1 | length(esc) != 1 | length(alpha) != 1 | length(beta) != 1)
		stop("The following parameters must be single values: ",
			"c_scale, e_scale, alpha, beta")

	if(any(bre < 0) | csc < 0 | esc < 0 | alpha < 0 | beta < 0)
		stop("The following parameters must not be negative: ",
			"breadth, scale_c, scale_e, alpha, beta")

	if(length(loc) == 1 & length(bre) != 1)
		stop("dimension mismatch: breadth and r_scale must be length 1 with a single niche",
				"dimension")
	if(length(loc) > 1 & (!is.matrix(bre) | !identical(dim(bre), rep(length(loc), 2))))
		stop("dimension mismatch: breadth must be a square matrix with one row/column per ",
			"niche dimension")
}


getNodesAux=function(f,sampling,error,type,deltaOriginalInterval,relative)
{   # auxliary variables
    found=FALSE;
    i=1;
    n_interval_in=0;
    # Iterate until the node is found
    while(found==FALSE)
    {
          bj=n_interval_in
          # width of the interval
          delta = sampling/(2^(i+1));
          # searching
          for (j in (bj*2):(bj*2+1))
          {
            interval= c(j*delta,(j+1)*delta);
            if (f %rhrv_in% interval)
                 n_interval_in=j
            found =  getError(f,interval,type,deltaOriginalInterval,relative)<error;
            if (found)
               break

          }
          if (found==FALSE)
              i=i+1;

    }
    return(c(i,j))
}


#' Read MT3D .btn File
#'
#' This function reads in a btn file and creates a list
#' composed of the following vectors:
#' \describe{
#' \item{NLAY}{Atomic Vector of the Number of Layers in the Model Grid}
#' \item{NCOL}{Atomic Vector of the Number of Columns in the Model Grid}
#' \item{NROW}{Atomic Vector of the Number of Rows in the Model Grid}
#' \item{NPER}{Atomic Vector of the Number of Stress Periods in the Model}
#' \item{NCOMP}{Atomic Vector of the Number of Compounds in the Model}
#' \item{MCOMP}{Atomic Vector of the Number of Mobile Compounds in the Model}
#' \item{TUNIT}{Atomic Vector of the Number of Time Unit}
#' \item{LUNIT}{Atomic Vector of the Number of Length Unit}
#' \item{MUNIT}{Atomic Vector of the Number of Mass Unit}
#' \item{TRNOP}{Logical Vector of Packages To Use}
#' \item{LAYCON}{Vector of Layer Types: LAYCON = 0 = Confined, LAYCON != 0 = Unconfined or Convertible}
#' \item{dX}{Cell Width Along Columns}
#' \item{X}{Cell Center Coordinate in the Model Coordinate System}
#' \item{dY}{Cell Width Along Rows}
#' \item{Y}{Cell Center Coordinate in the Model Coordinate System}
#' \item{TOP}{Top Elevation of Layer 1}
#' \item{TRANS} {Data frame composed of LAY, ROW, COL, dZ, PRSITY, ICBUND, SONC, where these values are defined as follows:}
#' \item{dZ}{Layer Thicknesses}
#' \item{PRSITY}{Porosity}
#' \item{ICBUND}{ICBUND array. See MT3DMS manual for a description of ICBUND}
#' \item{SCONC}{Starting Concentrations at the beginning of the simulation}
#' \item{CINACT}{Value that indicates an inactive value}
#' \item{THKMIN}{Minimum saturated thickness in a cell}
#' \item{IFMTCN}{Flag indicating whether the calculated concentration should be
#' printed to the standard output text file and also serves as a printing-format
#' code if it is printed}
#' \item{IFMTNP}{Flag indicating if the number of particles in each cell should be printed and also
#' serves as a printing format code if it is printed}
#' \item{IFMTRF}{Flag indicating if the model-calculated retardation factor should be printed and also
#' serves as a printing format code if it is printed}
#' \item{IFMTDP}{Flag indicating if the model-calculated distance-weighted dispersion coefficient should
#' be printed and also serves as a printing format code if it is printed}
#' \item{SAVUCN}{Logical flag indicating if the concentration solution should be saved to a .ucn file}
#' \item{NPRS}{Flag indicating the frequncy of output and also indicating whether the frequency output
#' is specified in terms of total elapsed simulation time or the transport step number.
#' See MT3D Manual for further details of NPRS}
#' \item{TIMPRS}{Total elapsed time at which the simulation results are printed}
#' \item{NOBS}{Number of Observations wells recording concentration data}
#' \item{NPROBS}{Integer indicating how frequently the concentration is recorded at each
#'  Observation Well}
#' \item{OBSLOC}{Cell indices (L, R, C) of Observation Well locations}
#' \item{CHKMAS}{Logical Flag indicating whether a one-line summary of mass balance
#' information should be printed}
#' \item{NPRMAS}{Integer indicating how frequently the mass budget information
#' should be recorded}
#' \item{PERLEN}{Lengths of Stress Perids}
#' \item{NSTP}{Number of time-steps for the transient flow folution in each stress-period}
#' \item{TSMULT}{Time-step multiplier. Only used if NSTP > 1. See MT3DMS Manual for
#' further details}
#' \item{TSLNGHdf}{If TSMULT < 0, TSLNGHdf frovides the length of time-steps for the
#' flow solution in each stress period}
#' \item{DT0}{The user-specified transport step size within each time-step of the
#' flow solution}
#' \item{MXSTRN}{The maximum number of transport time steps allowed within one time
#' step of the flow solution}
#' \item{TTSMULT}{A multiplier for successive transport steps within a flow step}
#' \item{TTSMAX}{Maximum transport step size allowed when transport step size multiplier
#' TTSMULT > 1.0}
#' }
#' @param rootname This is the root name of the btn file
#' @export
#' @examples
#' readbtn("T04")
#'
#' # Find the average initial concentration assigned to the MT3DMS Model
#' btn <- readbtn("T04")
#' btn$TRANS %>%
#' select(SCONC) %>%
#' summarise(AVG = mean(SCONC))
#'
#' > A tibble: 1 x 1
#' >        AVG
#' >      <dbl>
#' > 1 17.77554
#'
#' # Find the average initial concentration (> 5 µg/L)
#' # assigned to Layer 1 of the MT3DMS Model
#' btn$TRANS %>%
#' filter(LAY == 1) %>%
#' select(SCONC) %>%
#' filter(SCONC >= 5) %>%
#' summarise(AVG = mean(SCONC))
#'
#' > A tibble: 1 x 1
#' >        AVG
#' >      <dbl>
#' > 1 1096.754
#'
#' # Find the range of porosity values assigned to the model
#' btn$TRANS %>%                  # Select the RCL Value table that contains the porosity values
#' select(PRSITY) %>%             # Select the table column that contains porosity values
#' t() %>%                        # Convert to a vector of values
#' as.factor() %>%
#' levels()
#'
#' > [1] "0.15" "0.21" "0.25" "0.4"

readbtn <- function(rootname){
    infl <- paste(rootname, ".btn", sep = "")
    linin <- readr::read_lines(infl)
    indx <- 3
    NLAY <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(1) %>% as.integer()
    NROW <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(2) %>% as.integer()
    NCOL <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(3) %>% as.integer()
    NPER <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(4) %>% as.integer()
    NCOMP <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(5) %>% as.integer()
    MCOMP <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(6) %>% as.integer()
    indx <- indx + 1
    BLOCKSIZE <- NROW * NCOL
    TUNIT <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(1) %>% as.character()
    LUNIT <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(2) %>% as.character()
    MUNIT <- linin[indx] %>% MFtools::parse_MF_FW_ELMT(3) %>% as.character()
    indx <- indx + 1
    TRNOP <- linin[indx] %>% MFtools::parse_MF_FW_LINE()
    indx <- indx + 1
    BLOCKEND <- ceiling(NLAY / 40)
    LAYCON <- linin[indx + seq(1:BLOCKEND) - 1] %>%
              MFtools::parse_MF_FW_LINE() %>%
              as.integer()

    HDGLOC       <- grep("\\(", linin)
    HDG          <- linin[HDGLOC]
    UNI          <- substr(HDG, start = 1, stop = 10) %>% as.integer()
    MULT         <- substr(HDG, start = 11, stop = 20) %>% as.numeric()
    ARR_MULT     <- UNI / UNI
    ARR_MULT[is.na(ARR_MULT)] <- 0
    MULTLOC      <- grep("^0$", UNI)
    FRMT         <- substr(HDG, start = 21, stop = 30)
    FRMTREP      <- regmatches(FRMT, gregexpr("[[:digit:]]+", FRMT)) %>% lapply('[[', 1) %>% unlist() %>% as.integer()
    BLOCK_START  <- HDGLOC + 1
    BLOCK_END    <- dplyr::lead(BLOCK_START) - 2
    BLOCK_LENGTH <- (NROW * ceiling(NCOL / FRMTREP))
    BLOCK_END[length(BLOCK_END)] <- BLOCK_END[length(BLOCK_END) - 1] + BLOCK_LENGTH[length(BLOCK_END)] + 1
    BLOCK_START  <- BLOCK_START * ARR_MULT
    BLOCK_END    <- BLOCK_END * ARR_MULT
    CELL_INDX    <- Map(seq, BLOCK_START, BLOCK_END)
# COLUMN WIDTHS
#---------------------------------------------------------
    indx <- HDGLOC[1] + 1
    BLOCKEND <- (ceiling(NCOL / FRMTREP[1]))
    if(UNI[1] == 0){
        dX <- rep(MULT[1], NCOL)
    }else{
        dX <- linin[indx + seq(1:BLOCKEND) - 1] %>% MFtools::parse_MF_FW_LINE()
        }
    dX %<>% as.numeric()
    X <- c(dX[1] / 2., dX[1:(NCOL - 1)] / 2 + dX[2:NCOL] / 2) %>% cumsum()
# ROW WIDTHS
#----------------------------------------------------------
    indx <- HDGLOC[2] + 1
    BLOCKEND <- (ceiling(NROW / FRMTREP[2]))
    if(UNI[2] == 0){
    dY <- rep(MULT[2], NROW)
    }else{
        dY <- linin[CELL_INDX[[2]]] %>% parse_MF_FW_LINE()
        }
    dY %<>% as.numeric()
    Y <- sum(dY) - (c(dY[1] / 2., dY[1:(NROW - 1)] / 2. + dY[2:NROW] / 2.) %>% cumsum())
# TOP ELEVATION
#-----------------------------------------------------------
    indx <- HDGLOC[3]
    if(UNI[3] == 0){
        TOPin <- rep(MULT[3], BLOCKSIZE)
    }else{
        TOPin <- linin[CELL_INDX[[3]]] %>% MFtools::parse_MF_FW_LINE()
    }
    TOPin %<>% as.numeric()

    TOP <- tibble::data_frame(ROW = rep(1:NROW, each = NCOL),
                              COL = rep(seq(1, NCOL, 1), NROW),
                              TOP = TOPin)
    rm(TOPin)
# ASSIGN REMAINING PARAMETERS
#--------------------------------------------------------------
indx <- HDGLOC[4] +1
VAL <- c()
if(length(MULTLOC[MULTLOC > 3]) > 0){
    # SPECIFIED CELLS: CELL BOTTOM ELEVATIONS SPECIFED USING MULT
    # SPEC_CELLS ARE THE CELLS THAT ARE DEFINED WHEN UNIT == 0
    SPEC_CELLS <- rep(BLOCKSIZE * (MULTLOC[MULTLOC > 3] - 4), each = BLOCKSIZE) + 1:BLOCKSIZE
    # ARR_CELLS ARE SPEFICIED IN ARRAYS.
    ARR_LOC    <- grep("^1$", ARR_MULT)
    ARR_CELL   <- rep(BLOCKSIZE * (ARR_LOC[ARR_LOC > 3] - 4), each = BLOCKSIZE) + 1:BLOCKSIZE
    VAL[SPEC_CELLS] <- rep(MULT[MULTLOC[MULTLOC > 3]], each = BLOCKSIZE)
    VAL[ARR_CELL] <- CELL_INDX %>% MFtools::parse_MF_CELL_INDX(LINE = linin)
    }else{
    VAL <- CELL_INDX %>% MFtools::parse_MF_CELL_INDX(LINE = linin)
    }

    dZ     <- VAL[1:(NLAY * BLOCKSIZE)] %>%
              as.numeric()
    PRSITY <- VAL[(NLAY * BLOCKSIZE + 1):(2 * NLAY * BLOCKSIZE)] %>%
              as.numeric()
    ICBUND <- VAL[(2 * NLAY * BLOCKSIZE + 1):(3 * NLAY * BLOCKSIZE)] %>%
              as.integer()
    SCONC <-  VAL[(3 * NLAY * BLOCKSIZE + 1) : (NLAY * BLOCKSIZE * (3 + NCOMP))] %>%
              as.numeric()
    dim(SCONC) <- c(NLAY * BLOCKSIZE, NCOMP)
    SCONC      <- as_tibble(SCONC, validate = FALSE)
    TRANS <- tibble::data_frame(
                      LAY = rep(1:NLAY, each = NCOL * NROW),
                      ROW = rep(rep(1:NROW, each = NCOL), NLAY),
                      COL = rep(rep(seq(1, NCOL, 1), NROW), NLAY),
                      X   = rep(rep(X, NROW), NLAY),
                      Y   = rep(rep(Y, each = NCOL), NLAY),
                      dZ = dZ,
                      PRSITY = PRSITY,
                      ICBUND = ICBUND) %>%
                      bind_cols(SCONC) %>%
                      select(LAY,
                             ROW,
                             COL,
                             X,
                             Y,
                             dZ,
                             PRSITY,
                             ICBUND,
                             SCONC = starts_with("V")) %>%
                      tibble::repair_names(prefix = "SCONC", sep = "_")
rm(VAL)
# BACK ARRAYS
#--------------------------------------------------------------
    indx <- HDGLOC[length(HDGLOC)] +
            ifelse(UNI[length(UNI)] >= 1, 1, 0) *
            BLOCK_LENGTH[length(BLOCK_LENGTH)] + 1

    CINACT <- linin[indx] %>% parse_MF_FW_ELMT(1) %>%
              as.numeric()

    THKMIN <- linin[indx] %>% parse_MF_FW_ELMT(2) %>%
              as.numeric()

    indx <- indx + 1
    IFMTCN <- linin[indx] %>% parse_MF_FW_ELMT(1) %>%
              as.integer()
    IFMTNP <- linin[indx] %>% parse_MF_FW_ELMT(2) %>%
              as.integer()
    IFMTRF <- linin[indx] %>% parse_MF_FW_ELMT(3) %>%
              as.integer()
    IFMTDP <- linin[indx] %>% parse_MF_FW_ELMT(4) %>%
              as.integer()
    SAVUCN <- linin[indx] %>% parse_MF_FW_ELMT(5)
    UNKN <- linin[indx] %>% parse_MF_FW_ELMT(6)
    indx <- indx + 1

# UCN PRINTING FREQUENCY
#-----------------------------------------------------------------
    NPRS <- linin[indx] %>% parse_MF_FW_LINE() %>%
            as.integer()
    indx <- indx + 1
    TIMPRS <- vector(mode = "numeric", length = abs(NPRS))
    FRMTREP <- 8
    FRMTWIDTH <- 10
    BLOCKEND <- ceiling(abs(NPRS) / FRMTREP)
    if(NPRS > 0){
    for(i in 1:BLOCKEND){
        FROM <- (i - 1) * FRMTREP + 1
        TO <- ifelse(i == BLOCKEND, NPRS, i * FRMTREP)
        TIMPRS[FROM:TO] <- substring(linin[indx],
                           seq(1, nchar(linin[indx]), FRMTWIDTH),
                           seq(FRMTWIDTH, nchar(linin[indx]), FRMTWIDTH)) %>%
                           gsub("[[:space:]]", "", .) %>%
                        as.numeric()
        indx <- indx + 1
        }
    }
#
#-----------------------------------------------------------------
    NOBS <- linin[indx] %>% parse_MF_FW_ELMT(1) %>%
            as.integer()
    KOBS <- vector(mode = "integer", length = NOBS)
    IOBS <- vector(mode = "integer", length = NOBS)
    JOBS <- vector(mode = "integer", length = NOBS)
    NPROBS <- linin[indx] %>% parse_MF_FW_ELMT(2) %>%
            as.integer()
    indx <- indx + 1
    OBSLOC <- tibble::data_frame(
                        OBS_WELL = NA,
                        LAY = NA,
                        ROW = NA,
                        COL = NA
                        )

    if(NOBS > 0){
    OBSLOC_OBS_WELL <-  1:NOBS
    OBSLOC_LAY <- substring(linin[indx:(indx + NOBS - 1)], 1, 10) %>%
              gsub("[[:space:]]", "", .) %>%
              as.integer()
    OBSLOC_ROW <- substring(linin[indx:(indx + NOBS - 1)], 11, 20) %>%
              gsub("[[:space:]]", "", .) %>%
              as.integer()
    OBSLOC_COL <- substring(linin[indx:(indx + NOBS - 1)], 21, 30) %>%
              gsub("[[:space:]]", "", .) %>%
              as.integer()
    OBSLOC <- tibble::data_frame(
                    OBS_WELL = OBSLOC_OBS_WELL,
                    LAY = OBSLOC_LAY,
                    ROW = OBSLOC_ROW,
                    COL = OBSLOC_COL
                    )
    indx <- indx + NOBS
    }

    CHKMAS <- linin[indx] %>% parse_MF_FW_ELMT(1)
    NPRMAS <- linin[indx] %>% parse_MF_FW_ELMT(2) %>%
              as.integer()
    indx <- indx + 1
    PERLEN <- vector(mode = "numeric", length = NPER)
    NSTP <- vector(mode = "integer", length = NPER)
    TSMULT <- vector(mode = "numeric", length = NPER)
    TSLNGH <- c()
    DT0 <- vector(mode = "numeric", length = NPER)
    MXSTRN <- vector(mode = "integer", length = NPER)
    TTSMULT <- vector(mode = "numeric", length = NPER)
    TTSMAX <- vector(mode = "numeric", length = NPER)
    TSLNGHdf <- tibble::data_frame(
              PER = NA,
              TSLNGH = NA
              )

    for(Q in 1:NPER){
        PERLEN <- substr(linin[indx], start = 0, stop = 11) %>%
                     as.numeric()
        NSTP[Q] <-   substr(linin[indx], start = 11, stop = 20) %>%
                     as.integer()
        TSMULT[Q] <- substr(linin[indx], start = 21, stop = 30) %>%
                     as.numeric()
        indx <- indx + 1
        if(TSMULT[[Q]] < 0){
            FRMTREP <- 8
            FRMTWIDTH <- 10
            BLOCKEND <- ceiling(TSMULT[[Q]] / FRMTREP)
            for(i in 1:BLOCKEND){
                FROM <- (i - 1) * FRMTREP + 1
                TO <- ifelse(i == BLOCKEND, NPRS, i * FRMTREP)
                TSLNGH[FROM:TO] <- substring(linin[indx],
                                   seq(1, nchar(linin[indx]), FRMTWIDTH),
                                   seq(FRMTWIDTH, nchar(linin[indx]), FRMTWIDTH)) %>%
                                   gsub("[[:space:]]", "", .) %>%
                                as.numeric()
                indx <- indx + 1
                TSLNGHdf$PER[FROM:TO]     <- Q
                TSLNGHdf$TSLNGTH[FROM:TO] <- TSLNGTH
            }
        }
        DT0[Q] <- substr(linin[indx], start = 0, stop = 10) %>%
                  as.numeric()
        MXSTRN[Q] <- substr(linin[indx], start = 11, stop = 20) %>%
                     as.integer()
        TTSMULT[Q] <- substr(linin[indx], start = 21, stop = 30) %>%
                      as.numeric()
        TTSMAX[Q] <- substr(linin[indx], start = 31, stop = 40) %>%
                     as.numeric()
        indx <- indx + 1
    }
    rm(linin)
    BTN <- list(NLAY = NLAY,
                NCOL = NCOL,
                NROW = NROW,
                NPER = NPER,
                NCOMP = NCOMP,
                MCOMP = MCOMP,
                TUNIT = TUNIT,
                LUNIT = LUNIT,
                MUNIT = MUNIT,
                TRNOP = TRNOP,
                LAYCON = LAYCON,
                dX = dX,
                X = X,
                dY = dY,
                Y = Y,
                TOP = TOP,
                TRANS = TRANS,
                CINACT = CINACT,
                THKMIN = THKMIN,
                IFMTCN = IFMTCN,
                IFMTNP = IFMTNP,
                IFMTRF = IFMTRF,
                IFMTDP = IFMTDP,
                SAVUCN = SAVUCN,
                NPRS = NPRS,
                TIMPRS = TIMPRS,
                NOBS = NOBS,
                NPROBS = NPROBS,
                OBSLOC = OBSLOC,
                CHKMAS = CHKMAS,
                NPRMAS = NPRMAS,
                PERLEN = PERLEN,
                NSTP = NSTP,
                TSMULT = TSMULT,
                TSLNGHdf = TSLNGHdf,
                DT0 = DT0,
                MXSTRN = MXSTRN,
                TTSMULT = TTSMULT,
                TTSMAX = TTSMAX)
    return(BTN)
    gc()
    }


#! /usr/bin/Rscript --vanilla

library("rjson")

args = commandArgs(TRUE)

bugginess = fromJSON(args[2])
values = fromJSON(args[3])

print(cor.test(bugginess, values, method="pearson"))
print(cor.test(bugginess, values, method="kendall"))

# exact flag suppresses a warning
print(cor.test(bugginess, values, method="spearman", exact=FALSE))


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Coauthor networks: data preparation
# Note: analysis done in Python, see folder 2019-09-24-coauthor-networkx
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Set up
source('2019-06-19-jsa-type/init/var.R')
source('2019-06-19-jsa-type/subset.R')

# Parameters
dir_plot = "C:\\Users\\ejysoh\\Dropbox\\msc-thesis\\research\\_figures\\_ch3\\_ch3-coauth\\"
theme = theme_minimal()

# Read/wrangle data
df0a <- get_df1(write=F)
df0b <- get_df2(write=F)
df0b <- df0b[status=="Synonym"]
df <- rbind(df0a[,c("full.name.of.describer", "idx", "date.n")],
            df0b[,c("full.name.of.describer", "idx", "date.n")])
df <- df[date.n <= 2018]

df$date.decade <- paste0(substr(as.character(df$date.n), 1, 3), "0s")
df <- df %>% separate_rows(full.name.of.describer, sep="; ")
df <- unique(df)
df <- df[order(date.n)]
df1 <- df[] # for coauth analysis

df <- df[, list(.N), by=c('idx', 'date.decade')]
df <- df[order(date.decade)]
df$N <- as.character(df$N)

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Number of co-authoring authors
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Number of co-authoring authors"))
dim(df)
prop.table(table(df$N %in% c(2,3,4)))*100

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Mean year of publication for co-authors
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

nw = get_describer_network()
auth_coauth = unique(c(nw[!is.na(p2)]$p1, nw[!is.na(p2)]$p2))
auth_did_not_coauth = unique(nw[is.na(p2)]$p1)
auth_did_not_coauth = unique(auth_did_not_coauth[!auth_did_not_coauth %in% auth_coauth])
any(auth_did_not_coauth %in% auth_coauth)

length(auth_did_not_coauth)
length(auth_did_not_coauth) / (length(auth_coauth) + length(auth_did_not_coauth)) * 100

# get publication year
des = get_des(write=F)

idxes_coauth = des[full.name.of.describer.n %in% auth_coauth, c("spp_idxes")]
idxes_coauth = unique(separate_rows(idxes_coauth, spp_idxes, sep=", "))
idxes_coauth = idxes_coauth[order(as.integer(spp_idxes))]
dim(idxes_coauth)
df_coauth = df1[idx %in% as.numeric(idxes_coauth$spp_idxes)]
df_coauth$coauth = "Coauthor"

idxes_did_not_coauth = des[full.name.of.describer.n %in% auth_did_not_coauth, c("spp_idxes")]
idxes_did_not_coauth = unique(separate_rows(idxes_did_not_coauth, spp_idxes, sep=", "))
idxes_did_not_coauth = idxes_did_not_coauth[order(as.integer(spp_idxes))]
dim(idxes_did_not_coauth)
df_did_not_coauth = df1[idx %in% as.numeric(idxes_did_not_coauth$spp_idxes)]
df_did_not_coauth$coauth = "Did not coauthor"

df_bp = rbind(df_coauth, df_did_not_coauth)
df_bp$coauth = factor(df_bp$coauth, levels=c("Coauthor", "Did not coauthor"))

df_bp[, list(mean=mean(date.n),
             se=sd(date.n)/sqrt(.N),
             n=.N), by=coauth]

# Plot
plot_bp = ggplot(df_bp) +
  geom_boxplot(aes(y=date.n, fill=as.character(coauth))) +
  theme +
  ylab("Year of description\n") +
  theme(axis.title.x=element_blank(),
      axis.text.x=element_blank(),
      axis.ticks.x=element_blank()) +
  scale_fill_manual(name="", values=c("grey80", "grey40"))

plot_bp
# ggsave(paste0(dir_plot, 'fig-4.png'), plot_bp, units="cm", width=15, height=10, dpi=300)

res = t.test(df_coauth$date.n, df_did_not_coauth$date.n, alternative = "two.sided", var.equal = FALSE)
res$p.value
res

# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
# Section - Proportion of authors across years
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
print(paste0(Sys.time(), " --- Proportion of authors across years"))

calc_median <- function(x){
  return(c(y = -0.1, label = length(x)))
  # experiment with the multiplier to find the perfect position
}

plot_auth_decade1 <-
    ggplot(data=df, aes(x=date.decade, fill=N)) +
        geom_bar(position = "fill") +
        xlab("\nDecade") + ylab("Proportion of species with \nN number of authors\n") +
        theme + scale_fill_grey()

plot_auth_decade2 <-
    ggplot(data=df, aes(x=date.decade, fill=N)) +
        geom_bar(stat='count') +
        xlab("\nDecade") + ylab("Number of species with \nN number of authors\n") +
        theme + scale_fill_grey()

gr = grid.arrange(plot_auth_decade1, plot_auth_decade2)
ggsave(paste0(dir_plot, 'fig-4.png'), gr, units="cm", width=30, height=15, dpi=300)


#31-03-2020
#Elozetes halalozasi aranyok szamitasa idosoros adatokon
#Explorativ, vizualizacio

#memoria uritese
rm(list = ls())

#BETOLTES
#adatok betoltese Johns Hopkins egyetem folyamatos frissitesu online adataibol
rawcovid <- read.csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv", header=TRUE, as.is=T, sep=",", fileEncoding = "UTF-8")  #rawcovid az igazolt betegek

rawcovidd <- read.csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_global.csv", header=TRUE, as.is=T, sep=",", fileEncoding = "UTF-8") #rawcovidd az igazolt halalesetek

#OECD orszagok alapadatai -- Ebben az elemzesben nem hasznalom, de kesobb bovitheto, ezert bennehagyom
oecdraw <- read.csv("https://raw.githubusercontent.com/bricoler/naiv_COVID19_HU/R_code/OECD_2019.csv", header=TRUE, as.is=T, sep=",", fileEncoding = "UTF-8")

#AGGREGALAS
#aggregalas orszagokra igazolt betegek
#E: itt eldobjuk a GEO-t, de a jovoben lehetne kezdeni valamit a tavolsagi adatokkal, ketdimenzioban (ido, ter)
l2 <- dim(rawcovid)[2] # napok hossza
rcovid <- aggregate(rawcovid[5:l2], by = list(rawcovid$Country.Region), FUN = sum) # orszagok szerinti aggregalas rcovid
rownames(rcovid) <- rcovid[,1] #sornevek javitasa rcovidban
colnames(rcovid)[1] <- "cname"

# Dél-Korea nevének javítása
rownames(rcovid)[which(rownames(rcovid) %in% "Korea, South")] <- "Korea South"
rcovid$cname[rcovid$cname=="Korea, South"] <- "Korea South"
rrcovid <- rcovid[,-1] # elso oszlop a cname torlese rrcovidban

#aggregalas a halalesetekre
#E: itt eldobjuk a GEO-t, de a jovoben lehetne kezdeni valamit a tavolsagi adatokkal, ketdimenzioban (ido, ter)
l2 <- dim(rawcovidd)[2] # napok hossza
rcovidd <- aggregate(rawcovidd[5:l2], by = list(rawcovidd$Country.Region), FUN = sum) # orszagok szerinti aggregalas rcovidd
rownames(rcovidd) <- rcovidd[,1] #sornevek javitasa rcovidban
colnames(rcovidd)[1] <- "cname"
# Dél-Korea nevének javítása
rownames(rcovidd)[which(rownames(rcovidd) %in% "Korea, South")] <- "Korea South"
rcovidd$cname[rcovidd$cname=="Korea, South"] <- "Korea South"
# OECD orszagok vizsgalata csak
##rrcovidd <- rcovidd[(rcovidd$cname %in% oecdraw$cname),] ##rrcovidd: csak OECD orszagok
colnames(rcovidd)[1] <- "cname"
rrcovidd <- rcovidd[,-1] # elso oszlop a cname torlese rrcovidban
#az OECD lakossagszam leosztas
#covid : lakossagszamaranyos fertozottek aranya OECD orszagokban

rcovid[rcovid==0]<-NA #0-kbol NA
rcovidd[rcovidd==0]<-NA #0-kbol NA

#covid az igazolt halalesetek es az igazol beteszam aranya
covid <- rrcovidd / rrcovid

covid[covid==0]<-NA #0-kbol NA

#Populacioval valo osztas, nem ertelmes
#for (i in 1:dim(rrcovid)[1])
#{
#covid[i,] <- rrcovid[i,] / oecdraw[rownames(rrcovid)[i],"pop"]
#}

#HALALOZASI ARANY ORSZAGONKENT
cname <- NULL # orszag neve
rmin <- NULL # legalacsonyabb arany (igazolt halalozas es igazolt betegszam hanyadoasa)
rmax <- NULL # legmagasabb arany (igazolt halalozas es igazolt betegszam hanyadoasa)
rmean <-NULL # atlag
rmedian <-NULL #median
rsd <-NULL # szorasa

rni2 <- NULL # shapiroval normal p ertek

rlen <- NULL # hossza

rsu <- NULL # igazolt halalozas es igazolt betegszam hanyadoasanak 95% UP
rsd <- NULL # igazolt halalozas es igazolt betegszam hanyadoasanak 95% DOWN

for (i in 1:dim(covid)[1])
{
cname[i] <- rownames(covid)[i] # orszag neve
rmin[i] <- min(as.numeric(covid[i,]), na.rm=T)
rmax[i] <- max(as.numeric(covid[i,]), na.rm=T)
rmean[i] <- mean(as.numeric(covid[i,]), na.rm=T)
rmedian[i] <- median(as.numeric(covid[i,]), na.rm=T)
rsd[i] <- sd(as.numeric(covid[i,]), na.rm=T)
rlen[i]  <- sum(as.numeric(as.numeric(covid[i,])>0), na.rm=T)

rni2[i] <- ifelse (rlen[i]>5,as.numeric(shapiro.test(as.numeric(covid[i,]))[2]),0)

rsu[i] <- rmean[i] + qnorm(0.95)*rsd[i]/sqrt(rlen[i]) # 90% CI
rsd[i] <- rmean[i] + qnorm(0.95)*rsd[i]/sqrt(rlen[i]) # 90% CI

}

rresults <- data.frame(cname,rlen,rmean,rmax,rmin,rmedian,rsd,rsu,rsd,rni2, stringsAsFactors = TRUE)
colnames(rresults)[1] <- "cname"
View(rresults)

#VIZ
plot(c(1:length(rresults$rmean)),rresults$rmean[order(rresults$rmean, decreasing = TRUE)], log="xy")

# write.csv(rresults, file = "D:/R/Data/covid19_IEF.csv",fileEncoding = "UTF-8")

#raw_kornyezo_oecd <- covid[rownames(covid) %in% oecdraw$cname,]

raw_kornyezo_oecd2 <- t(covid)

#install.packages("ggplot2")
library("ggplot2")
#install.packages("reshape")
library(reshape)

g_raw <- melt(raw_kornyezo_oecd2)
colnames(g_raw) <- c("Datum" , "Orszag", "COVID_19_halálozasi_arany_atlaga_es_eloszlasa")

g_raw2 <- g_raw[which(g_raw$COVID_19_halálozasi_arany_atlaga_es_eloszlasa>0.0),]

ggplot(g_raw2, aes(x = reorder(Orszag, COVID_19_halálozasi_arany_atlaga_es_eloszlasa, FUN = median), y = COVID_19_halálozasi_arany_atlaga_es_eloszlasa)) + geom_boxplot()

# Box plot
boxp <- ggplot(g_raw2, aes(x = reorder(Orszag, COVID_19_halálozasi_arany_atlaga_es_eloszlasa,  FUN = median), y = COVID_19_halálozasi_arany_atlaga_es_eloszlasa)) +
  geom_boxplot(aes(fill = Orszag)) +
  geom_jitter(position=position_jitter(0.2)) +
  theme_minimal() +
  theme(legend.position = "none", axis.text.x = element_text(angle=90)
  )
boxp + scale_x_discrete(name="")

#VIZ2
plot(c(1:length(g_raw2$COVID_19_halálozasi_arany_atlaga_es_eloszlasa )),g_raw2$COVID_19_halálozasi_arany_atlaga_es_eloszlasa[order(g_raw2$COVID_19_halálozasi_arany_atlaga_es_eloszlasa , decreasing = TRUE)], log="y")
median(g_raw2$COVID_19_halálozasi_arany_atlaga_es_eloszlasa)

#VEGE


zero <- function(v) {
    0
}

# wrapper
wrapper <- function(table, columns, options) {

    # initialize output list
    l <- list()

    # loop through all columns
    m <- list()
    for (key in names(columns)) {
        # load column data
        column <- as.numeric(columns[key])

        # ensure string column
        column_data <- as.character(table[column][[1]])

        # collect vectors in list
        m <- append(m, list(column_data))
    }

    # get alphabetically sorted bins
    bins <- sort(unique(unlist(m)))

    # add first column
    l <- append(l, list(bins))

    # loop through all columns
    for (key in seq(m)) {
        # reset bins
        bins <- sapply(bins, zero)

        # load column data
        column_data <- m[[key]]

        # create hist data
        table_data <- table(column_data)

        # transfer counts to bins
        for (id in names(table_data)) {
            bins[id] <- table_data[id]
        }

        # normalize densities
        total <- length(column_data)
        if (total > 0) {
            bins <- bins / total
        }

        # collect vectors in list
        l <- append(l, list(bins))
    }

    # return
    return(l)
}


require(Hmisc)
set.seed(1)
d <- expand.grid(day=c(1, 3), rx=c('A','B'), reps=1:3)
d$x <- runif(nrow(d))
s <- summary(x ~ day + stratify(rx), fun=smean.sd, overall=FALSE, data=d)
w <- latex(s, file='/tmp/z.tex', table.env=FALSE, booktabs=TRUE)


library(dplyr)
library(RColorBrewer)
source("style.r")

args = commandArgs(trailingOnly = TRUE)
data = read.csv(args[1])

data$time = data$time/60
data = data %>%
	group_by(alpha, app_id) %>%
	mutate(
		   thp = ifelse(app_id == 5, cumsum(tasks_fulfilled)/(time-25), cumsum(tasks_fulfilled)/time),
		   req = cumsum(tasks_requested)/time)
data = data.frame(data)

data$app_id = factor(
					 data$app_id,
					 levels = c(5, 3, 4, 1, 2),
					 labels = c("Roof", "iPerf", "Air Quality", "Traffic", "Parking"))
data$alpha = factor(data$alpha, levels = c(100, 1, 0, -1), labels = c("Mobius\n(Max-Min)", "Mobius\n(Prop. Fair)", "Max\nThroughput", "Dedicated\nDrones"))
data = subset(data, app_id != -1)

colors = brewer.pal(n = 5, name = 'Dark2')
colors = c(colors[5], colors[3], colors[4], colors[1], colors[2])

p = ggplot(data, aes(x = time, y = thp, fill = app_id)) +
	geom_area(color = "black") +
	scale_fill_manual(values = colors) +
	facet_wrap(. ~ alpha, nrow=1) +

	# formatting
	theme(
		  legend.position = "top", legend.box = "vertical",
		  legend.margin=margin(0,0,0,0), legend.box.margin=margin(-4,-4,-7,-7),
		  legend.text = element_text(size = 10)
	) +
	ylim(c(0, NA)) +
	xlim(c(0, NA)) +
	xlab("Time (min)") +
	ylab("Long-term Tput\n(tasks/min)") +
	labs(fill = "", shape = "")
ggsave(args[2], p, width = 5, height = 2, units = 'in')


locs <- get_aeronet_radiosonde_matches()

locs$n <- rep(NA, nrow(locs))
locs$rmse <- rep(NA, nrow(locs))
locs$corr <- rep(NA, nrow(locs))
locs$m <- rep(NA, nrow(locs))
#locs$c <- rep(NA, nrow(locs))
locs$r2 <- rep(NA, nrow(locs))
locs$e_mean <- rep(NA, nrow(locs))
locs$e_sd <- rep(NA, nrow(locs))
locs$perc_e_mean <- rep(NA, nrow(locs))
locs$perc_e_sd <- rep(NA, nrow(locs))

mlist.ar = list()

for (i in 1:nrow(locs))
{
  l <- locs[i,]

  print(paste("###### Running validation for", l$aeronet, "and", l$radiosonde))
  m.temp <- aeronet_radiosonde_merge(l$aeronet, l$radiosonde)
  # Mark all stats as NA for any time that m.temp is NA (ie. fails)
  # or the length of m.temp is < 3 (ie. v few coincident measurements,
  # too few to do stats on)
  if ((is.na(m.temp[1]) && length(m.temp) == 1) || nrow(m.temp) < 3)
  {
    locs[i,]$rmse <- NA
    locs[i,]$m <- NA
    locs[i,]$corr <- NA
    locs[i,]$r2 <- NA
    locs[i,]$n <- NA
    locs[i,]$e_mean <- NA
    locs[i,]$e_sd <- NA
    locs[i,]$perc_e_mean <- NA
    locs[i,]$perc_e_sd <- NA
  }
  else
  {
    # Calculate percentage error
    m.temp$perc_e <- (m.temp$error / m.temp$pwc) * 100.0

    locs[i,]$rmse <- rmse(m.temp$error)
    model <- lm(m.temp$pwc ~ m.temp$PWC + 0)
    locs[i,]$m <- model$coefficients[1]
    locs[i,]$r2 <- summary(model)$r.squared
    locs[i,]$e_mean <- mean(m.temp$error)
    locs[i,]$e_sd <- sd(m.temp$error)
    locs[i,]$perc_e_mean <- mean(m.temp$perc_e)
    locs[i,]$perc_e_sd <- sd(m.temp$perc_e)

    locs[i,]$corr <- cor(m.temp$pwc, m.temp$PWC)

    locs[i,]$n <- nrow(m.temp)

    # Old code from before 1st Sept
    #mlist.radiosonde[[bigf_names[1]]] = m.temp

    # New code to deal with collisions between
    # stations with the same names
    element_name = l$radiosonde
    index = 1
    while (element_name %in% names(mlist.ar))
    {
      element_name = paste(l$radiosonde, "_", index, sep="")
      print(paste("In while loop:", element_name))
      index = index + 1
    }

    mlist.ar[[element_name]] = m.temp

    #browser()
  }

}

# Remove the src_id column, not needed any more
val.ar <- na.omit(locs)
val.ar$src_id <- NULL
#val.ar$bigf <- tolower(val.ar$bigf)
val.ar$radiosonde <- tolower(val.ar$radiosonde)

l <- lapply(mlist.ar, coredata)
m.ar <- do.call('rbind', l)
m.ar <- as.data.frame(m.ar)

#cache('val.ar')
#cache('m.ar')
#cache('mlist.ar')


'
The file "figure.r" creates one figure, plotting
the effect of perception of morality on self-indulgence for consumers with two different gift-giving motivations (altruistic motivation vs. social norm motivation).

'

rm(list=ls())

source("project_paths.r")
library(ggplot2, lib=PATH_OUT_LIBRARY_R)
library(foreign, lib=PATH_OUT_LIBRARY_R)

delete_outlier <- read.table(
     file=paste(PATH_OUT_DATA, "delete_outlier.txt", sep = "/"),
     header = TRUE

)

#####MEAN CENTER THE PERCEPTION OF MORALITY#####
center_appropriateness<-delete_outlier$appropriateness-mean(delete_outlier$appropriateness)

####################PLOT WITH ggplot#########
gp<-ggplot(data=delete_outlier,aes(x=center_appropriateness,y=brand_ave,colour=factor(Altruism)))
b<-gp + geom_point() + stat_smooth(method="lm")+ggtitle("INFLUENCE OF THE PERCEPTION\n OF MORALITY ON INDULGENCE")+labs(x="Perception of Morality",y="Indulgence")+theme(plot.title = element_text(face="bold", size=10))+theme(axis.title=element_text(face="bold",size=9))+theme(axis.line = element_line(size = 1,colour = "black"))+ scale_colour_discrete(name="Motivation",labels=c("Social Norm","Altruism"))

ggsave(file=paste(PATH_OUT_FIGURES, "figure1.png", sep="/"))


# (C) @Hackintush

library(tuneR)
library(seewave)

specan3 <- function(X, bp = c(0,22), wl = 2048, threshold = 5, parallel = 1){
  # To use parallel processing: library(devtools), install_github('nathanvan/parallelsugar')
  if(class(X) == "data.frame") {if(all(c("sound.files", "selec",
                                         "start", "end") %in% colnames(X)))
  {
    start <- as.numeric(unlist(X$start))
    end <- as.numeric(unlist(X$end))
    sound.files <- as.character(unlist(X$sound.files))
    selec <- as.character(unlist(X$selec))
  } else stop(paste(paste(c("sound.files", "selec", "start", "end")[!(c("sound.files", "selec",
                                                                        "start", "end") %in% colnames(X))], collapse=", "), "column(s) not found in data frame"))
  } else  stop("X is not a data frame")

  #if there are NAs in start or end stop
  if(any(is.na(c(end, start)))) stop("NAs found in start and/or end")

  #if end or start are not numeric stop
  if(all(class(end) != "numeric" & class(start) != "numeric")) stop("'end' and 'selec' must be numeric")

  #if any start higher than end stop
  if(any(end - start<0)) stop(paste("The start is higher than the end in", length(which(end - start<0)), "case(s)"))

  #if any selections longer than 20 secs stop
  if(any(end - start>20)) stop(paste(length(which(end - start>20)), "selection(s) longer than 20 sec"))
  options( show.error.messages = TRUE)

  #if bp is not vector or length!=2 stop
  if(!is.vector(bp)) stop("'bp' must be a numeric vector of length 2") else{
    if(!length(bp) == 2) stop("'bp' must be a numeric vector of length 2")}

  #return warning if not all sound files were found
  fs <- list.files(path = getwd(), pattern = ".wav$", ignore.case = TRUE)
  if(length(unique(sound.files[(sound.files %in% fs)])) != length(unique(sound.files)))
    cat(paste(length(unique(sound.files))-length(unique(sound.files[(sound.files %in% fs)])),
              ".wav file(s) not found"))

  #count number of sound files in working directory and if 0 stop
  d <- which(sound.files %in% fs)
  if(length(d) == 0){
    stop("The .wav files are not in the working directory")
  }  else {
    start <- start[d]
    end <- end[d]
    selec <- selec[d]
    sound.files <- sound.files[d]
  }

  # If parallel is not numeric
  if(!is.numeric(parallel)) stop("'parallel' must be a numeric vector of length 1")
  if(any(!(parallel %% 1 == 0),parallel < 1)) stop("'parallel' should be a positive integer")

  # If parallel was called
  if(parallel > 1)
  { options(warn = -1)
    if(all(Sys.info()[1] == "Windows",requireNamespace("parallelsugar", quietly = TRUE) == TRUE))
      lapp <- function(X, FUN) parallelsugar::mclapply(X, FUN, mc.cores = parallel) else
        if(Sys.info()[1] == "Windows"){
          cat("Windows users need to install the 'parallelsugar' package for parallel computing (you are not doing it now!)")
          lapp <- pbapply::pblapply} else lapp <- function(X, FUN) parallel::mclapply(X, FUN, mc.cores = parallel)} else lapp <- pbapply::pblapply

  options(warn = 0)

  if(parallel == 1)
  x <- as.data.frame(lapp(1:length(start), function(i) {
    r <- tuneR::readWave(file.path(getwd(), sound.files[i]), from = start[i], to = end[i], units = "seconds")

    b<- bp #in case bp its higher than can be due to sampling rate
    if(b[2] > ceiling(r@samp.rate/2000) - 1) b[2] <- ceiling(r@samp.rate/2000) - 1

    #frequency spectrum analysis
    songspec <- seewave::spec(r, f = r@samp.rate, plot = FALSE)
    analysis <- seewave::specprop(songspec, f = r@samp.rate, flim = c(0, 280/1000), plot = FALSE)

    #save parameters
    meanfreq <- analysis$mean/1000
    sd <- analysis$sd/1000
    median <- analysis$median/1000
    Q25 <- analysis$Q25/1000
    Q75 <- analysis$Q75/1000
    IQR <- analysis$IQR/1000
    skew <- analysis$skewness
    kurt <- analysis$kurtosis
    sp.ent <- analysis$sh
    sfm <- analysis$sfm
    mode <- analysis$mode/1000
    centroid <- analysis$cent/1000

    #Frequency with amplitude peaks
    peakf <- 0#seewave::fpeaks(songspec, f = r@samp.rate, wl = wl, nmax = 3, plot = FALSE)[1, 1]

    #Fundamental frequency parameters
    ff <- seewave::fund(r, f = r@samp.rate, ovlp = 50, threshold = threshold,
                        fmax = 280, ylim=c(0, 280/1000), plot = FALSE, wl = wl)[, 2]
    meanfun<-mean(ff, na.rm = T)
    minfun<-min(ff, na.rm = T)
    maxfun<-max(ff, na.rm = T)

    #Dominant frecuency parameters
    y <- seewave::dfreq(r, f = r@samp.rate, wl = wl, ylim=c(0, 280/1000), ovlp = 0, plot = F, threshold = threshold, bandpass = b * 1000, fftw = TRUE)[, 2]
    meandom <- mean(y, na.rm = TRUE)
    mindom <- min(y, na.rm = TRUE)
    maxdom <- max(y, na.rm = TRUE)
    dfrange <- (maxdom - mindom)
    duration <- (end[i] - start[i])

    #modulation index calculation
    changes <- vector()
    for(j in which(!is.na(y))){
      change <- abs(y[j] - y[j + 1])
      changes <- append(changes, change)
    }
    if(mindom==maxdom) modindx<-0 else modindx <- mean(changes, na.rm = T)/dfrange

    #save results
    return(c(duration, meanfreq, sd, median, Q25, Q75, IQR, skew, kurt, sp.ent, sfm, mode,
             centroid, peakf, meanfun, minfun, maxfun, meandom, mindom, maxdom, dfrange, modindx))
  }))

  #change result names

  rownames(x) <- c("duration", "meanfreq", "sd", "median", "Q25", "Q75", "IQR", "skew", "kurt", "sp.ent",
                   "sfm","mode", "centroid", "peakf", "meanfun", "minfun", "maxfun", "meandom", "mindom", "maxdom", "dfrange", "modindx")
  x <- data.frame(sound.files, selec, as.data.frame(t(x)))
  colnames(x)[1:2] <- c("sound.files", "selec")
  rownames(x) <- c(1:nrow(x))

  return(x)
}

processFolder <- function() {
  # Start with empty data.frame.
  data <- data.frame()

  # Get list of files in the folder.
  list <- list.files('./', '.wav$')

  # Add file list to data.frame for processing.
  for (fileName in list) {
    row <- data.frame(fileName, 0, 0, 20)
    data <- rbind(data, row)
  }

  # Set column names.
  names(data) <- c('sound.files', 'selec', 'start', 'end')

  # Process files.
  acoustics <- specan3(data, parallel=1)

  # Move back into parent folder.
  acoustics
}

# Load data
males <- processFolder()

# Set labels.
data <- rbind(males)

# Remove unused columns.
data$duration <- NULL
data$sound.files <- NULL
data$selec <- NULL
data$peakf <- NULL

# Remove rows containing NA's.
data <- data[complete.cases(data),]

# Write out csv dataset.
write.csv(data, file='my_voice.csv', row.names=F)


import_package("dplyr", attach=TRUE)
.idmap = import('../process/idmap')
.guess = import('../process/idmap/guess')

#' Use a linear model to test consistent gene DE in a collection of gene sets
#'
#' @param genes  A data.frame with gene separation statistics
#' @param sets   List of character vectors
#' @param label  Column name of gene names
#' @param stat   Column name of separation statistics
#' @param add_means  Column name(s) of variables to compute the mean of the set of
#' @param trim   Fraction of extremes to ignore when computing the mean
#' @return       A data.frame with association results
test_lm = function(genes, sets,
                   label=c("external_gene_name", "gene_name", "gene", "name", "label", "ensembl_gene_id"),
                   stat=c("stat", "statistic", "log2FoldChange"),
                   add_means=c(), trim=0) {
    test_one = function(res, set) {
        dset = res %>% mutate(in_set = !! slab %in% set + 0)

        sums = dset %>% group_by(in_set) %>%
            summarize_at(vars(all_of(add_means)), function(x) mean(x, na.rm=TRUE, trim=trim)) %>%
            summarize_at(vars(all_of(add_means)), diff)

        lm(as.formula(paste(stat, "~ in_set")), data=dset) %>%
            broom::tidy() %>%
            filter(term == "in_set") %>%
            select(-term) %>%
            mutate(size = length(set),
                   size_used = sum(res[[label]] %in% set & !is.na(res[[stat]]))) %>%
            cbind(sums)
    }

    msg = c()
    if (length(label) > 1) {
        label = intersect(label, colnames(genes))[1]
        first = head(na.omit(genes[[label]]), 2) %>% sQuote() %>% paste(collapse=", ")
        msg = c(msg, paste0(sQuote(label), " for sets (", first, ", …)"))
    }
    slab = rlang::sym(label)
    if (length(stat) > 1) {
        stat = intersect(stat, colnames(genes))[1]
        msg = c(msg, paste0(sQuote(stat), " for separation"))
    }
    if (length(msg) > 0)
        message("[geneset/test_lm] using ", paste(msg, collapse=", "))

    all_sets = unique(unlist(sets))
    if (mean(all_sets %in% genes[[label]]) < 0.25) {
        idt = .guess$id_type(all_sets)
        message("[geneset/test_lm] low identifier overlap, mapping ", sQuote(label), " to ", sQuote(idt))
        genes[[label]] = .idmap$gene(genes[[label]], to=idt)
    }

    lapply(sets, test_one, res=genes) %>%
        setNames(names(sets)) %>%
        dplyr::bind_rows(.id="label") %>%
        as_tibble() %>%
        na.omit() %>%
        select(label, size, size_used, !!! rlang::syms(add_means), everything()) %>%
        mutate(adj.p = p.adjust(p.value, method="fdr")) %>%
        arrange(adj.p, p.value)
}

if (is.null(module_name())) {
    library(testthat)

    genes = data.frame(gene = LETTERS[1:10], stat=1:10)
    sets = list(a=LETTERS[1:5])
    res = test_lm(genes, sets)

    expect_true(inherits(res, "data.frame"))
    expect_equal(res$estimate, -5)
}


library(data.table)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

nchains <- 2

source('../../config.r')

## * Data
model_data <- new.env()
load('../generated/model/data.rdata', envir = model_data)
## attach(model_data)

## Different BETA0 between JAGS and Stan
model_data$BETA0 <- 1 #model_data$BETA0^-0.

## ## Overwrite the interaction variables, so the interaction is by species
## model_data$DUMMYVAR_INTERACTION_O <- model.matrix(data=data.frame(y=model_data$OVERLAP_O,
##     x1=as.factor(model_data$SPECIES_O),
##     x2=as.factor(model_data$FISHERY_GROUP_O)), y~x1:x2-1)

## model_data$N_INTERACTION_CAT_O <- ncol(model_data$DUMMYVAR_INTERACTION_O)

## model_data$DUMMYVAR_INTERACTION_T <- model.matrix(data=data.frame(y=model_data$OVERLAP_T,
##     x1=as.factor(model_data$SPECIES_T),
##     x2=as.factor(model_data$FISHERY_GROUP_T)), y~x1:x2-1)

## model_data$N_INTERACTION_CAT_T <- ncol(model_data$DUMMYVAR_INTERACTION_T)

save(model_data, file='../generated/model/model_data.rdata', compress = F)

warmup <- 2000
nsamples <- 1500

## * Run model
fit <- stan(file       = 'model.stan',
           model_name = "SRAmodel",
           pars       = c('apf_t', 'q0', 'q_f0', 'q_g0', 'q_gf0',
                          'p_identified_bird',
                          'p_identified_family',
                          'captures_o',
			  'sigma_f',
			  'sigma_g',
                          'q_prior'),
           include    = TRUE, ## TRUE to only store parameters in `pars`
           data       = model_data,
           iter       = warmup + nsamples,
           warmup     = warmup,
           control    = list(max_treedepth = 15, adapt_delta=0.8),
           chains     = nchains,
           diagnostic_file='../generated/model/diag.txt',
           verbose    = F,
           seed       = 3859285)

codasamples <- As.mcmc.list(fit)
mcmc <- data.table(do.call('rbind', codasamples))

save(codasamples, fit,
     file = '../generated/model/model-fitted.rdata', compress = F)


library(ggplot2)
library(grid)
library(formattable)
library(gridExtra)

CATEGORIES = c('All', 'SubtypeB', 'SubtypeC', 'Non-SubtypeBC', 'Naive', 'ART')

SGS_PR=read.csv('data/prevalence/SGS.PRprevalence.csv')
SGS_RT=read.csv('data/prevalence/SGS.RTprevalence.csv')
SGS_IN=read.csv('data/prevalence/SGS.INprevalence.csv')

APOBECS=read.csv('data/prevalence/LUAPOBEC.csv')

CONSENSUS=read.csv('data/consensus.csv')

GENES = c('PR', 'RT', 'IN')

breaks = 10**(1:5)/1000

for (cat in CATEGORIES) {

  plots = list()
  DB_PREVALENCE_DATA = read.csv(
    sprintf('data/prevalence/dbAminoAcidVariants%s.csv', cat)
  )

  for (gene in GENES) {
    sgsData = switch(
      gene,
      PR = SGS_PR,
      RT = SGS_RT,
      IN = SGS_IN
    )
    cons = switch(
      gene,
      PR = as.character(CONSENSUS[1,2]),
      RT = as.character(CONSENSUS[2,2]),
      IN = as.character(CONSENSUS[3,2])
    )
    sgsData = sgsData[sgsData$Category == cat,]
    sgsData$sgsPcnt = sgsData$Pcnt
    dbData = DB_PREVALENCE_DATA[DB_PREVALENCE_DATA$gene == gene,]
    dbData$dbPcnt = dbData$percent * 100
    data = merge(sgsData, dbData, by.x=c("Pos", "AA"), by.y=c("position", "aa"), all.x=TRUE)
    data$Pos = as.numeric(as.character(data$Pos))
    data$Cons = substring(cons, data$Pos, data$Pos)
    if (gene == "RT") {
      data = data[data$Pos < 241,]
    }
    data$pcntFold = data$sgsPcnt / data$dbPcnt
    # data = c(data$position, data$aa, data$dbPcnt, data$sgsPcnt)
    df = subset(data, select=c("sgsPcnt", "dbPcnt"))
    model <- lm(dbPcnt ~ sgsPcnt, data=df)
    simx = seq(0, 100, step=0.01)
    confints = predict(model, newdata=data.frame(sgsPcnt=simx),
                        interval='confidence', level=0.95)
    confints = as.data.frame(confints)
    confints$lwr[confints$lwr < 0] = 0
    predints = predict(model, newdata=data.frame(sgsPcnt=simx),
                       interval='prediction', level=0.9)
    predints = as.data.frame(predints)
    predints$lwr[predints$lwr < 0] = 0

    #confints <- with(df, data.frame(lwr=))
    plot = ggplot(cbind(cbind(x=simx, confints))) +
      # geom_abline(aes(x=sgsPcnt, y=dbPcnt), color="blue") +
      geom_ribbon(aes(ymin=lwr, ymax=upr, x=x), fill="blue", alpha=0.2) +
      geom_line(aes(y=fit, x=x), color="blue", alpha=0.8) +
      geom_ribbon(aes(ymin=lwr, ymax=upr, x=x), data=cbind(cbind(x=simx, predints)), fill="blue", alpha=0.05) +
      geom_point(aes(x=sgsPcnt, y=dbPcnt), data=df, size=0.3) +
      scale_x_log10("SGSPcnt", breaks=breaks, labels=comma(breaks), limits=c(0.01, 100)) +
      scale_y_log10("DBPcnt", breaks=breaks, labels=comma(breaks), limits=c(0.01, 100)) +
      ggtitle(gene)
    plots = append(plots, list(plot))
    target = switch(
      gene,
      PR = sprintf('data/prevalence/CompPR%s.csv', cat),
      RT = sprintf('data/prevalence/CompRT%s.csv', cat),
      IN = sprintf('data/prevalence/CompIN%s.csv', cat)
    )
    out = data[data$sgsPcnt > 0 & data$AA != data$Cons,]
    # out = data[data$sgsPcnt > 0,]
    write.csv(subset(out, select=c("Pos", "Cons", "AA", "FromCodons", "ToCodons",
                                   "FromCodonsCtx", "ToCodonsCtx", "Count", "PosTotal", "PatientCount",
                                   "PatientPosTotal", "SampleCount", "SamplePosTotal", "sgsPcnt", "dbPcnt",
                                   "pcntFold", "IsAPOBEC", "isUnusual")
                     ), target, row.names=FALSE)
  }
  pdf(sprintf('data/%sPrevalanceCmp.pdf', cat), width=8, height=24)
  print(grid.arrange(grobs = plots, ncol = 1, nrow = 3))
  dev.off()
}


#!/usr/bin/r -t
#
# Comparison benchmark -- using old and small Longley data set
#
# This shows how Armadillo improves on the previous version using GNU GSL,
# and how both are doing better than lm.fit()
#
# Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
# Rcpp is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# Rcpp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.

suppressMessages(library(utils))
suppressMessages(library(Rcpp))
suppressMessages(library(inline))
suppressMessages(library(datasets))

source("lmArmadillo.R")
source("lmGSL.R")

data(longley)

longleydm <- data.matrix(data.frame(intcp=1, longley))
X <- longleydm[,-8]
y <- as.numeric(longleydm[,8])

N <- 1000

lmgsl <- lmGSL()
lmarma <- lmArmadillo()

tlm <- mean(replicate(N, system.time( lmfit <- lm(y ~ X - 1) )["elapsed"]), trim=0.05)
tlmfit <- mean(replicate(N, system.time(lmfitfit <- lm.fit(X, y))["elapsed"]), trim=0.05)
tlmgsl <- mean(replicate(N, system.time(lmgsl(y, X))["elapsed"]), trim=0.05)
tlmarma <- mean(replicate(N, system.time(lmarma(y, X))["elapsed"]), trim=0.05)

res <- c(tlm, tlmfit, tlmgsl, tlmarma)
data <- data.frame(results=res, ratios=tlm/res)
rownames(data) <- c("lm", "lm.fit", "lmGSL", "lmArma")
cat("For Longley\n")
print(t(data))
print(t(1/data[,1,drop=FALSE])) # regressions per second


require(graphics)
require(Matrix)

pdf(file="plots/Experiment4b.pdf",
  width=3.7, height=4.0, family="serif", pointsize=14)

input = as.matrix(read.table("results/Experiment4b_times.dat", sep=",")[3])
data = colMeans(matrix(input, 3, 4))/1000

data1 = data #data[c(35,15,25,5)]

plot_colors <- c("cornflowerblue","orange","black","orangered")

barplot( data1,
         space = c(0.1,0.1),
         xlab = "",
         ylab = "",
         col=plot_colors,
         ylim = c(1,900),
         log = "y",
         axes = FALSE,
         cex.names=0.96,
         names.arg = c("KDD","USC","Cov","Adu"),
         args.legend = list(x="topleft", bty="n", bty="n", ncol=1),
         beside = TRUE,
)

axis(2, las=1)
mtext(2,text="Execution Time [s]",line=2.7)
mtext(1,text="Datasets",line=2)

text(3.6,400,"maxL = 3")

box()	              # box around plot
dev.off()


rm(list = ls())
setwd(dirname(parent.frame(2)$ofile))

library(ggplot2)
library(xtable)
library(plyr)
library(dplyr)
library(tidyr)
library(readr)
library(kableExtra)
source('./_sequential_mnist_expand_name.r')

best.range = 1000

best.model.step.fn = function (errors) {
  best.step = max(length(errors) - best.range, 0) + which.min(tail(errors, best.range))
  if (length(best.step) == 0) {
    return(length(errors))
  } else {
    return(best.step)
  }
}

first.solved.step = function (steps, errors, threshold) {
  index = first(which(errors < threshold))
  if (is.na(index)) {
    return(NA)
  } else {
    return(steps[index])
  }
}

safe.interval = function (alpha, vec) {
  if (length(vec) <= 1) {
    return(NA)
  }

  return(abs(qt((1 - alpha) / 2, length(vec) - 1)) * (sd(vec) / sqrt(length(vec))))
}
#
# eps = read_csv('../results/sequential_mnist_mse_expectation.csv') %>%
#   filter(operation == 'cumprod') %>%
#   mutate(
#     test.extrapolation.length=extrapolation.length
#   ) %>%
#   select(operation, test.extrapolation.length, threshold)
#
# eps = data.frame(
#  operation = 'cumprod',
#  test.extrapolation.length = 1:9,
#  threshold = c(0.18, 4.7, 1.5e2, 4e3, 1.2e5, 4e6, 1.5e8, 4e9, 5e10)
# )
#

eps = expand.name(read_csv('../results/mnist-reference-solved.csv')) %>%
  gather(
    key="test.extrapolation.length", value="test.extrapolation.mse",
    loss.test.extrapolation.1.mse, loss.test.extrapolation.2.mse,
    loss.test.extrapolation.3.mse, loss.test.extrapolation.4.mse,
    loss.test.extrapolation.5.mse, loss.test.extrapolation.6.mse,
    loss.test.extrapolation.7.mse, loss.test.extrapolation.8.mse,
    loss.test.extrapolation.9.mse, loss.test.extrapolation.10.mse,
    loss.test.extrapolation.11.mse, loss.test.extrapolation.12.mse,
    loss.test.extrapolation.13.mse, loss.test.extrapolation.14.mse,
    loss.test.extrapolation.15.mse, loss.test.extrapolation.16.mse,
    loss.test.extrapolation.17.mse, loss.test.extrapolation.18.mse,
    loss.test.extrapolation.19.mse, loss.test.extrapolation.20.mse
  ) %>%
  rowwise() %>%
  mutate(
    test.extrapolation.length = extrapolation.loss.name.to.integer(test.extrapolation.length)
  ) %>%
  group_by(seed, test.extrapolation.length) %>%
  summarise(
    best.model.step = best.model.step.fn(loss.valid.validation.mse),
    threshold = test.extrapolation.mse[best.model.step],
  ) %>%
  filter(seed %in% c(0,1,2,4,5,6,7,9)) %>% # seed 3 and 8 did not solve it
  group_by(test.extrapolation.length) %>%
  summarise(
    threshold = mean(threshold) + qt(1 - 0.001, 8) * sd(threshold)
  )

dat = expand.name(read_csv('../results/sequential_mnist_prod_outputs.csv')) %>%
  gather(
    key="test.extrapolation.length", value="test.extrapolation.mse",
    loss.test.extrapolation.1.mse, loss.test.extrapolation.2.mse,
    loss.test.extrapolation.3.mse, loss.test.extrapolation.4.mse,
    loss.test.extrapolation.5.mse, loss.test.extrapolation.6.mse,
    loss.test.extrapolation.7.mse, loss.test.extrapolation.8.mse,
    loss.test.extrapolation.9.mse
  ) %>%
  mutate(
    valid.mse=loss.valid.validation.mse,
    valid.acc.all=loss.valid.validation.acc.all,
    valid.acc.last=loss.valid.validation.acc.last,
    valid.mnist.acc=loss.valid.mnist.acc,
    test.mnist.acc=loss.test.mnist.acc,
    test.extrapolation.length=as.integer(substring(test.extrapolation.length, 25, 25))
  ) %>%
  select(-starts_with("loss.test")) %>%
  select(-starts_with("loss.valid")) %>%
  merge(eps)

dat.last = dat %>%
  group_by(name, test.extrapolation.length) %>%
  summarise(
    threshold = last(threshold),
    best.model.step = best.model.step.fn(valid.mse),

    valid.mse.last = valid.mse[best.model.step],
    test.mnist.acc.last = test.mnist.acc[best.model.step],
    test.extrapolation.mse.last = test.extrapolation.mse[best.model.step],

    extrapolation.epoch.solved = first.solved.step(epoch, test.extrapolation.mse, threshold),

    sparse.error.max = sparse.error.max[best.model.step],
    sparse.error.mean = sparse.error.sum[best.model.step] / sparse.error.count[best.model.step],

    solved = replace_na(test.extrapolation.mse[best.model.step] < threshold, FALSE),
    model = last(model),
    operation = last(operation),
    hidden.size = last(hidden.size),
    seed = last(seed),
    size = n()
  )

dat.last.rate = dat.last %>%
  group_by(model, operation, hidden.size, test.extrapolation.length) %>%
  summarise(
    size=n(),
    success.rate.mean = mean(solved) * 100,
    success.rate.upper = NA,
    success.rate.lower = NA,

    converged.at.mean = mean(extrapolation.epoch.solved[solved]),
    converged.at.upper = converged.at.mean + safe.interval(0.95, extrapolation.epoch.solved[solved]),
    converged.at.lower = converged.at.mean - safe.interval(0.95, extrapolation.epoch.solved[solved]),

    sparse.error.mean = mean(sparse.error.max[solved]),
    sparse.error.upper = sparse.error.mean + safe.interval(0.95, sparse.error.max[solved]),
    sparse.error.lower = sparse.error.mean - safe.interval(0.95, sparse.error.max[solved])
  )

dat.gather.mean = dat.last.rate %>%
  mutate(
    success.rate = success.rate.mean,
    converged.at = converged.at.mean,
    sparse.error = sparse.error.mean
  ) %>%
  select(model, operation, hidden.size, test.extrapolation.length, success.rate, converged.at, sparse.error) %>%
  gather('key', 'mean.value', success.rate, converged.at, sparse.error)

dat.gather.upper = dat.last.rate %>%
  mutate(
    success.rate = success.rate.upper,
    converged.at = ifelse(converged.at.upper > 1000, NA, converged.at.upper),
    sparse.error = ifelse(sparse.error.upper > 1, NA, sparse.error.upper)
  ) %>%
  select(model, operation, hidden.size, test.extrapolation.length, success.rate, converged.at, sparse.error) %>%
  gather('key', 'upper.value', success.rate, converged.at, sparse.error)

dat.gather.lower = dat.last.rate %>%
  mutate(
    success.rate = success.rate.lower,
    converged.at = ifelse(converged.at.lower < 0, NA, converged.at.lower),
    sparse.error = ifelse(sparse.error.lower < 0, NA, sparse.error.lower)
  ) %>%
  select(model, operation, hidden.size, test.extrapolation.length, success.rate, converged.at, sparse.error) %>%
  gather('key', 'lower.value', success.rate, converged.at, sparse.error)

dat.gather = merge(merge(dat.gather.mean, dat.gather.upper), dat.gather.lower) %>%
  mutate(
    model=droplevels(model),
    lower.value=as.numeric(lower.value),
    upper.value=as.numeric(upper.value),
    key = factor(key, levels = c("success.rate", "converged.at", "sparse.error"))
  )

for (extrapolation.length in c(9)) {
  p = ggplot(
      dat.gather %>% filter(test.extrapolation.length == extrapolation.length),
      aes(x = hidden.size, colour=model)
    ) +
    geom_point(aes(y = mean.value)) +
    geom_line(aes(y = mean.value)) +
    geom_errorbar(aes(ymin = lower.value, ymax = upper.value), width = 0.5) +
    scale_color_discrete(labels = model.to.exp(levels(dat.gather$model))) +
    scale_x_continuous(
      name = paste0('Hidden size at extrapolation length ', extrapolation.length),
      breaks=unique(dat.gather$hidden.size)
    ) +
    scale_y_continuous(name = element_blank()) +
    facet_wrap(~ key, scales='free_y', labeller = labeller(
      key = c(
        success.rate = "Success rate in %",
        converged.at = "Solved at epoch",
        sparse.error = "Sparsity error"
      )
    )) +
    theme(legend.position="bottom") +
    theme(plot.margin=unit(c(5.5, 10.5, 5.5, 5.5), "points"))
  print(p)
  ggsave(paste0('../paper/results/sequential_mnist_prod_hidden_size_l', extrapolation.length,'.pdf'), p, device="pdf", width = 13.968, height = 5, scale=1.4, units = "cm")
}
#
#
# for (extrapolation.length in 1:9) {
#   p = ggplot(
#     dat.gather %>% filter(test.extrapolation.length == extrapolation.length & key %in% c("success.rate", "converged.at")),
#     aes(x = hidden.size, colour=model)
#   ) +
#     geom_point(aes(y = mean.value)) +
#     geom_line(aes(y = mean.value)) +
#     geom_errorbar(aes(ymin = lower.value, ymax = upper.value), width = 0.5) +
#     scale_color_discrete(name=element_blank(), labels = model.to.exp(levels(dat.gather$model))) +
#     scale_x_continuous(
#       name = element_blank(),
#       breaks=unique(dat.gather$hidden.size)
#     ) +
#     scale_y_continuous(name = element_blank()) +
#     facet_wrap(~ key, scales='free_y', labeller = labeller(
#       key = c(
#         success.rate = "Success rate in %",
#         converged.at = "Solved at epoch",
#         sparse.error = "Sparsity error"
#       )
#     )) +
#     theme(legend.position="bottom") +
#     theme(
#       plot.margin=unit(c(5.5, 5.5, 5.5, 5.5), "points"),
#       axis.title = element_blank(),
#       legend.margin=unit(c(0, 0, 5.5, 0), "points")
#     )
#   print(p)
#   ggsave(paste0('../paper/results/sequential_mnist_prod_hidden_size_small_l', extrapolation.length,'.pdf'), p, device="pdf", width = 8, height = 4, scale=1.4, units = "cm")
# }
#
#
# p = ggplot(
#   dat.gather %>% filter(hidden.size == 1),
#   aes(x = test.extrapolation.length, colour=model)
# ) +
#   geom_point(aes(y = mean.value)) +
#   geom_line(aes(y = mean.value)) +
#   geom_errorbar(aes(ymin = lower.value, ymax = upper.value), width = 0.5) +
#   scale_color_discrete(name=element_blank(), labels = model.to.exp(levels(dat.gather$model))) +
#   scale_x_continuous(
#     name = "Extrapolation length",
#     breaks=unique(dat.gather$test.extrapolation.length)
#   ) +
#   scale_y_continuous(name = element_blank()) +
#   facet_wrap(~ key, scales='free_y', labeller = labeller(
#     key = c(
#       success.rate = "Success rate in %",
#       converged.at = "Solved at epoch",
#       sparse.error = "Sparsity error"
#     )
#   )) +
#   theme(legend.position="bottom") +
#   theme(
#     plot.margin=unit(c(5.5, 5.5, 5.5, 5.5), "points"),
#     legend.margin=unit(c(0, 0, 5.5, 0), "points")
#   )
# print(p)


#' Create a bias-corrected distribution model
#'
#' This function implements an occupancy-detection model assuming that:
#' \itemize{
#' 		\item{Detection varies by state but not between counties in a state.
#' 		\item{False detections can occur when the species does not occupy a county but does not occur when it does.
#'		\item{Occupancy is a function of the occupancy of neighboring counties.
#' }
#' @param shape SpatialPolygonsDataFrame
#' @param effort Character, name of field in \code{shape} indicating collection effort.
#' @param detect Character, name of field in \code{shape} indicating number of detections of focal species.
#' @param stateProv Character, name of field with state/province.
#' @param county Character, name of field with county.
#' @param niter Positive integer, number of MCMC iterations (including burn-in). The default is 2000, but this is often too low for most cases (i.e., try numbers in the range 10000, 100000, etc.).
#' @param nburnin Positive integer, number of burn-in samples (less than \code{niter}). The default is 1000, but this is often too low for most cases (i.e., try numbers in the range 10000, 100000, etc.).
#' @param nchains Positive integer, number of MCMC chains (default is 4).
#' @param thin Positive integer, number of MCMC samples by which to thin the results (default is 1; i.e., no thinning). To reduce memory requirements, you can use \code{thin} while increasing \code{niter} and/or \code{nburnin}.
#' @param raf Logical, if \code{TRUE} (default), dynamically change the value for niter using the Raftery-Lewis method for assessing number of iterations needed for convergence. The number used will the the number suggested rounded up to the nearest 1000. The total number of iterations (including burn-in) will be this number plus \code{nburnin}.
#' @param minIter Minimum number of iterations to require (not including burn-in).
#' @param maxIter Maximum number of iterations to allow in output. The final number of recommended iterations will be \code{min(maxIter, rl)} where \code{rl} is the number recommend by the RL method, rounded up to the nearest 1000. If \code{rl} is > \code{maxIter} a warning will be issued.
#' @param nsamples Number of samples desired (after burn-in and thinning). Only used if \code{raf} is \code{TRUE}. Used to reset the value of \code{thin} after estimating the number of iterations using the Raftery-Lewis method.
#' @param na.rm Logical, if \code{TRUE} (default), then remove rows in \code{shape} that have \code{NA} in any input field. If this is \code{FALSE} and \code{NA}s occur in any fields then an error may occur.
#' @param verbose Logical, if \code{TRUE} (default) display progress.
#' @param ... Arguments to pass to \code{\link[nimble]{configureMCMC}}, \code{\link[nimble]{runMCMC}}, and \code{rafLewis}.
#' @return A list object with three elements, one with the MCMC chains, a second with the object \code{shape} with model output appended to the data portion of the object, and a third with model information. The new columns in \code{shape} represent:
#' \itemize{
#' 		\item{\code{psi}} Probability of occurrence
#' 		\item{\code{psi95CI}} 95% credibility interval for probability of occurrence
#' 		\item{\code{p}} Probability of detecting the focal species assuming it is present
#' 		\item{\code{p95CI}} 95% credibility interval for probability of detection
#' }
#' @examples
#' @export

trainBayesODM_pMaxVarByState_psiCar <- function(
	shape,
	effort,
	detect,
	stateProv,
	county,
	niter = 2000,
	nburnin = 1000,
	nchains = 4,
	thin = 1,
	raf = TRUE,
	minIter = 2000,
	maxIter = 11000,
	nsamples = 1000,
	na.rm = TRUE,
	verbose = TRUE,
	...
) {

	### prepare data
	################

		# remove missing
		if (na.rm) {
			ok <- complete.cases(shape@data[ , c(effort, detect)])
			shape <- shape[ok, ]
		}

		### CAR setup for counties

		neighs <- spdep::poly2nb(shape, queen=TRUE)
		neighIndex <- which(!sapply(neighs, function(shape) { length(shape == 1) && (shape == 0) }))
		islandIndex <- which(sapply(neighs, function(shape) { length(shape == 1) && (shape == 0) }))

		hasNeighs <- length(neighIndex) > 0
		hasIslands <- length(islandIndex) > 0

		if (hasIslands) {
			shapeNoIslands <- shape[neighIndex, ]
			neighs <- spdep::poly2nb(shapeNoIslands, queen=TRUE)
		}

		numNeighs <- length(neighIndex)
		numIslands <- length(islandIndex)

		numCounties <- nrow(shape)
		numStates <- length(unique(shape@data[ , stateProv]))

		### input
		data <- list()
		constants <- list(
			numStates = numStates
		)

		inits <- list(
			q = 0.01,
			qConstraint = rep(1, numStates),
			p_max = rep(0.6, numStates),
			p_min_star = rep(0.95, numStates)
		)

		# some counties have neighbors
		if (hasNeighs) {

			# remove islands
			neighsList <- spdep::nb2WB(neighs)
			carAdjCounty <- neighsList$adj
			carWeightCounty <- neighsList$weights
			carNumCounty <- neighsList$num

			data <- c(
				data,
				list(
					y_neigh = shape@data[neighIndex, detect],
					N_neigh = shape@data[neighIndex, effort],
					carAdjCounty = carAdjCounty,
					carWeightCounty = carWeightCounty,
					carNumCounty = carNumCounty
				)
			)

			constants <- c(
				constants,
				list(
					numNeighs = numNeighs,
					state_neigh = as.numeric(as.factor(shape@data[neighIndex, stateProv])),

					lengthAdjCounties = length(carAdjCounty)
				)
			)

			inits <- c(
				inits,
				list(
					p_star_neigh = runif(numNeighs, inits$p_min_star * inits$p_max, inits$p_max),

					z_neigh = rep(1, numNeighs),
					psi_neigh = runif(numNeighs, 0.4, 0.6),

					psi_tau = 0.1,
					psi_car = rnorm(numNeighs)
				)
			)

		}

		# some counties are islands
		if (hasIslands) {

			data <- c(
				data,
				list(
					y_island = shape@data[islandIndex, detect],
					N_island = shape@data[islandIndex, effort]
				)
			)

			numStates_island <- length(shape@data[islandIndex, stateProv])

			constants <- c(
				constants,
				list(
					numIslands = numIslands,
					state_island = as.numeric(as.factor(shape@data[islandIndex, stateProv]))
				)
			)

			psi_island <- runif(numIslands, 0.4, 0.6)

			inits <- c(
				inits,
				list(
					p_star_island = runif(numIslands, 0.1, 0.5),
					z_island = rep(1, numIslands),
					psi_island = psi_island,
					logit_psi_island = logit(psi_island),
					psi_islandMean = 0,
					psi_islandTau = 1
				)
			)

		}

		### monitors
		monitors <- names(inits)
		if (hasNeighs) monitors <- c(monitors, 'p_star_neigh')
		if (hasIslands) monitors <- c(monitors, 'p_star_island')

	### model setup
	###############

		code <- if (hasNeighs & hasIslands) {
			.trainBayesODM_pMaxVarByState_psiCar_neighsIslands
		} else if (hasNeighs & !hasIslands) {
			.trainBayesODM_pMaxVarByState_psiCar_neighsOnly
		} else if (!hasNeighs & hasIslands) {
			.trainBayesODM_pMaxVarByState_psiCar_islandsOnly
		}

		### construct and compile model
		###############################

			model <- nimble::nimbleModel(code=code, constants=constants, data=data, inits=inits, check=TRUE)
			flush.console()

			conf <- nimble::configureMCMC(model, monitors = monitors, print = verbose, enableWAIC = TRUE)

			### modify samplers
			node <- 'q'
			conf$removeSamplers(node)
			conf$addSampler(target=node, type='slice')

			if (hasNeighs) {
				node <- 'psi_tau'
				conf$removeSamplers(node)
				conf$addSampler(target=node, type='slice')
			}

			if (hasIslands) {
				node <- 'psi_islandTau'
				conf$removeSamplers(node)
				conf$addSampler(target=node, type='slice')

				# for (i in 1:numIslands) {
					# node <- paste0('logit_psi_island[', i, ']')
					# conf$removeSamplers(node)
					# conf$addSampler(target=node, type='slice')
				# }
			}

			for (i in 1:numStates) {

				node <- paste0('p_max[', i, ']')
				conf$removeSamplers(node)
				conf$addSampler(target=node, type='slice')

				node <- paste0('p_min_star[', i, ']')
				conf$removeSamplers(node)
				conf$addSampler(target=node, type='slice')

			}

			confBuild <- nimble::buildMCMC(conf)
			compiled <- nimble::compileNimble(model, confBuild)

	### variables to ignore when assessing convergence
	##################################################

		exact <- NULL
		# pattern <- c('qConstraint[[]', 'p_star_neigh[[]', 'p_star_island[[]', 'logit_psi_island[[]')
		pattern <- c('qConstraint[[]')

	### use Raftery-Lewis statistic to see how many iterations are needed
	#####################################################################

		if (raf) {

			rl <- rafLewis(
				comp=compiled$confBuild,
				inits = inits,
				niter = niter,
				nburnin = nburnin,
				nsamples = nsamples,
				thin = thin,
				minIter = minIter,
				maxIter = maxIter,
				retry = TRUE,
				exact = exact,
				pattern = pattern,
				propInsufficient = minUnconverged,
				verbose = verbose
			)

			rl$mcmc <- .removeVariablesFromMcmc(rl$mcmc, exact=exact, pattern=pattern)

			rand <- round(1E6 * runif(1))
			tempFile <- paste0('./temp/temp', rand, '.rda')
			save(rl, file=tempFile)
			rm(rl)
			gc()
			load(tempFile)
			file.remove(tempFile)

		}

		if (rl$sufficient) {

			niter <- rl$recIter
			thin <- rl$recThin

			if (coda::niter(rl$mcmc) < nsamples) {
				if (verbose) omnibus::say('Adding iterations to Raftery-Lewis MCMC chain...')
				add <- (niter - burnin - coda::niter(rl$mcmc)) * thin
				rl$mcmc <- addToMcmc(comp = comp, mcmc = rl$mcmc, inits = inits, add = add, thin = thin)
			}

		}

	### add MCMC chains
	###################

		if (nchains > 1 | !raf) {

			startChain <- if (raf) { 2 } else { 1 }
			thisNumChains <- if (raf) { nchains - 1 } else { nchains }

			mcmc <- runMCMC(compiled$confBuild, niter = niter, nburnin = nburnin, thin = thin, nchains = thisNumChains, inits = inits, progressBar = verbose, samplesAsCodaMCMC = TRUE, summary = FALSE, WAIC = FALSE)
			flush.console()

			mcmc <- .removeVariablesFromMcmc(mcmc, exact=exact, pattern=pattern)

		}

		# combine all chains
		nrowRafMcmc <- coda::niter(rl$mcmc)
		nrowNewMcmc <- coda::niter(mcmc)

		if (nrowRafMcmc > nrowNewMcmc) {
			rl$mcmc <- rl$mcmc[1:nrowNewMcmc, ]
			rl$mcmc <- as.mcmc(rl$mcmc)
		}

		mcmc[[1 + coda::nchain(mcmc)]] <- rl$mcmc
		names(mcmc)[coda::nchain(mcmc)] <- paste0('chain', coda::nchain(mcmc))

		save(mcmc, file=tempFile)
		rm(mcmc)
		gc()
		load(tempFile)
		done <- file.remove(tempFile)

	### WAIC and LOO
	################

		# combine chains
		niter <- coda::niter(mcmc) * nchains
		combined <- mcmc[[1]]
		if (nchains > 1) {
			for (chain in 2:nchains) {
				combined <- rbind(combined, mcmc[[chain]])
			}
		}

		# counties with neighborhoods (not islands)
		if (hasNeighs) {

			neigh_ll <- matrix(NA, nrow=niter, ncol=length(data$y_neigh))

			# detection and occupancy
			for (iter in 1:niter) {

				# detection
				z_neigh <- combined[iter, grepl(colnames(combined), pattern='z_neigh[[]'), drop=TRUE]
				p_max <- combined[iter, grepl(colnames(combined), pattern='p_max[[]'), drop=TRUE]
				p_min_star <- combined[iter, grepl(colnames(combined), pattern='p_min_star[[]'), drop=TRUE]

				q <- combined[iter, 'q', drop=TRUE]

				p_max_ll <- dbeta(p_max, 1, 1, log=TRUE)
				p_min_star_ll <- dbeta(p_min_star, 10, 1, log=TRUE)
				q_ll <- dbeta(q, 1, 2, log=TRUE)

				# CAR component
				psi_tau <- combined[iter, 'psi_tau', drop=TRUE]
				psi_tau_ll <- dgamma(psi_tau, 0.001, 0.001, log=TRUE)

				psi_car <- combined[iter, grepl(colnames(combined), pattern='psi_car[[]')]
				psi_car_ll <- dcar_normal(psi_car, adj=data$carAdjCounty[1:constants$lengthAdjCounties], weights=data$carWeightCounty[1:constants$lengthAdjCounties], num=data$carNumCounty[1:constants$numNeighs], tau=psi_tau, c=3, zero_mean=0, log=TRUE)

				p_star_neigh <- combined[iter, grepl(colnames(combined), pattern='p_star_neigh[[]'), drop=TRUE]
				p_neigh <- z_neigh * p_star_neigh + (1 - z_neigh) * q

				neigh_ll[iter, ] <-
					dbinom(data$y_neigh, size=data$N_neigh, prob=p_neigh, log = TRUE) +	# detection
					p_max_ll[constants$state_neigh] +									# state effect
					q_ll +															# false detection
					psi_car_ll														# occupancy ~ CAR

			} # next iteration

		} # has neighbors

		# island counties
		if (hasIslands) {

			island_ll <- matrix(NA, nrow=niter, ncol=length(data$y_island))

			# detection and occupancy
			for (iter in 1:niter) {

				# detection
				z_island <- combined[iter, grepl(colnames(combined), pattern='z_island[[]'), drop=TRUE]
				p_max <- combined[iter, grepl(colnames(combined), pattern='p_max[[]'), drop=TRUE]
				p_min_star <- combined[iter, grepl(colnames(combined), pattern='p_min_star[[]'), drop=TRUE]

				q <- combined[iter, 'q', drop=TRUE]

				p_max_ll <- dbeta(p_max, 1, 1, log=TRUE)
				p_min_star_ll <- dbeta(p_min_star, 10, 1, log=TRUE)
				q_ll <- dbeta(q, 1, 2, log=TRUE)

				p_star_island <- combined[iter, grepl(colnames(combined), pattern='p_star_island[[]'), drop=TRUE]
				p_island <- z_island * p_star_island + (1 - z_island) * q

				psi_islandMean <- combined[iter, 'psi_islandMean', drop=TRUE]
				psi_islandTau <- combined[iter, 'psi_islandTau', drop=TRUE]

				psi_islandMean_ll ~ dnorm(psi_islandMean, 0, sd=1000)
				psi_islandTau_ll ~ dgamma(psi_islandTau, 1, 0.001)

				island_ll[iter, ] <-
					dbinom(data$y_island, size=data$N_island, prob=p_island, log = TRUE) +
					p_max_ll[constants$state_island] +
					p_min_star_ll[constants$state_island] +
					q_ll +															# false detection
					psi_islandMean_ll +												# psi for islands
					psi_islandTau_ll												# psi for islands

			} # next iteration

		} # if has islands

		# LL of neighbors and islands, one row per iteration, one column per county
		ll <- if (hasNeighs & !hasIslands) {
			neigh_ll
		} else if (!hasNeighs & hasIslands) {
			island_ll
		} else {
			cbind(neigh_ll, island_ll)
		}

		waic <- loo::waic(ll)
		loo <- loo::loo(ll, cores=4)

	### process model output
	########################

		mcmc <- .removeVariablesFromMcmc(mcmc, exact=exact, pattern=c('z_neigh[[]', 'z_island[[]'))

		mcmcModel <- .processBayesODM(shape=shape, mcmc=mcmc, effort=effort, detect=detect, neighIndex=neighIndex, islandIndex=islandIndex, pByState=TRUE, stateProv=stateProv)

		meta <- list(
			niter=niter,
			nburnin=nburnin,
			nchains=nchains,
			thin=thin,
			effort=effort,
			detect=detect,
			stateProv=stateProv,
			county=county,
			hasIslands=hasIslands,
			na.rm=na.rm,
			...
		)

		mcmcModel <- c(mcmcModel, list(code=code), meta=list(meta), waic=list(waic), loo=list(loo))
		mcmcModel

}

.trainBayesODM_pMaxVarByState_psiCar_neighsIslands <- nimble::nimbleCode({

	### likelihood for counties with neighborhoods
	for (g in 1:numNeighs) {

		# detection
		y_neigh[g] ~ dbin(p_neigh[g], N_neigh[g])
		p_neigh[g] <- z_neigh[g] * p_star_neigh[g] + (1 - z_neigh[g]) * q
		p_star_neigh[g] ~ dunif(p_min[state_neigh[g]], p_max[state_neigh[g]])

		# occupancy
		z_neigh[g] ~ dbern(psi_neigh[g])
		logit(psi_neigh[g]) <- psi_car[g]

	}

	# county occupancy CAR
	psi_tau ~ dgamma(0.001, 0.001)
	psi_car[1:numNeighs] ~ dcar_normal(adj=carAdjCounty[1:lengthAdjCounties], weights=carWeightCounty[1:lengthAdjCounties], num=carNumCounty[1:numNeighs], tau=psi_tau, c=3, zero_mean=0)

	### likelihood for island counties
	for (h in 1:numIslands) {

		# detection
		y_island[h] ~ dbin(p_island[h], N_island[h])
		p_island[h] <- z_island[h] * p_star_island[h] + (1 - z_island[h]) * q
		p_star_island[h] ~ dunif(p_min[state_island[h]], p_max[state_island[h]])

		# occupancy
		z_island[h] ~ dbern(psi_island[h])
		logit(psi_island[h]) ~ dnorm(psi_islandMean, sd=psi_islandTau)

	}

	psi_islandMean ~ dnorm(0, tau=0.001)
	psi_islandTau ~ dgamma(1, 0.001)

	# false detection
	q ~ dbeta(1, 2)

	# detection
	for (j in 1:numStates) {
		p_max[j] ~ dbeta(1, 1)
		p_min[j] <- p_min_star[j] * p_max[j]
		p_min_star[j] ~ dbeta(10, 1)
		qConstraint[j] ~ dconstraint(p_min[j] > q)
	}

})

.trainBayesODM_pMaxVarByState_psiCar_neighsOnly <- nimble::nimbleCode({

	### likelihood for counties with neighborhoods
	for (g in 1:numNeighs) {

		# detection
		y_neigh[g] ~ dbin(p_neigh[g], N_neigh[g])
		p_neigh[g] <- z_neigh[g] * p_star_neigh[g] + (1 - z_neigh[g]) * q
		p_star_neigh[g] ~ dunif(p_min[state_neigh[g]], p_max[state_neigh[g]])

		# occupancy
		z_neigh[g] ~ dbern(psi_neigh[g])
		logit(psi_neigh[g]) <- psi_car[g]

	}

	# county occupancy CAR
	psi_tau ~ dgamma(0.001, 0.001)
	psi_car[1:numNeighs] ~ dcar_normal(adj=carAdjCounty[1:lengthAdjCounties], weights=carWeightCounty[1:lengthAdjCounties], num=carNumCounty[1:numNeighs], tau=psi_tau, c=3, zero_mean=0)

	# false detection
	q ~ dbeta(1, 2)

	# detection
	for (j in 1:numStates) {
		p_max[j] ~ dbeta(1, 1)
		p_min[j] <- p_min_star[j] * p_max[j]
		p_min_star[j] ~ dbeta(10, 1)
		qConstraint[j] ~ dconstraint(p_min[j] > q)
	}

})


setwd("/Users/robertarnold/Projects/java-realtime-model/src/main/r/simple-lm-model")
load("model.rda")

evaluate <- function(newY) {
  predict.lm(model_fit, newdata=data.frame(y=newY))
}