#------------------------------------------------------------------------------
#	Define constants.
#------------------------------------------------------------------------------

# Name of parameters used when calling optimal.cutpoints.
OPTIMAL_CUTPOINT_PARAMETERS = c("methods", "op.prev", "control")

# Name conversion table between the names of metrics in this package
# and names used in the result of optimal.cutpoints.
NAME_CONVERSION_TABLE <- c(
	cutoff = "threshold", Se = "sensitivity", Sp = "specificity",
	PPV = "ppv", NPV = "npv", DLR.Positive = "dlr.positive",
	DLR.Negative = "dlr.negative", FP = "fp", FN = "fn"
)

#------------------------------------------------------------------------------
#	A reference class calculating metrics for classification models.
#------------------------------------------------------------------------------
classification.metrics.calculator <- R6::R6Class(
	"classification.metrics.calculator",
	private = list(
		cutpoint.options = NULL,
		positive.class = NULL
	)
)

#------------------------------------------------------------------------------
#	Initialize an object from cv.models object.
#
#	Args:
#		object:
#			a cv.models object. Only fields in the fields of this class
#			are used.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"public", "initialize",
	function(object) {
		# Check error.
		if (is.null(object$cutpoint.options$methods)) {
			stop("'methods' should be specified in 'cutpoint.options'.")
		}
		if (length(object$cutpoint.options$methods) == 0) {
			msg = paste(
				"'methods' of 'cutpoint.options' should have at least",
				"one element."
			)
			stop(msg)
		}
		# Copy field from the object.
		private$positive.class <- determine.positive.class(object)
		private$cutpoint.options <- object$cutpoint.options
	}
)

#------------------------------------------------------------------------------
#	Get probability from the result of cross validation.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "get.probability",
	function(fit) {
		return(fit$prediction[, private$positive.class])
	}
)

#------------------------------------------------------------------------------
#	Get binary response from the result of cross validation.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "get.binary.response",
	function(fit) {
		return(as.numeric(fit$response == private$positive.class))
	}
)

#------------------------------------------------------------------------------
#	Prepare arguments for optimal.cutpoints.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "prepare.optimal.cutpoints.args",
	function(fit) {
		# Prepare options for optimal.cutpoints().
		args <- private$cutpoint.options[OPTIMAL_CUTPOINT_PARAMETERS]
		args$X <- prediction ~ response
		args$data <- data.frame(
			response = private$get.binary.response(fit),
			prediction = private$get.probability(fit)
		)
		args$ci.fit <- FALSE
		# Because we can specify only negative class in optimal.cutpoints(),
		# using the following option to specify positive class.
		args$tag.healthy <- 0
		return(args)
	}
)

#------------------------------------------------------------------------------
#	Run optimal.cutpoints.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "run.optimal.cutpoints",
	function(fit) {
		args <- private$prepare.optimal.cutpoints.args(fit)
		result <- do.call(OptimalCutpoints::optimal.cutpoints, args)
		return(result)
	}
)

#------------------------------------------------------------------------------
#	Parse result of optimal.cutpoints.
#
#	Args:
#		object:
#			an object of optimal.cutpoints.
#		method:
#			a method for which result of optimal.cutpoints is parsed.
#
#	Returns:
#		a matrix of 1 row with each column represents each metric.
#			matrix(threshold, sensitivity, ...)
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "parse.optimal.cutpoints.result",
	function(object, method) {
		# Extract threshold and metrics from the result of optimal.cutpoints.
		# Because field name "Global" is only used for the first method,
		# access element of list by index (1) instead of name ("Global").
		cutoff <- object[[method]][[1]]$optimal.cutoff
		if (any(sapply(cutoff, length) > 2)) {
			# Not sure there is a possibility to be here.
			msg <- paste0(
				"Single optimal threshold was not determined ",
				"by specified settings.\n",
				"The first threshold was used for further calculation.\n",
				"If this is a problem, change the 'cutpoint.options' option\n",
				"of the cv.models to find single optimal threshold.\n",
				"For the further information, please consult the manual of ",
				"optimal.cutpoitns."
			)
			warning(msg)
			cutoff <- lapply(cutoff, "[", 1)
		}
		# Convert the result to a matrix.
		result <- do.call(cbind, lapply(cutoff, c))
		colnames(result) <- NAME_CONVERSION_TABLE[colnames(result)]
		# Join AUC to the result.
		auc <- object[[method]][[1]]$measures.acc$AUC["AUC"]
		result <- cbind(result, auc = auc)
		return(result)
	}
)

#------------------------------------------------------------------------------
#	Calculate number of true positive (TP).
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.tp",
	function(fit, metrics) {
		n.positive <- sum(private$get.binary.response(fit))
		tp <- n.positive - metrics[, "fn"]
		return(tp)
	}
)

#------------------------------------------------------------------------------
#	Calculate number of true negative (TN).
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.tn",
	function(fit, metrics) {
		bin <- private$get.binary.response(fit)
		n.negative <- length(bin) - sum(bin)
		tn <- n.negative - metrics[, "fp"]
		return(tn)
	}
)

#------------------------------------------------------------------------------
#	Calculate accuracy.
#
#	Args:
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.accuracy",
	function(metrics) {
		tp <- metrics[, "tp"]
		tn <- metrics[, "tn"]
		fp <- metrics[, "fp"]
		fn <- metrics[, "fn"]
		accuracy <- (tp + tn) / (tp + tn + fp + fn)
		return(accuracy)
	}
)

#------------------------------------------------------------------------------
#	Calculate informedness.
#
#	Args:
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.informedness",
	function(metrics) {
		return(metrics[, "sensitivity"] + metrics[, "specificity"] - 1)
	}
)

#------------------------------------------------------------------------------
#	Calculate markedness.
#
#	Args:
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.markedness",
	function(metrics) {
		return(metrics[, "ppv"] + metrics[, "npv"] - 1)
	}
)

#------------------------------------------------------------------------------
#	Calculate Matthew's correlation coefficient (MCC).
#
#	Args:
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.mcc",
	function(metrics) {
		tp <- metrics[, "tp"]
		tn <- metrics[, "tn"]
		fp <- metrics[, "fp"]
		fn <- metrics[, "fn"]
		denominator <- sqrt((tp + fn) * (tp + fp) * (tn + fp) * (tn + fn))
		mcc <- (tp * tn - fp * fn) / denominator
		return(mcc)
	}
)

#------------------------------------------------------------------------------
#	Calculate log-likelihood.
#
#	Original program was obtained from Lawson et al. 2014.
#	Prevalence, thresholds and the performance of presence-absence models.
#	Methods in Ecology and Evolution 5:54-64.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.loglik",
	function(fit) {
		p <- private$get.probability(fit)
		y <- private$get.binary.response(fit)
		loglik <- sum(log(p * y + (1 - p) * (1 - y)))
		return(loglik)
	}
)

#------------------------------------------------------------------------------
#	Calculate Likelihood based R squared.
#
#	Original program was obtained from Lawson et al. 2014.
#	Prevalence, thresholds and the performance of presence-absence models.
#	Methods in Ecology and Evolution 5:54-64.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response" and "prediction" fields.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.r.squared.loglik",
	function(fit) {
		p <- private$get.probability(fit)
		y <- private$get.binary.response(fit)
		loglik.p <- sum(log(p * y + (1 - p) * (1 - y)))
		loglik.n <- sum(log(mean(p) * y + (1 - mean(p)) * (1 - y)))
		rsq <- (loglik.p - loglik.n) / (1 - loglik.n)
		return(rsq)
	}
)

#------------------------------------------------------------------------------
#	Calculate Cohen's Kappa statistic.
#
#	https://en.wikipedia.org/wiki/Cohen%27s_kappa
#
#						response
#						TRUE	FALSE
#	predicted	TRUE	tp: a	fp: b
#				FALSE	fn: c	fn: d
#
#	Args:
#		metrics:
#			result of 'parse.optimal.cutpoints.result' method.
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calc.kappa",
	function(metrics) {
		tp <- metrics[, "tp"]
		tn <- metrics[, "tn"]
		fp <- metrics[, "fp"]
		fn <- metrics[, "fn"]
		n <- tp + tn + fp + fn
		po = (tp + tn) / n
		pe.true = (tp + fp) / n * (tp + fn) / n
		pe.false = (fn + tn) / n * (fp + tn) / n
		pe = pe.true + pe.false
		kappa = (po - pe) / (1 - pe)
		return(kappa)
	}
)

#------------------------------------------------------------------------------
#	Calculate all metrics for single method of optimal.cutpoints.
#
#	Args:
#		method:
#			a method by which result is calculated.
#		object:
#			cv.models object.
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#
#	Returns:
#		a matrix of 1 row with each column represents each metric.
#			matrix(threshold, sensitivity, ...)
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"private", "calculate.metrics.for.single.method",
	function(method, object, fit) {
		# Calculate metrics using optimal.cutpoints.
		metrics <- private$parse.optimal.cutpoints.result(object, method)
		# Calculate TP and TN first.
		metrics <- cbind(
			metrics,
			tp = private$calc.tp(fit, metrics),
			tn = private$calc.tn(fit, metrics)
		)
		# Calculate other metrics including that depend on TP and TN.
		metrics <- cbind(
			metrics,
			accuracy = private$calc.accuracy(metrics),
			informedness = private$calc.informedness(metrics),
			markedness = private$calc.markedness(metrics),
			mcc = private$calc.mcc(metrics),
			loglik = private$calc.loglik(fit),
			rsq.loglik = private$calc.r.squared.loglik(fit),
			kappa = private$calc.kappa(metrics)
		)
		rownames(metrics) <- NULL
		return(metrics)
	}
)

#------------------------------------------------------------------------------
#	Calculate all metrics.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#
#	Returns:
#		list(
#			method1 = matrix(threshold, sensitivity, ...),
#			method2 = matrix(threshold, sensitivity, ...),
#			...
#		)
#------------------------------------------------------------------------------
classification.metrics.calculator$set(
	"public", "calculate.metrics",
	function(fit) {
		oc.result <- private$run.optimal.cutpoints(fit)
		methods <- private$cutpoint.options$methods
		metrics <- lapply(
			methods, private$calculate.metrics.for.single.method,
			oc.result, fit
		)
		names(metrics) <- private$cutpoint.options$methods
		return(metrics)
	}
)


# /* !/usr/bin/Rscript */

#' # Titanic Data Analysis
#' This file is the main entry point into the analysis, which is broken
#' down by concern to aid maintenance and extensibility.
#'
#' - *clean.r*    -- Data pre-processing
#' - *explore.r*  -- Data inspection
#' - *create.r*   -- Feature engineering
#' - *model.r*    -- Model fitting
#' - *validate.r* -- Model validation
#'
#' ## Setup
#' Prep the R environment:
#' - Suppress package messages and warnings when generating Knitr docs
#' - Teardown previous user vars in workspace
#' - Set working directory to script directory
#' - Reset plot setup
#' - Set global seed value
#' - load dependencies
# /*
writeLines('Beginning Titanic Data Analysis')
writeLines('-------------')
writeLines('\nStart: Reset workspace, load dependencies & source data')
# */

#+ suppress-warnings, include = FALSE
if (isTRUE(getOption("knitr.in.progress"))) {
  knitr::opts_chunk$set(message = FALSE, warning = FALSE)
} else {
  setwd(dirname(sys.frame(1)$ofile))
}

rm(list=ls())
par(mfrow=c(1,1))
SEED <- 83;

library(Amelia)        # for missmap()
library(tree)          # for exploring
library(caret)         # for modelling
library(caretEnsemble) # for modelling
library(discern)       # for analysis - install_github('andybeeching/discern')

#' ### Obtain data
#' Kaggle doesn't permit direct downloads, so assume manually placed in
#' the "data" directory. Additionally, save the data as a fresh
#' workspace.
# TRAIN_DATA_URL <- "https://www.kaggle.com/c/titanic-gettingStarted/download/train.csv"
# TEST_DATA_URL  <- "https://www.kaggle.com/c/titanic-gettingStarted/download/test.csv"
# download.file(TRAIN_DATA_URL, destfile="../data/train.csv", method="curl")
# download.file(TEST_DATA_URL, destfile="../data/test.csv", method="curl")
ts <- date()
raw <- read.csv('../data/train.csv')
test <- read.csv('../data/test.csv')

# /*
# reference modules to prepare data for modelling
#  - NOTE: model.r and analyse.r generally used independently due to
#    runtime cost of training models and running validation tests.
# */
if (isTRUE(getOption("knitr.in.progress"))) {
  knitr::spin_child('clean.r')
  knitr::spin_child('explore.r')
  knitr::spin_child('create.r')
  knitr::spin_child('model.r')
  knitr::spin_child('validate.r')
} else {
  source('clean.r')
  source('explore.r')
  source('create.r')
  source('model.r')
  source('validate.r')
}

#' ### Prediction
#' Predict the response variable *Survived* for the original test
#' dataset. Through submission the best result was in fact random
#' forest, so this is the model referenced in the script.
Survived <- predict(rfFit, newdata = test.munged)

#' Re-level vector to binary response, associate with passenger ID,
#' and write CSV file.
Survived <- round(Survived)
levels(Survived) <- c(0, 1)
output <- as.data.frame(Survived)
output$PassengerId <- test$PassengerId
write.csv(output[,c("PassengerId", "Survived")],
          file="../Titanic_predictions.csv", row.names=FALSE, quote=FALSE)


#' @title make.xyz
#' @description couldn't accurately describe
#' @param \code{x}
#' @param \code{y}
#' @param \code{z}
#' @param \code{group}
#' @param \code{FUN}
#' @family  data structures
#' @keywords manip
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
make.xyz <- function (x, y, z, group, FUN = sum, ...)
{
    Z <- tapply(z, list(paste(x, y, sep = ", "), group), FUN,
        ...)
    Z <- ifelse(is.na(Z), 0, Z)
    XY <- rownames(Z)
    tempfun <- function(XY, i) {
        as.numeric(unlist(lapply(strsplit(XY, ", "), function(x) x[i])))
    }
    X <- tempfun(XY, 1)
    Y <- tempfun(XY, 2)
    return(list(x = X, y = Y, z = Z))
}


# In RStudio, Ctrl+A then Run

library(ggplot2)
library(dplyr)

setwd("~/GitHub/nzpolls/graphing") # replace with own working directory

# Read data
csvData <- read.csv("local-data.csv")
pollingData <- arrange(csvData, desc(as.Date(endDate, '%Y-%m-%d')))

# Plot data
spansize <- 0.65 # higher = smoother
ggplot(pollingData, aes(x = as.Date(endDate, '%Y-%m-%d'))) +
  theme_bw() +

  # Labour
  geom_point(aes(y = LAB, colour = "LAB"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = LAB, colour = "LAB"), span = spansize, se = FALSE) +
  # National
  geom_point(aes(y = NAT, colour = "NAT"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = NAT, colour = "NAT"), span = spansize, se = FALSE) +
  # Green
  geom_point(aes(y = GRN, colour = "GRN"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = GRN, colour = "GRN"), span = spansize, se = FALSE) +
  # ACT
  geom_point(aes(y = ACT, colour = "ACT"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = ACT, colour = "ACT"), span = spansize, se = FALSE) +
  # NZ First
  geom_point(aes(y = NZF, colour = "NZF"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = NZF, colour = "NZF"), span = spansize, se = FALSE) +
  # Maori
  geom_point(aes(y = MRI, colour = "MRI"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = MRI, colour = "MRI"), span = spansize, se = FALSE) +
  # TOP
  geom_point(aes(y = TOP, colour = "TOP"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = TOP, colour = "TOP"), span = spansize, se = FALSE) +
  # New Conservative
  geom_point(aes(y = NCP, colour = "NCP"), size = 2, alpha = 0.3) +
  geom_smooth(aes(y = NCP, colour = "NCP"), span = spansize, se = FALSE) +

  # Y-axis
  scale_y_continuous(limits = c(0, 55), breaks = c(0, 5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60), minor_breaks = waiver(), expand = c(0, 0)) +
  # X-axis
  scale_x_date(date_breaks = "4 months", date_labels = "%b '%y", minor_breaks = "1 month") +
  # Axis styling
  theme(
    plot.background = element_rect(fill = "white", color = NA),
    axis.text.x = element_text(angle = 0, vjust = 0.5, size = 10),
    axis.text.y = element_text(size = 12),
    axis.title.y = element_text(size = 12)
  ) +
  # Axis labels
  labs(y = "Party vote (%)", x = NULL) +
  # Colors and key
  scale_color_manual(
    name = "",
    # Legend
    labels = c(
      "LAB" = "Labour",
      "NAT" = "National",
      "ACT",
      "GRN" = "Greens",
      "NZF" = "NZ First",
      "MRI" = "Maori",
      "TOP" = "Opportunities",
      "NCP" = "New Conservative"
    ),
    # Color mapping
    values = c(
      "LAB" = "#D82A20",
      "NAT" = "#004278",
      "ACT" = "#FDE401",
      "GRN" = "#098137",
      "NZF" = "#000000",
      "MRI" = "#B2001A",
      "TOP" = "#32DAC3",
      "NCP" = "#00AEEF"
    )
  ) +
  theme(
    legend.position = "bottom",
    legend.text = element_text(size = 12)
  )

# Save as 800x500 SVG


clomin <- function(t, rh, wind, trad) {
    .Call('biometeoR_clomin', PACKAGE = 'biometeoR', t, rh, wind, trad)
}


## Main fitting function.
## - Arguments:
##   - capthist:     Capture history matrix.
##   - ids:          A vector of IDs, where each element indicates which individual is associated with each capture history.
##   - traps:        Matrix of detector locations.
##   - mask:         Mask object with points for numerical integration over activity centre locations. Must include an attribute called "area", providing the area covered by a single point.
##   - detfn:        The detection function to use; either "hn" (halfnormal) or "hhn" (hazard halfnormal). If signal strengths are provided, then this argument is ignored and a signal strength detection function is used.
##   - start:        A named vector of start values for numerical maximisation. See the model parameters below for names.
##   - toa:          Time of arrival matrix in the same structure as the capthist object (optional).
##   - ss:           Signal strength matrix in the same structure as the capthist object (optional).
##   - speed_sound:  The speed of sound in metres per second.
##   - ss_cutoff:    A signal strength cutoff. See Stevenson et al (2015).
##
## For multisession models, capthist, ids, traps, mask, toa, and ss can be lists, where each component of the list corresponds to a single session.
##
## Model parameters:
##
## Mandatory:
## - D:         Animals per hectare.
## - lambda:    Expected number of calls per individual.
##
## When using the halfnormal detection function:
## - g0:        Detection function intercept.
## - sigma:     Detection function spatial scale.
##
## When using the hazard halfnormal detection function:
## - lambda0:   Detection function intercept on the hazard scale.
## - sigma:     Detection function spatial scale.
##
## When time-of-arrival data are provided:
## - sigma_toa: Measurement error of times-of-arrival.
##
## When signal strength data are provided:
## - b0_ss:     Source signal strength.
## - b1_ss:     Signal strength loss per metre.
## - sigma_ss:  Measurement error of signal strengths.

cuerate.scr.fit <- function(capthist, ids, traps, mask, detfn = NULL, start, toa = NULL, ss = NULL , speed_sound = 330, ss_cutoff = 0, trace = FALSE){
    ## Indicator for whether or not signal strengths are used.
    use_ss <- !is.null(ss)
    ## Indicator for whether or not times of arrival are used.
    use_toa <- !is.null(toa)
    if (is.list(capthist)){
        multi.sess <- TRUE
    } else {
        multi.sess <- FALSE
        capthist <- list(capthist)
        ids <- list(ids)
        traps <- list(traps)
        mask <- list(mask)
        if (use_toa){
            toa <- list(toa)
        }
        if (use_ss){
            ss <- list(ss)
        }
    }
    n.sessions <- length(capthist)
    aMask <- maskDists <- toa_ssq <- vector("list", n.sessions)
    if (!use_toa){
        toa <- vector("list", n.sessions)
    }
    if (!use_ss){
        ss <- vector("list", n.sessions)
    }
    for (i in 1:n.sessions){
        ## ids must be 1:N animals.
        ids[[i]] = as.numeric(factor(ids[[i]]))
        ## Area of a single mask point.
        aMask[[i]] <- attr(mask[[i]], "area")

        ## Calculating distances between mask points and detectors.
        maskDists[[i]] <- eucdist(mask[[i]], traps[[i]])
        if (use_toa){
            ## Creating TOA sum of squares matrix.
            toa_ssq[[i]] <- make_toa_ssq(toa[[i]], eucdist(traps[[i]], mask[[i]]), speed_sound)
        } else {
            ## Dummy objects if not used.
            toa[[i]] <- toa_ssq[[i]] <- matrix(0, nrow = 1, ncol = 1)
        }
        if (!use_ss){
            ss[[i]] <- matrix(0, nrow = 1, ncol = 1)
        }
    }
    ## Indicator for detection function.
    if (is.null(detfn) & !use_ss){
        stop("A detection function must be selected.")
    }
    if (use_ss){
        if (!is.null(detfn)){
            warning("The choice of detection function is being ignored because signal strengths have been provided.")
        }
        detfn <- "ss"
        hn <- FALSE
    } else if (detfn == "hn"){
        hn <- TRUE
    } else if (detfn == "hhn"){
        hn <- FALSE
    } else {
        stop("The argument detfn must either be 'hn' or 'hhn'.")
    }
    ## Converting parameters to link scale.
    start.link <- numeric(6)
    names(start.link) <- c("D", "df1", "df2", "lambda", "sigma_toa", "sigma_ss")
    start.link["D"] <- log(start["D"])
    start.link["lambda"] <- log(start["lambda"])
    if (use_ss){
        names(start.link)[c(2, 3)] <- c("b0_ss", "b1_ss")
        start.link["b0_ss"] <- log(start["b0_ss"])
        start.link["b1_ss"] <- log(start["b1_ss"])
        start.link["sigma_ss"] <- log(start["sigma_ss"])
    } else if (hn){
        names(start.link)[c(2, 3)] <- c("g0", "sigma")
        start.link["g0"] <- qlogis(start["g0"])
        start.link["sigma"] <- log(start["sigma"])
    } else {
        names(start.link)[c(2, 3)] <- c("lambda0", "sigma")
        start.link["lambda0"] <- log(start["lambda0"])
        start.link["sigma"] <- log(start["sigma"])
    }
    if (use_toa){
        start.link["sigma_toa"] <- log(start["sigma_toa"])
    }
    start <- c(start[1:4], start["sigma_toa"][use_toa], start["sigma_ss"][use_ss])
    start.link <- c(start.link[1:4], start.link["sigma_toa"][use_toa], start.link["sigma_ss"][use_ss])
    n.pars <- length(start)
    par.names <- names(start)
    ## Fitting model.
    fit <- nlminb(start.link, scr.nll.cuerate.multi,
                  caps = capthist,
                  aMask = aMask,
                  maskDists = maskDists,
                  ID = ids,
                  toa = toa,
                  toa_ssq = toa_ssq,
                  use_toa = use_toa,
                  ss = ss,
                  use_ss = use_ss,
                  ss_cutoff = ss_cutoff,
                  hn = hn,
                  trace = trace,
                  par_names = par.names)
    ## Approximating Hessian.
    hess <- optimHess(fit$par, scr.nll.cuerate.multi,
                      caps = capthist,
                      aMask = aMask,
                      maskDists = maskDists,
                      ID = ids,
                      toa = toa,
                      toa_ssq = toa_ssq,
                      use_toa = use_toa,
                      ss = ss,
                      ss_cutoff = ss_cutoff,
                      use_ss = use_ss,
                      hn = hn,
                      trace = trace,
                      par_names = par.names)

    ## Calculating confidence intervals
    ## - Using the (sqrt of) diagonals of (-ve) Hessian obtained from optimHess
    ##    - i.e. Information matrix
    ## - Wald CIs calculated by sapply() loop
    ##    - Loops through each of fitted parameters and calculates lower/upper bounds
    ## Note: fitted pars must be on LINK scale
    ##     : if matrix is singular, none of the SEs or CIs are calculated (inherits/try statement)
    fittedPars = fit$par
    names(fittedPars) <- par.names
    if(inherits(try(solve(hess), silent = TRUE), "try-error")) {
        ## Hessian is singular
        warning("Warning: singular hessian")
        ## SE and Wald CIs not calculated
        se = NA
        waldCI = matrix(NA, nrow = length(fittedPars), ncol = 2)
        ## But columns still need to be returned (if/when simulations are run)
        cnames = c("Estimate", "SE", "Lower", "Upper")
    } else {
        ## Calculating basic Wald CIs
        se = sqrt(diag(solve(hess)))
        waldCI.link = t(sapply(1:length(fittedPars),
                               function(i) fittedPars[i] + (c(-1, 1) * (qnorm(0.975) * se[i]))))
        G.mult <- numeric(n.pars)
        waldCI <- 0*waldCI.link
        ## Back-transforming the confidence limits.
        for (i in par.names){
            if (i %in% c("D", "b0_ss", "b1_ss", "sigma_ss", "lambda0", "sigma", "lambda", "sigma_toa")){
                waldCI[par.names == i, ] <- exp(waldCI.link[par.names == i, ])
                G.mult[par.names == i] <- exp(fittedPars[i])
                fittedPars[i] <- exp(fittedPars[i])
            }
            if (i == "g0"){
                waldCI[par.names == i, ] <- plogis(waldCI.link[par.names == i, ])
                G.mult[par.names == i] <- dlogis(fittedPars[i])
                fittedPars[i] <- plogis(fittedPars[i])
            }
        }
        ## Using the delta method to get the standard errors
        ## - G = jacobian matrix of partial derivatives of back-transformed
        ##    - i.e. log(D) -> exp(D) -- deriv. --> exp(D)
        ##    - Note: 1st deriv of plogis (CDF) = dlogis (PDF)
        G = diag(length(fittedPars)) * G.mult
        se = sqrt(diag(G %*% solve(hess) %*% t(G)))
    }
    results = cbind(fittedPars, se, waldCI)
    dimnames(results) = list(par.names, c("Estimate", "SE", "Lower", "Upper"))
    ## Returning a list with everything.
    list(results = results, capthist = capthist,
         mask = mask, aMask = aMask, maskDists = maskDists,
         speed_sound = speed_sound, ids = ids,
         traps = traps, detfn = detfn, toa = toa, toa_ssq = toa_ssq, hess = hess)

}

scr.nll.cuerate.multi <- function(pars, caps, aMask, maskDists, ID, toa, toa_ssq,
                                  use_toa, ss, use_ss, ss_cutoff, hn, trace, par_names){
    n.sessions <- length(caps)
    sess.nll <- numeric(n.sessions)
    for (i in 1:n.sessions){
        sess.nll[i] <- scr_nll_cuerate(pars, caps[[i]], aMask[[i]], maskDists[[i]],
                                       ID[[i]], toa[[i]], toa_ssq[[i]], use_toa, ss[[i]],
                                       use_ss, ss_cutoff, hn, trace, par_names)
    }
    sum(sess.nll)
}


# Run init.r before other scripts
rm(list=ls())
 # for use in R console.
 # set own relevant directory if working in R console, otherwise ignore if in terminal
setwd("/Users/davidbeauchesne/Dropbox/PhD/PhD_obj2/Structure_Comm_EGSL/EGSL_species_distribution")
# -----------------------------------------------------------------------------
# PROJECT:
#    Evaluating the structure of the communities of the estuary
#    and gulf of St.Lawrence
# -----------------------------------------------------------------------------

# Studying the HMSC package, contact is G. Blanchet for inquiries

# Dependencies
    library(Rcpp)
    library(RcppArmadillo)
    library(coda)

# Installing the package
    # library(devtools)
    # install_github("guiblanchet/HMSC")
    library(HMSC)

# Other libraries
    # install.packages('beanplot', dependencies = T)
    # install.packages('corrplot', dependencies = T)
    # install.packages('circlize', dependencies = T)
    library(beanplot)
    library(corrplot)
    library(circlize)

# First part of the workflow:
    # 1. Setting up an HMSC object by dening the model structure (e.g. whether traits or random effects are to be included) and organizing the data (typically imported from les with standard R commands).
    # 2. Dening the priors required for Bayesian inference.
    # 3. Initiating the model parameters
    # 4. Running the actual estimation scheme. This involves setting the Markov chain Monte Carlo (MCMC) sampler (e.g. by dening the number of iterations and how they will be thinned). As running the estimation scheme may take some time, we recommend the user to save the HMSC object to a le outside of R (e.g. called \model.RData"). This object includes the model structure, the data, and the full posterior distribution.

# Second part of the workflow:
    # No set order, but the user might typically wish to do the following:
        # - Assess the convergence of the MCMC chains,
        # - Produce posterior summaries (e.g. posterior means and quantiles) such as tables or plots,
        # - Measure the explanatory power of the model,
        # - Perform a variance partitioning among the fixed and random effects,
        # - Make predictions.

# Structure of the HMSC model
    # For ecologically meaningful analyses, the minimal set of data needed are either of the following:
        # 1. The occurrence matrix for one species as well as the environmental covariate matrix, in which case the HMSC model corresponds to a traditional single-species model.
        # 2. The occurrence matrix for several species, in which case the HMSC model corresponds to a model-based ordination.

# Formatting data
    # species: numeric values
    # environmental covariates: numeric values
    # random effects: factor if single random effect, data frame if multiple random effects
    # traits: numeric values
    # phylogeny: square symmetric correlation or covariance matrix
    # autocorrelated random effect: either a data frame with the first column a factor while the other columns are spatial or temporal coordinates or a list of data frame following the structure presented previously if there are multiple autocorrelated random effects.

    # Typically highly recommended to scale (center and divide by the standard deviation) the environmental covariates and the traits so that their mean is zero and their variance one.
        # this removes the potential eects units can have on the parameter estimation
        # the default priors are compatible with the scaled covariates

# Example 1
    # 1. Reading the data
        # Community matrix
        spComm <- read.csv("./documentation/HMSC-data/simulated/Y.csv")
        # Environmental covariates
        env <- read.csv("./documentation/HMSC-data/simulated/X.csv")
        # Random effects
        sitePlot <- read.csv("./documentation/HMSC-data/simulated/Pi.csv")

    # 2. Creating HMSC data
        # Convert all columns of Pi to a factor
        for(i in 1:ncol(sitePlot)) {
            sitePlot[,i] <- as.factor(sitePlot[,i])
        }

        simulEx1 <- as.HMSCdata(Y = spComm, X = env, Random = sitePlot, interceptX = FALSE, scaleX = FALSE)

        # Alternatively, load the data directly. Available for this example, but I will have to do it myself for my own data
        data("simulEx1")

    # 3. Defining prior distribution
        # We are using uninformative priors for this part. However, the user can modify this if desired.
        simulEx1prior <- as.HMSCprior(simulEx1)

    # 4. Setting initial model parameters
        simulEx1param <- as.HMSCparam(simulEx1, simulEx1prior)

    # 5. Setting the values of the true parameters"
        # This is only possible with simulated data for which we know the actual parameter values. Otherwise, it is impossible.
        data("simulParamEx1")

    # 6. Performing the MCMC sampling
        model <- hmsc(simulEx1,
                      param = simulEx1param,
                      priors = simulEx1prior,
                      family = "probit",
                      niter = 10000,
                      nburn = 1000,
                      thin = 10)

        # Simpler version when uninformative priors are sufficient and a priori parameters do not need to be set
        model <- hmsc(simulEx1,
                      family = "probit",
                      niter = 10000,
                      nburn = 1000,
                      thin = 10)

    # 7. Producing MCMC trace and density plots
        # Mixing objects
        mixingParamX <- as.mcmc(model, parameters = "paramX")
        mixingMeansParamX <- as.mcmc(model, parameters = "meansParamX")
        mixingMeansVarX <- as.mcmc(model, parameters = "varX")
        mixingParamLatent <- as.mcmc(model, parameters = "paramLatent")

        plot(mixingMeansParamX, col = "blue")

    # 8. Producing posterior summaries
        # Violin plot
            par(mar=c(6,4,1,1))
            mixingParamXDF <- as.data.frame(mixingParamX)
            beanplot(mixingParamXDF, las = 2)
            points(1:30, as.vector(simulParamEx1$param$paramX), pch=19, col="blue", cex=2)

        # Box plot
            par(mar=c(6,4,1,1))
            boxplot(mixingParamXDF, las = 2)
            points(1:30, as.vector(simulParamEx1$param$paramX), pch=19, col="blue", cex=2)

        # Average
            average <- apply(model$results$estimation$paramX, 1:2, mean)
        # 95% confidence intervals
            CI.025 <- apply(model$results$estimation$paramX, 1:2, quantile, probs = 0.025)
            CI.975 <- apply(model$results$estimation$paramX, 1:2, quantile, probs = 0.975)

        # Summary table
            paramXCITable <- cbind(unlist(as.data.frame(average)),
                                   unlist(as.data.frame(CI.025)),
                                   unlist(as.data.frame(CI.975)))
            colnames(paramXCITable) <- c("average", "lowerCI", "upperCI")
            rownames(paramXCITable) <- paste(rep(colnames(average), each = nrow(average)), "_", rep(rownames(average), ncol(average)), sep="")

            # Print summary table
            paramXCITable

        # Credible intervals
            par(mar=c(7,4,1,1))
            plot(0, 0, xlim = c(1, nrow(paramXCITable)), ylim = range(paramXCITable), type = "n", xlab = "", ylab = "", main="paramX", xaxt="n")
            axis(1,1:30,rownames(paramXCITable),las=2)
            abline(h = 0,col = "grey")
            arrows(x0 = 1:nrow(paramXCITable), x1 = 1:nrow(paramXCITable), y0 = paramXCITable[, 2], y1 = paramXCITable[, 3], code = 3, angle = 90, length = 0.05)
            points(1:nrow(paramXCITable), paramXCITable[,1], pch = 15, cex = 2)
            points(1:nrow(paramXCITable), as.vector(simulParamEx1$param$paramX),col = "blue", pch = 19, cex = 2)

    # 9. Variance partitioning
        variationPart <- variPart(model, c(rep("climate", 2), "habitat"))

        Colour <- c("orange", "blue", "darkgreen", "purple")
        barplot(t(variationPart), col=Colour, las=1)
        legend("bottomleft",
                legend = c(paste("Fixed climate (mean = ", round(mean(variationPart[, 1]), 4)*100, "%)", sep=""),
                           paste("Fixed habitat (mean = ", round(mean(variationPart[, 2]), 4)*100, "%)", sep=""),
                           paste("Random site (mean = ", round(mean(variationPart[, 3]), 4)*100, "%)", sep=""),
                           paste("Random plot (mean = ", round(mean(variationPart[, 4]), 4)*100, "%)", sep="")),
               fill = Colour,
               bg="white")

    # 10. Association networks
        # Extract all estimated associatin matrix
            assoMat <- corRandomEff(model)
        # Average
            siteMean <- apply(assoMat[, , , 1], 1:2, mean)
            plotMean <- apply(assoMat[, , , 2], 1:2, mean)

        #=======================
        ### Associations to draw
        #=======================
        #--------------------
        ### Site level effect
        #--------------------
        # Build matrix of colours for chordDiagram
            siteDrawCol <- matrix(NA, nrow = nrow(siteMean), ncol = ncol(siteMean))
            siteDrawCol[which(siteMean > 0.4, arr.ind=TRUE)]<-"red"
            siteDrawCol[which(siteMean < -0.4, arr.ind=TRUE)]<-"blue"
        # Build matrix of "significance" for corrplot
            siteDraw <- siteDrawCol
            siteDraw[which(!is.na(siteDraw), arr.ind = TRUE)] <- 0
            siteDraw[which(is.na(siteDraw), arr.ind = TRUE)] <- 1
            siteDraw <- matrix(as.numeric(siteDraw), nrow = nrow(siteMean), ncol = ncol(siteMean))
        #--------------------
        ### Plot level effect
        #--------------------
        # Build matrix of colours for chordDiagram
            plotDrawCol <- matrix(NA, nrow = nrow(plotMean), ncol = ncol(plotMean))
            plotDrawCol[which(plotMean > 0.4, arr.ind=TRUE)]<-"red"
            plotDrawCol[which(plotMean < -0.4, arr.ind=TRUE)]<-"blue"
        # Build matrix of "significance" for corrplot
            plotDraw <- plotDrawCol
            plotDraw[which(!is.na(plotDraw), arr.ind = TRUE)] <- 0
            plotDraw[which(is.na(plotDraw), arr.ind = TRUE)] <- 1
            plotDraw <- matrix(as.numeric(plotDraw), nrow = nrow(plotMean), ncol = ncol(plotMean))

        # plotDraw plots
            par(mfrow=c(1,2))
            # Matrix plot
            Colour <- colorRampPalette(c("blue", "white", "red"))(200)
            corrplot::corrplot(siteMean, method = "color", col = Colour, type = "lower", diag = FALSE, p.mat = siteDraw, tl.srt = 45)
            # Chord diagram
            circlize::chordDiagram(siteMean, symmetric = TRUE, annotationTrack = c("name", "grid"), grid.col = "grey", col = siteDrawCol)

        # siteDraw plots
            par(mfrow=c(1,2))
            # Matrix plot
            Colour <- colorRampPalette(c("blue", "white", "red"))(200)
            corrplot::corrplot(plotMean, method = "color", col = Colour, type = "lower", diag = FALSE, p.mat = plotDraw, tl.srt = 45)
            # Chord diagram
            circlize::chordDiagram(plotMean, symmetric = TRUE, annotationTrack = c("name", "grid"), grid.col = "grey", col = plotDrawCol)

    # 11. Computing the explanatory power of the model
        # Prevalence
            prevSp <- colSums(simulEx1$Y)
        # Coefficient of multiple determination
            R2 <- Rsquared(model, averageSp = FALSE)
            R2comm <- Rsquared(model, averageSp = TRUE)
        # Draw figure
            par(mar=c(5,6,0.5,0.5))
            plot(prevSp, R2, xlab = "Prevalence", ylab = expression(R^2), pch=19, las=1,cex.lab = 2)
            abline(h = R2comm, col = "blue", lwd = 2)

        # Extract all MCMC of paramX
            model$results$estimation$paramX

        ### Full joint probability distribution
            fullPost <- jposterior(model)

    # 12. Generating predictions for training data
        # predictions that are not conditional on the occurrences of other species
            predTrain <- predict(model)

    #13. Generating predictions for new data
        # New environmental covariates
            newPred <- 100
            nEnv <- ncol(simulEx1$X)
            Xnew <- matrix(nrow = newPred, ncol = nEnv)
            colnames(Xnew) <- colnames(simulEx1$X)
            Xnew[, 1] <- 1
            Xnew[, 2] <- mean(simulEx1$X[, 2])
            Xnew[, 3] <- seq(min(simulEx1$X[, 3]), max(simulEx1$X[, 3]), length = newPred)

        # New site- and plot-level random effect
            RandomSel <- sample(200, 100)
            RandomNew <- simulEx1$Random[RandomSel, ]
            for(i in 1:ncol(RandomNew)) {
                RandomNew[, i] <- as.factor(as.character(RandomNew[, i]))
            }
            colnames(RandomNew) <- colnames(simulEx1$Random)

        # Organize the data into an HMSCdata object
            dataVal <- as.HMSCdata(X = Xnew, Random = RandomNew, scaleX = FALSE, interceptX = FALSE)

        # Generate predictions
            predVal <- predict(model, newdata = dataVal)

        # Plot predictions
            plot(0, 0, type="n", xlim = range(dataVal$X[, 3]), ylim = c(0, 1),
                 xlab = "Environmental covariate 3",
                 ylab = "Probability of occurrence")
            Colours <- rainbow(ncol(predVal))
            for(i in 1:ncol(predVal)) {
                lines(dataVal$X[, 3], predVal[, i], col = Colours[i], lwd=3)
            }


#Assign spatial products to Delgado data.
#Climate from worldclim2. N-dep from NADP.
#These are based on functions written by Colin.
rm(list = ls())
library(data.table)
source('paths.r')
source('NEFI_functions/extract_ndep.r')
source('NEFI_functions/worldclim2_grab.r')
source('NEFI_functions/arid_extract.r')
source('NEFI_functions/extract_pH.r')
source('NEFI_functions/extract_npp.r')
source('NEFI_functions/extract_ndep_global.r')
source('NEFI_functions/extract_EM.r')
source('NEFI_functions/extract_soil_moist.r')

# set output path
output.path <- "/projectnb/talbot-lab-data/NEFI_data/16S/scc_gen/prior_abundance_mapping/Delgado/delgado_metadata_spatial.rds"

d <- read.csv("/projectnb/talbot-lab-data/NEFI_data/16S/scc_gen/prior_abundance_mapping/Delgado/delgado_metadata.csv")

# subset to northern temperate lats
d <- d[d$Latitude < 66.5 & d$Latitude > 23.5,]
# change column names
colnames(d) <- tolower(colnames(d))
setnames(d, c("soil_c", "soil_c_n_ratio", "npp2003_2015","ph"), c("pC", "cn", "NPP","pH"))

# create sample ID
d$sampleID <- paste0("site", d$id_environmental)
rownames(d) <- d$sampleID

# extract % basal area of ecto trees
relEM <- extract_EM(d$latitude, d$longitude)

#extract worldclim.
clim <- worldclim2_grab(d$latitude,d$longitude, worldclim2_folder = "/projectnb/talbot-lab-data/spatial_raster_data/WorldClim2/")
clim$aridity <- arid_extract(d$latitude,d$longitude, folder = "/projectnb/talbot-lab-data/spatial_raster_data/Global_Aridity/aridity/")

moisture <- extract_soil_moist(d$latitude, d$longitude, path = '/projectnb/talbot-lab-data/NEFI_data/covariate_data/soil_moisture_raster/soilmoisture/w001001.adf')
#extract N deposition. Half of these are NA because our Ndep product only covers the United States.
#ignore the warnings.
ndep <- extract_ndep(d$longitude,d$latitude, folder = "/projectnb/talbot-lab-data/spatial_raster_data/CASTNET_Ndep/")

#extract pH
ph_estim <- extract_pH(d$latitude,d$longitude, folder = "/projectnb/talbot-lab-data/spatial_raster_data/SoilGrids_uncertainty/")

# "recent" because the delgado values are averaged over 15 years
NPP_recent     <- extract_npp(d$latitude, d$longitude, path="/projectnb/talbot-lab-data/NEFI_data/covariate_data/NPP/w001001.adf")

# from Ackerman et al.: https://conservancy.umn.edu/handle/11299/197613
ndep.glob <- extract.ndep.global(d$latitude, d$longitude)

#put together all spatial products
spatial <- cbind(relEM, ndep, ph_estim,clim, NPP_recent, ndep.glob, moisture)

#remove any columns from previous spatial extractions, update with new extraction.
d <- as.data.frame(d)
d <- cbind(d,spatial)

#save
saveRDS(d,output.path)