#' Model fitting
#'
#' @description This function fits the occupancy model of Diana et al. (2021).
#' Note that in the following the parameters are described with the notations used in the paper.
#'
#' @param data The data frame containing the data.
#' @param index_year The index of the column containing the year variable.
#' @param index_site The index of the column containing the site variable.
#' @param index_occ The index of the column containing the detections.
#' @param index_spatial_x The index of the x coordinate of the site.
#' @param index_spatial_y The index of the y coordinate of the site.
#' @param covariates_psi_text Indexes of the column of the occupancy probability. To be separated by a comma, eg. "5,6,8". Set to "0" if no covariate is available
#' @param covariates_p_text Indexes of the column of the detection probability.
#' @param prior_psi Prior mean for the occupancy probability
#' @param sigma_psi Standard deviation for the prior on the occupancy probability
#' @param prior_p Prior mean for the detection probability
#' @param sigma_p Standard deviation for the prior on the detection probability
#' @param usingYearDetProb Should the model include year-specific detection probabilities (as opposed to a constant one)?
#' @param usingSpatial Should the model include the auto-correlated spatial effects?
#' @param gridStep Step of the grid to use for the approximation of the auto-correlated spatial effects. Use \code{\link{buildSpatialGrid}} to show the grid for a value of \code{gridStep}.
#' @param storeRE Should the model store the site-specific independent random effects for each iteration (instead of just their mean across all chain)? Not suggested if the number of sites is greater than 1000.
#' @param nchain Number of chains.
#' @param nburn Number of burn-in iterations.
#' @param niter Number of (non burn-in) iterations.
#' @param verbose Should the progress of the MCMC be printed?.
#' @param computeGOF Should the model perform calculations of the goodness of fit?
#'
#' @importFrom magrittr %>%
#'
#' @export
#'
#' @return
#' A list with components:
#'
#' \itemize{
#'
#'  \item \code{modelResults} A list with components:
#'
#'       \describe{
#'
#'       \item{\code{beta_psi_output}}{ An array of dimensions \code{nchain} x \code{niter} x (number of coefficients for
#'       occupancy probability) containing the values of the coefficients of the occupancy probability.
#'      The coefficients are reported in the order (year r.e., space r.e., covariates for time-space interaction,
#'       standard covariates).}
#'
#'       \item{\code{eps_unique_output}}{ if \code{storeRE = T}, an array of dimensions
#'       \code{nchain} x \code{niter} x S containing the values of the site-specific independent random effects
#'        of the occupancy probability. If  \code{storeRE = F}, a matrix of dimensions \code{nchain} x S
#'        containing the mean value of the random effect across a chain.}
#'
#'       \item{\code{beta_p_output}}{ An array of dimensions \code{nchain} x \code{niter} x (number of coefficients for
#'       detection probability) containing the values of the coefficients of the detection probability.
#'        The coefficients are reported in the order (intercepts, covariates).}
#'
#'        \item{\code{sigma_T_output}}{ A array of dimensions \code{nchain} x \code{niter} containing the values of
#'        \eqn{\sigma_T}.}
#'
#'        \item{\code{l_T_output}}{ A array of dimensions \code{nchain} x \code{niter} containing the values of
#'        \eqn{l_T}.}
#'
#'        \item{\code{sigma_s_output}}{ A array of dimensions \code{nchain} x \code{niter} containing the values of
#'        \eqn{\sigma_S}.}
#'
#'        \item{\code{l_s_output}}{ A array of dimensions \code{nchain} x \code{niter} containing the values of
#'        \eqn{l_S}.}
#'
#'        \item{\code{sigma_eps_output}}{ A array of dimensions \code{nchain} x \code{niter} containing the values of
#'        \eqn{\sigma_\epsilon}.}
#'
#'        \item{\code{psi_mean_output}}{ A array of dimensions \code{nchain} x \code{niter} containing the values of
#'        the occupancy index.}
#'
#'        \item{\code{GOF_output}}{ A list with components:
#'
#'        \describe{
#'
#'        \item{  \code{gofYear_output} }{An array of dimensions \code{nchain} x \code{niter} x Y containing the values
#'          of the test statistics of yearly detections.}
#'
#'        \item{  \code{gofSpace_output} }{An array of dimensions \code{nchain} x \code{niter} x (M), where M is the number
#'        of regions in the approximation, containing the values of the test statistics of the detections in
#'        each region.}
#'
#'        \item{  \code{trueYearStatistics} }{ A vector containing the true values of the test statistics of the detections
#'         in each year.}
#'
#'        \item{  \code{trueSpaceStatistics} }{ A vector containing the true values of the test statistics of the detections
#'         in each region}
#'
#'        }
#'
#'        }
#'
#'      }
#'
#'
#'       \item \code{dataCharacteristics}: A list with components:
#'
#'       \describe{
#'
#'       \item{\code{Years}}{A vector with the years.}
#'
#'       \item{\code{X_tilde}}{A matrix of dimension M x 2, where M is the number of points chosen in the
#'       spatial approximation, with the location of the points used for the approximation. The points are
#'       arranged in the same as order as in the coefficients vector \code{beta_psi_output}.}
#'
#'       \item{\code{gridStep}}{The width of the grid chosen in the approximation.}
#'
#'       \item{\code{usingSptial}}{Same as in the input.}
#'
#'        \item{\code{usingYearDetProb}}{Same as in the input.}
#'
#'
#'       }
#'  }
#'
#' @examples
#'
#' modelResults <- runModel(sampleData,
#'                          index_year = 1,
#'                          index_site = 2,
#'                          index_occ = 8,
#'                          index_spatial_x = 3,
#'                          index_spatial_y = 4,
#'                          covariates_psi_text = "5",
#'                          covariates_p_text = "6-7",
#'                          usingSpatial = TRUE,
#'                          gridStep = .2,
#'                          nchain = 1,
#'                          nburn = 100,
#'                          niter = 100)
#'
runModel <- function(data, index_year, index_site,
                     index_occ, index_spatial_x = 0, index_spatial_y = 0,
                     covariates_psi_text, covariates_p_text,
                     prior_psi = .5, sigma_psi = 2,
                     prior_p = .5, sigma_p = 2,
                     usingYearDetProb = F,
                     usingSpatial = F, gridStep,
                     storeRE = F, nchain, nburn, niter,
                     verbose = T, computeGOF = T){

  print("Analyzing the data..")

  # CLEAN DATA
  {

    colnames(data)[c(index_year, index_site, index_occ)] <- c("Year","Site","Occ")

    if(usingSpatial){
      colnames(data)[c(index_spatial_x, index_spatial_y)] <- c("X_sp","Y_sp")
    }

    data$Year <- as.numeric(data$Year)

    S <- length(unique(data$Site))
    Y <- length(unique(data$Year))
    years <- sort(unique(data$Year))

    # transform site codes to numbers
    originalsites <- unique(data$Site)
    names(originalsites) <- seq_along(originalsites)
    data$Site <- as.numeric(names(originalsites)[match(data$Site, originalsites)])

    data <- data %>% dplyr::arrange(Site, Year)

    # define data for occupancies

    {
      k_s <- data %>% dplyr::group_by(Year, Site) %>%
        dplyr::summarise(Occupied = as.numeric(sum(Occ) > 0),
                         Visits = dplyr::n()) %>%
        dplyr::arrange(Site, Year)
      k_s <- as.data.frame(k_s)

      # match row in data_p to row in k_s
      indexes_occobs <- rep(1:nrow(k_s), k_s$Visits)

      Occs <- data$Occ
    }

    # covariate for psi

    {

      X_psi <- data[!duplicated(data[,c("Site","Year")]),] %>% dplyr::arrange(Site, Year)

      # year covariates
      {
        X_psi$Year <- as.factor(X_psi$Year)
        X_psi_year <- stats::model.matrix( ~ . - 1, data = X_psi[,c("Year"),drop = F])

        X_y_index <- apply(X_psi_year, 1, function(x) {which(x != 0)})
        X_y_index <- unlist(X_y_index)

      }

      # spatial covariates
      {

        if(usingSpatial){

          X_sp <- X_psi$X_sp
          Y_sp <- X_psi$Y_sp

          uniqueIndexesSite <- which(!duplicated(X_psi$Site))
          X_sp_unique <- X_sp[uniqueIndexesSite]
          Y_sp_unique <- Y_sp[uniqueIndexesSite]
          XY_sp_unique <- cbind(X_sp_unique, Y_sp_unique)

          # build the grid
          X_tilde <- as.matrix(buildGrid(XY_sp_unique, gridStep))
          XY_centers <- findClosestPoint(XY_sp_unique, X_tilde)

          # get rid of unused cells by refinding the grid
          X_tilde <- X_tilde[sort(unique(XY_centers)),]

          # refit
          XY_centers <- findClosestPoint(cbind(X_psi$X_sp,X_psi$Y_sp), X_tilde)
          XY_centers_unique <- findClosestPoint(XY_sp_unique, X_tilde)

          X_psi$Center <- as.factor(XY_centers)
          X_s_index <- XY_centers

          X_psi_s <- stats::model.matrix( ~ . - 1, data = X_psi[,c("Center"),drop = F])

          X_centers <- nrow(X_tilde)

        } else {
          X_centers <- 0
          XY_centers <- NULL
          X_psi_s <- NULL
          XY_sp_unique <- NULL
          X_s_index <- numeric(0)
          X_tilde <- NULL
          gridStep <- NULL
        }

      }

      # time space covariates
      {
        numTimeSpaceCov <- 0

        X_psi_yearcov <- scale(as.numeric(X_psi$Year))
        X_psi_yearcov_values <- sort(unique(X_psi_yearcov))

        if(usingSpatial){

          X_psi_spcov <- cbind(X_sp, Y_sp)

          X_timesp_cov <- cbind(X_psi_yearcov * X_sp, X_psi_yearcov * Y_sp)

          numTimeSpaceCov <- numTimeSpaceCov + 2

        } else {
          X_timesp_cov <- NULL
        }

      }

      # standard covariates
      {

        column_covariate_psi <- ExtractCovariatesFromText(covariates_psi_text)

        nameVariables_psi <- colnames(data)[column_covariate_psi]
        ncov_psi <- length(nameVariables_psi)

        if(ncov_psi > 0){

          X_psi_cov <- stats::model.matrix(~ ., data = X_psi[,column_covariate_psi,drop = F])[,-1]

        }

      }

      X_psi <- cbind(X_psi_year)
      if(usingSpatial) X_psi <- cbind(X_psi, X_psi_s, X_timesp_cov)
      if(ncov_psi > 0) X_psi <- cbind(X_psi, X_psi_cov)

    }

    # covariates for p

    {
      data_p <- data

      column_covariate_p <- ExtractCovariatesFromText(covariates_p_text)

      X_p_cov <- data_p[,column_covariate_p, drop = F]

      ncov_p <- ncol(X_p_cov)

      if(ncov_p > 0){
        nameVariables_p <- colnames(data_p)[column_covariate_p]
      } else {
        nameVariables_p <- c()
      }

      if(usingYearDetProb){

        data_p$Year <- as.factor(data_p$Year)
        X_p_year <- stats::model.matrix( ~ . - 1, data = data_p[,c("Year"),drop = F])

        X_y_index_p <- apply(X_p_year, 1, function(x) {which(x != 0)})
        X_y_index_p <- unlist(X_y_index_p)

        X_p <- X_p_year
      } else {
        X_p <- matrix(1, nrow = nrow(data_p), ncol = 1)
        X_y_index_p <- rep(1, nrow(data_p))
      }

      if(ncov_p > 0){
        X_p <- cbind(X_p, X_p_cov)
      }

      X_p <- as.matrix(X_p)

      p_intercepts <- ifelse(usingYearDetProb, Y, 1)

    }

    # data for GOF

    {

      k_s_all <- data %>% dplyr::arrange(Site, Year)

      trueYearStatistics <- k_s_all %>% dplyr::group_by(Year) %>%
        dplyr::summarise(Detections = sum(Occ)) %>% dplyr::arrange(Year)

      if(usingSpatial){

        k_s_all$SitePatch <- findClosestPoint(cbind(k_s_all$X_sp,k_s_all$Y_sp), X_tilde)

        trueSpaceStatistics <- k_s_all %>% dplyr::group_by(SitePatch) %>%
          dplyr::summarise(Detections = sum(Occ)) %>% dplyr::arrange(SitePatch)

        k_s_all <- k_s_all %>% dplyr::select(SitePatch, Year, ) %>% dplyr::mutate(Present = 0)

      } else {

        k_s_all <- k_s_all %>% dplyr::select(Year) %>% dplyr::mutate(Present = 0)

        trueSpaceStatistics <- NULL
      }

    }
  }

  # ASSIGN THE PRIOR
  {
    print("Setting up the priors")

    # fixed parameters
    {
      phi_psi <- 2
      phi_p <- 2

      a_l_T <- 1
      b_l_T <- 1

      a_sigma_T <- 2
      b_sigma_T <- .25

      a_l_s <- 1
      b_l_s <- 10

      a_sigma_s <- 2
      b_sigma_s <- 1

      a_sigma_eps <- 2
      b_sigma_eps <- .25

      sd_l_T <- .2
      sd_sigma_T <- .2
    }

    sigma_s <- b_sigma_s / (a_sigma_s - 1)
    sigma_T <- b_sigma_T / (a_sigma_T - 1)

    l_T <- a_l_T / b_l_T
    l_s <- a_l_s / b_l_s

    mu_psi <- invLogit(prior_psi)
    mu_p <- invLogit(prior_p)

    # priors on psi

    {

      b_psi <- c(rep(mu_psi,Y), rep(0, ncol(X_psi) - Y))
      B_psi <- matrix(0, nrow = ncol(X_psi), ncol = ncol(X_psi))

      C <- matrix(0, nrow = Y + X_centers, ncol = Y + X_centers)
      C[1:Y, 1:Y] <- K(1:Y,1:Y, sigma_T^2, l_T) + sigma_psi^2
      if(usingSpatial){
        C[Y + 1:X_centers, Y + 1:X_centers] <- K2(X_tilde,X_tilde, sigma_s^2, l_s)
      }

      B_psi[1:(Y + X_centers), 1:(Y + X_centers)] <- C

      B_psi[Y + X_centers + seq_len(numTimeSpaceCov),
            Y + X_centers + seq_len(numTimeSpaceCov)] <- diag(phi_psi^2, nrow = numTimeSpaceCov)

      if(ncov_psi > 0){

        C_covs <- diag(phi_psi^2, nrow = ncov_psi)

        B_psi[(Y + X_centers) + numTimeSpaceCov + 1:ncov_psi,
              (Y + X_centers) + numTimeSpaceCov + 1:ncov_psi] <- C_covs

      }

      inv_B_psi <- solve(B_psi)
    }

    # prior on p

    {
      b_p <- c(rep(mu_p, p_intercepts), rep(0, ncol(X_p) - p_intercepts))
      B_p <- matrix(0, nrow = ncol(X_p), ncol = ncol(X_p))
      diag(B_p)[1:p_intercepts] <- sigma_p^2

      if(ncov_p > 0){

        C <- diag(phi_p^2, nrow = ncov_p)

        B_p[p_intercepts + 1:ncov_p, p_intercepts + 1:ncov_p] <- C

      }

      inv_B_p <- solve(B_p)

    }
  }

  # run MCMC
  {
    # initialize output
    {
      beta_psi_output <- array(NA, dim = c(nchain , niter, ncol(X_psi)),
                               dimnames = list(c(), c(), colnames(X_psi)))

      beta_p_output <- array(NA, dim = c(nchain , niter, ncol(X_p)),
                             dimnames = list(c(), c(), colnames(X_p)))

      l_T_output <- matrix(NA, nrow = nchain, ncol = niter)
      l_s_output <- matrix(NA, nrow = nchain, ncol = niter)
      sigma_T_output <- array(NA, dim = c(nchain, niter))
      sigma_s_output <- array(NA, dim = c(nchain, niter))
      sigma_eps_output <- array(NA, dim = c(nchain, niter))

      psi_mean_output <- array(NA, dim = c(nchain, niter, Y))
      indexUniqueSite <- which(!duplicated(k_s$Site))
      namesUniqueSite <- k_s$Site[indexUniqueSite]

      gofYear_output <- array(NA, dim = c(nchain, niter, Y))
      if(usingSpatial){
        gofSpace_output <- array(NA, dim = c(nchain, niter, nrow(X_tilde)))
      } else {
        gofSpace_output <- NULL
      }

      if(storeRE){
        eps_unique_output <- array(NA, dim = c(nchain, niter, S),
                                   dimnames = list(c(), c(), namesUniqueSite))
      } else {
        eps_unique_output <- matrix(0, nchain , S)
        colnames(eps_unique_output) <- namesUniqueSite
      }

    }

    for (chain in 1:nchain) {

      # initialize parameters
      {

        print("Initializing the parameters")

        beta_psi <- b_psi
        psi <- as.vector(logit(X_psi %*% beta_psi))

        Xbetapsi <- X_psi %*% beta_psi

        beta_p <- b_p
        p <- as.vector(logit(X_p %*% beta_p))

        Xbetap <- X_p %*% beta_p

        eps_s <- rep(0, nrow(k_s))

        z <- rep(NA, nrow(k_s))
        for (i in 1:nrow(k_s)) {
          if(k_s[i,1] == 1){
            z[i] <- 1
          } else {
            z[i] <- stats::rbinom(1, 1, psi[i])
          }
        }

        # presences across each sampling occasion
        z_all <- z[indexes_occobs]

        # hyperparameters
        {
          l_T <- a_l_T / b_l_T
          l_s <- a_l_s / b_l_s

          sigma_T <- b_sigma_T / (a_sigma_T - 1)
          sigma_s <- b_sigma_s / (a_sigma_s - 1)

          sigma_eps <- b_sigma_eps / (a_sigma_eps - 1)

          # precompute parameters to update l_s
          if(usingSpatial){

            length_grid_ls <- 20
            l_s_grid <- seq(0.01, 0.5, length.out = length_grid_ls)
            K_s_grid <- array(NA, dim = c(X_centers, X_centers, length_grid_ls))
            inv_K_s_grid <- array(NA, dim = c(X_centers, X_centers, length_grid_ls))
            diag_K_s_grid <- array(NA, dim = c(X_centers, length_grid_ls))
            inv_chol_K_s_grid <- array(NA, dim = c(X_centers, X_centers, length_grid_ls))

            for (j in 1:length_grid_ls) {
              l_s <- l_s_grid[j]
              K_s_grid[,,j] <- K_l <- K2(X_tilde, X_tilde, 1, l_s) + diag(exp(-10), nrow = nrow(X_tilde))
              diag_K_s_grid[,j] <- FastGP::rcppeigen_get_diag(K_s_grid[,,j])
              inv_K_s_grid[,,j] <- FastGP::rcppeigen_invert_matrix(K_s_grid[,,j])
              inv_chol_K_s_grid[,,j] <- FastGP::rcppeigen_invert_matrix(FastGP::rcppeigen_get_chol(K_s_grid[,,j]))
            }

            l_s <- l_s_grid[length_grid_ls / 2]

          } else {
            l_s_grid <- NULL
            K_s_grid <- NULL
            inv_K_s_grid <- NULL
            diag_K_s_grid <- NULL
            inv_chol_K_s_grid <- NULL
          }

        }

      }

      for (iter in seq_len(nburn + niter)) {

        if(verbose){
          if(iter <= nburn){
            print(paste0("Chain = ",chain," - Burn-in Iteration = ",iter))
          } else {
            print(paste0("Chain = ",chain," - Iteration = ",iter - nburn))
          }
        }
        # print(paste0("l_s = ",l_s," / sigma_s = ",sigma_s,
        #              " / max(beta_psi) = ",max(abs(beta_psi[Y  + 1:X_centers]))))

        # sample z ----

        z <- sample_z_cpp(psi, p, as.matrix(k_s[,3:4]))
        z_all <- z[indexes_occobs]

        # sample psi ----

        list_psi <- update_psi(beta_psi, X_psi, Xbetapsi,
                               b_psi, inv_B_psi,
                               z, k_s, sites, Y, X_centers, ncov_psi,
                               X_y_index, X_s_index, numTimeSpaceCov,
                               usingSpatial, eps_s, sigma_eps)
        psi <- list_psi$psi
        beta_psi <- list_psi$beta
        Omega <- list_psi$Omega
        eps_s <- list_psi$eps_s
        XbetaY <- list_psi$XbetaY
        Xbetas <- list_psi$Xbetas
        Xbeta_cov <- list_psi$Xbeta_cov
        Xbetapsi <- list_psi$Xbeta

        # sample hyperparameters ---------

        list_hyperparameters <- update_hyperparameters(l_T, a_l_T, b_l_T, sd_l_T, sd_sigma_T,
                                                       sigma_T, a_sigma_T, b_sigma_T, Y,
                                                       beta_psi, inv_B_psi,
                                                       b_psi, sigma_psi,
                                                       l_s_grid, K_s_grid, inv_K_s_grid,
                                                       inv_chol_K_s_grid, diag_K_s_grid,
                                                       a_l_s, b_l_s,
                                                       sigma_s, a_sigma_s, b_sigma_s, X_tilde,
                                                       a_sigma_eps, b_sigma_eps,
                                                       usingSpatial,
                                                       XbetaY, Xbetas, Xbeta_cov,
                                                       eps_s, k_s,
                                                       z, X_psi, Omega, X_y_index)
        l_T <- list_hyperparameters$l_T
        sigma_T <- list_hyperparameters$sigma_T
        sigma_s <- list_hyperparameters$sigma_s
        l_s <- list_hyperparameters$l_s
        index_l_s <- list_hyperparameters$index_l_s
        inv_B_psi <- list_hyperparameters$inv_B_psi
        sigma_eps <- list_hyperparameters$sigma_eps

        # sample p ----------------

        if(sum(z) > 0){
          list_p <- update_p(beta_p, Occs, z_all, X_p, b_p, inv_B_p, Xbetap,
                             ncov_p, p_intercepts, X_y_index_p, usingYearDetProb)
          p <- list_p$p
          beta_p <- list_p$beta
          Xbetap <- list_p$Xbeta
        }

        # write parameters  -------------------------------------------------------

        if(iter > nburn){

          beta_psi_output[chain,iter - nburn,] <- beta_psi

          eps_unique <- eps_s[indexUniqueSite]

          if(usingSpatial){
            a_s_unique <- beta_psi[Y + XY_centers_unique] +
              eps_unique
            psi_mean_output[chain,iter - nburn,] <- computeYearEffect(Y, a_s_unique, beta_psi)
          } else {
            psi_mean_output[chain,iter - nburn,] <- logit(beta_psi[1:Y]) + mean(eps_unique)
          }

          if(storeRE){
            eps_unique_output[chain, iter - nburn,] <- eps_s[indexUniqueSite]
          } else {
            eps_unique_output[chain,] <- eps_unique_output[chain,] +
              (1 / niter)  * eps_s[indexUniqueSite]
          }

          sigma_eps_output[chain, iter - nburn] <- sigma_eps

          l_T_output[chain, iter - nburn] <- l_T
          sigma_T_output[chain, iter - nburn] <- sigma_T

          l_s_output[chain, iter - nburn] <- l_s
          sigma_s_output[chain, iter - nburn] <- sigma_s

          beta_p_output[chain,iter - nburn,] <- beta_p

          # GOF
          if (computeGOF) {
            k_s_all$Present <- simulateDetections(p, z_all)

            detectionsByYear <- k_s_all %>% dplyr::group_by(Year) %>%
              dplyr::summarise(Detections = sum(Present))

            gofYear_output[chain,iter - nburn,] <- detectionsByYear$Detections

            if(usingSpatial){

              detectionsByPatch <- k_s_all %>% dplyr::group_by(SitePatch) %>%
                dplyr::summarise(Detections = sum(Present))

              gofSpace_output[chain,iter - nburn,] <- detectionsByPatch$Detections

            }

          }

        }

      }

    }

  }

  # store summaries of the dataset
  {

    dataCharacteristics <- list("Years" = years,
                                "X_tilde" = X_tilde,
                                "originalsites" = originalsites,
                                "gridStep" = gridStep,
                                "XY_sp_unique" = XY_sp_unique,
                                "usingYearDetProb" = usingYearDetProb,
                                "usingSpatial" = usingSpatial,
                                "numTimeSpaceCov" = numTimeSpaceCov,
                                "X_psi_yearcov_values" = X_psi_yearcov_values,
                                "nameVariables_psi" = nameVariables_psi,
                                "nameVariables_p" = nameVariables_p)
  }

  # create model output
  {
    GOF_output <- list(
      "trueYearStatistics" = trueYearStatistics,
      "trueSpaceStatistics" = trueSpaceStatistics,
      "gofYear_output" = gofYear_output,
      "gofSpace_output" = gofSpace_output
    )

    modelOutput <- list(
      "beta_psi_output" = beta_psi_output,
      "eps_unique_output" = eps_unique_output,
      "beta_p_output" = beta_p_output,
      "sigma_T_output" = sigma_T_output,
      "l_T_output" = l_T_output,
      "sigma_s_output" = sigma_s_output,
      "l_s_output" = l_s_output,
      "sigma_eps_output" = sigma_eps_output,
      "psi_mean_output" = psi_mean_output,
      "GOF_output" = GOF_output
    )
  }

  list("dataCharacteristics" = dataCharacteristics,
       "modelOutput" = modelOutput)
}


## Make a joyplot of any scale by any factor variable
# wtib = work tibble (data)
# fctr = factor variable
# fctr_nm = Factor name for axis title
# scl = scale variable
# title = Plot title
# sample_nm = Sample name, e.g., "Vaccines"
# sample_num = sample number for filename (e.g., 2016)
#
# prints the plot to a file with the name format "Joyplot", sample_num, " ", title, ".png", sep = ""

joyplot_scale_by_factor <- function(plot_tib,
                                    fctr, fctr_nm,
                                    scl, scl_nm,
                                    title,
                                    sample_nm, sample_num) {
        shhh(library(ggjoy))
        shhh(library(ggridges))
        shhh(library(scales))
        shhh(library(lubridate))
        ggplot(plot_tib, aes(y = fctr, x = scl)) +
                geom_density_ridges(scale = 4,
                                    aes(fill = fctr),
                                    alpha = 3/4,
                                    na.rm = FALSE,
                                    quantile_lines = TRUE,
                                    quantiles = 2) +
                scale_x_continuous(scl_nm) +
                guides(fill = FALSE, color = FALSE) +
                labs(title = title,
                     y = fctr_nm,
                     x = "How Characteristic",
                     caption = (paste(sample_nm,
                                      today(),
                                      sep = " "))) +
                z_theme()
        plotfile <- paste("Joyplot",
                          " ", title,
                          ".png",
                          sep = "")
        ggsave(plotfile,
               height = 8,
               width = 8,
               dpi = 120,
               type = "cairo-png")
}


###############################################################################
# This program 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 3 of the License, or
# (at your option) any later version.
#
# This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
###############################################################################
# Examples for the R/Finance Presentation
# Copyright (C) 2012  Michael Kapler
#
# For more information please visit my blog at www.SystematicInvestor.wordpress.com
# or drop me a line at TheSystematicInvestor at gmail
###############################################################################

#############################################################################
# Seasonality Analysis - TIME patterns
# R/Finance 2012
###############################################################################
seasonality.test <- function()
{
	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')
	ticker = 'WMT'

	data = getSymbols(ticker, src = 'yahoo', from = '1970-01-01', auto.assign = F)
		data = adjustOHLC(data, use.Adjusted=T)

	data = data['1980::2012:04:07']

	#*****************************************************************
	# Look at the Month of the Year Seasonality
	#******************************************************************
png(filename = 'plot.month.year.seasonality.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	month.year.seasonality(data, ticker)
dev.off()

	#*****************************************************************
	# Look at What seasonally happens in the first 20 days of May
	#******************************************************************
	# Find first day of May: it is one day after the last day of April
	month.ends = endpoints(data, 'months')
		month.ends = month.ends[month.ends > 0 & month.ends < nrow(data)]
		index = which(format(index(data), '%b')[month.ends] == 'Apr')

png(filename = 'plot.time.seasonality.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	layout(1)
	time.seasonality(data, 1 + month.ends[index], 20, ticker)
dev.off()
}

#############################################################################
# Pattern Matching - PRICE patterns
# R/Finance 2012
###############################################################################
pattern.test <- function()
{
	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')
	ticker = 'SPY'

	data = getSymbols(ticker, src = 'yahoo', from = '1970-01-01', auto.assign = F)
		data = adjustOHLC(data, use.Adjusted=T)

	data = data['::2012:04:07']
	#*****************************************************************
	# Find historical Matches similar to the last 90 days of price history
	#******************************************************************
png(filename = 'plot1.time.series.pattern.matching.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	matches = bt.matching.find(Cl(data), main = ticker,	n.query=90, plot=TRUE)
dev.off()

png(filename = 'plot2.time.series.pattern.matching.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	out = bt.matching.overlay(matches, plot=TRUE)
dev.off()

	#*****************************************************************
	# Find Classical Techical Patterns, based on
	# Pattern Matching. Based on Foundations of Technical Analysis
	# by A.W. LO, H. MAMAYSKY, J. WANG
	#******************************************************************
png(filename = 'plot.pattern.matching.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	plot.patterns(data, 190, ticker)
dev.off()
}

#############################################################################
# Month of the Year Seasonality
#' @export
#############################################################################
month.year.seasonality <- function
(
	data,	# xts time series data
	ticker,
	lookback.len = 20*252	# last 20 years of data
)
{
	data = last(data, lookback.len)
		nperiods = nrow(data)

	#*****************************************************************
	# Compute monthly returns
	#******************************************************************
	# find month ends
	month.ends = endpoints(data, 'months')
		month.ends = month.ends[month.ends > 0]

	prices = Cl(data)[month.ends]
	ret = prices / mlag(prices) - 1
		ret = ret[-1]

	ret.by.month = create.monthly.table(ret)

	#*****************************************************************
	# Plot
	#******************************************************************
	data_list = lapply(apply(ret.by.month, 2, list), '[[', 1)
	group.seasonality(data_list, paste(ticker, 'Monthly', join(format(range(index(data)), '%d-%b-%Y'), ' to\n')))

}

#' @export
group.seasonality <- function
(
	data_list,	# data list for each group
	smain,
	...
)
{
	#*****************************************************************
	# Compute group stats
	#******************************************************************
	out = compute.stats( data_list,
		list(Sharpe=function(x) mean(x,na.rm=T)/sd(x,na.rm=T),
			'% Positive'=function(x) sum(x > 0,na.rm=T)/sum(!is.na(x)),
			Min=function(x) min(x,na.rm=T),
			Max=function(x) max(x,na.rm=T),
			Avg=function(x) mean(x,na.rm=T),
			Med=function(x) median(x,na.rm=T),
			StDev=function(x) sd(x,na.rm=T)
			)
		)

	#*****************************************************************
	# Plot
	#******************************************************************
	layout(mat=matrix(1:4, 2, 2, byrow=FALSE))
	par(mar=c(4, 3, 2, 2))
	col = spl('lightgray,red')

	stats.names = spl('Sharpe,% Positive,Min,Avg')
	for(i in stats.names) {
		barplot(100*out[i,], names.arg = colnames(out),
			col=iif(out[i,] > 0, col[1], col[2]),
			main=iif(i == stats.names[1], paste(smain,' ', i, sep=''), i),
			border = 'darkgray',las=2, ...)
		grid(NA,NULL)
		abline(h=0, col='black')
	}
}

#############################################################################
# Time seasonally for given periods
#' @export
###############################################################################
time.seasonality <- function
(
	data,			# xts time series data
	period.starts,	# locations
	period.len,		# number of trading days to examine
	ticker
)
{
	nperiods = len(period.starts)
	dates = index(data)
		ndates = len(dates)

	#*****************************************************************
	# Compute returns, construct trading.days matrix
	#******************************************************************
	prices = Cl(data)
	ret = prices / mlag(prices) - 1
		ret = c( as.double(ret), rep(NA, period.len))

	# 1:period.len by period.starts matrix
	trading.days = sapply(period.starts, function(i) ret[i : (i + period.len - 1)])

	#*****************************************************************
	# Compute stats
	#******************************************************************
	# exclude periods that have insufficient data
	periods.index = 1:nperiods
		temp = count(trading.days)
	periods.index = periods.index[temp > 0.9 * median(temp)]

	# last period
	last.period = trading.days[, nperiods]
		last.period = 100 * ( cumprod(1 + last.period) - 1 )

	# average period
	avg.period = apply(trading.days[, periods.index], 1, mean, na.rm=T)
		avg.period = 100 * ( cumprod(1 + avg.period) - 1 )

	# ranges
	temp = 100*(apply(1 + trading.days[, periods.index], 2, cumprod) - 1)
	quantiles = apply(temp, 1, quantile, probs = c(75, 25)/100, na.rm=T)

	#*****************************************************************
	# Create Plot
	#******************************************************************
	cols = spl('blue,red,gray')

	par(mar=c(4,4,2,1))
	plot(avg.period, type='n', xaxt = 'n', xlim=c(1,period.len),
		ylim=range(avg.period, last.period, quantiles, na.rm=T),
		main = ticker, xlab = 'Trading Days', ylab = 'Avg % Profit/Loss')

	grid()
	axis(1, 1:period.len)

	lines(quantiles[1,], type='l', lwd=2, col=cols[3])
	lines(quantiles[2,], type='l', lwd=2, col=cols[3])

	lines(last.period, type='b', lwd=2, col=cols[2], bg=cols[2], pch=24)
	lines(avg.period, type='b', lwd=2, col=cols[1], bg=cols[1], pch=22)

	first.year = format(dates[period.starts][periods.index[1]], '%Y')
	last.year = format(dates[period.starts][last(periods.index)], '%Y')
	last.period.start.date = format(dates[period.starts[nperiods]], '%d %b %Y')
	last.period.end.date = format(dates[ndates], '%d %b %Y')

	if( (period.starts[nperiods] + period.len - 1) < ndates ) {
		last.period.end.date = format(dates[period.starts[nperiods] + period.len - 1], '%d %b %Y')
	}

	plota.legend(c(paste('Avgerage for', first.year, '-', last.year),
			paste(last.period.start.date, '-', last.period.end.date),
			'Top 25% / Bot 25%'), cols)
}

#############################################################################
# Find and Plot Classical Techical Patterns
#' @export
#############################################################################
plot.patterns <- function
(
	data,	# xts time series data
	n,		# lookback period to search for the patterns
	ticker,
	patterns = pattern.db()	# database with patterns
)
{
	#*****************************************************************
	# Find Extrema
	#******************************************************************
	load.packages('sm')

	sample = last(data, n)

	obj = find.extrema( Cl(sample) )
		mhat = obj$mhat
		mhat.extrema.loc = obj$mhat.extrema.loc
		data.extrema.loc = obj$data.extrema.loc
		n.index = len(data.extrema.loc)

	#*****************************************************************
	# Plot
	#******************************************************************
		plota.control$col.border = 'gray'
	plota(sample, type='hl',col='gray')
		plota.lines(mhat, col='magenta', lwd=2)
		plota.lines(sample, col='blue')

	if(n.index > 0) {
		plota.lines(sample[data.extrema.loc], type='p', col='blue', lwd=3, pch=19)
		out = find.patterns(obj, patterns = patterns, silent=F, plot=T)
	}

	plota.legend(c(paste(ticker, join(format(range(index(sample)), '%d%b%Y'), ' - ')),
				'Close,Kernel,Pattern(s)'),
				'gray,blue,magenta,orange')

}

#############################################################################
# Find maxima and minima using Kernel estimate
#' @export
#############################################################################
find.extrema <- function(
	x	# time series
)
{
	if(is.xts(x)) {
		y = as.vector( Cl(x) )
	} else {
		y = x
	}
	n = len(y)
	t = 1:n

	# Fit kernel
	# stat.epfl.ch/files/content/sites/stat/files/users/MdC/notes_3.pdf
	h = h.select(t, y, method = 'cv')
		temp = sm.regression(t, y, h=h, display = 'none')
	mhat = approx(temp$eval.points, temp$estimate, t, method='linear')$y

	# page 15
	# find locations of local maxima and minima in mhat
	temp = diff(sign(diff(mhat)))
	loc = which( temp != 0 ) + 1
		loc.dir = -sign(temp[(loc - 1)])

	# check
	# temp = cbind(mhat[(loc - 1)],mhat[(loc)],mhat[(loc + 1)])
	# cbind(round(temp,2), loc.dir, apply(temp, 1, which.max), apply(temp, 1, which.min))

	# page 16
	# find locations of local maxima and minima in original data with in +1/-1 local maxima and minima in mhat
	temp = c( y[1], y, y[n] )
	temp = cbind(temp[loc], temp[(loc + 1)], temp[(loc + 2)])
		max.index = loc + apply(temp, 1, which.max) - 2
		min.index = loc + apply(temp, 1, which.min) - 2
	data.loc = iif(loc.dir > 0, max.index, min.index)
	data.loc = iif(data.loc < 1, 1, iif(data.loc > n, n, data.loc))

	if(is.xts(x)) mhat = make.xts(mhat, index(x))

	return(list(data = y, mhat = mhat, extrema.dir = loc.dir,
		mhat.extrema.loc = loc, data.extrema.loc = data.loc))
}

#############################################################################
# Find Classical Techincal patterns
#' @export
#############################################################################
find.patterns <- function
(
	obj, 	# extrema points
	patterns = pattern.db(),
	silent=T,
	plot=T
)
{
	data = obj$data
	mhat = obj$mhat
	extrema.dir = obj$extrema.dir
	data.extrema.loc = obj$data.extrema.loc
	n.index = len(data.extrema.loc)

	if(is.xts(mhat)) {
		dates = index4xts(obj$mhat)
	} else {
		dates = 1:len(data)
	}

	# Semi-transparent orange color
	col = col.add.alpha('orange', alpha=150)

	out = out.rownames = c()

	# search for patterns
	for(i in 1:n.index) {

		for(pattern in patterns) {

			# check same sign
			if( pattern$start * extrema.dir[i] > 0 ) {

				# check that there is suffcient number of extrema to complete pattern
				if( i + pattern$len - 1 <= n.index ) {

					# create enviroment to check pattern: E1,E2,...,En; t1,t2,...,tn
					envir.data = c(data[data.extrema.loc][i:(i + pattern$len - 1)],
									data.extrema.loc[i:(i + pattern$len - 1)])
						names(envir.data) = c(paste('E', 1:pattern$len, sep=''),
												paste('t', 1:pattern$len, sep=''))
					envir.data = as.list(envir.data)

					# double top/bottom patterns require all extrema [we will exclude the first point(E1/t1)]
					#envir.data$E = data[data.extrema.loc][i:n.index]
					envir.data$E = data[data.extrema.loc][-c(1:i)]
					envir.data$t = data.extrema.loc[-c(1:i)]

					# check if pattern was found
					if( eval(pattern$formula, envir = envir.data) ) {
						if(!silent) cat('Found', pattern$name, 'at', i, '\n')

						if(plot & !is.null(pattern$plot)) {
							temp = dates[data.extrema.loc[i:(i + pattern$len - 1)]]
								names(temp) = paste('d', 1:pattern$len, sep='')
							envir.data = c( envir.data, temp )
							envir.data$d = dates[data.extrema.loc[-c(1:i)]]
							envir.data$col = col

							eval(pattern$plot, envir = envir.data)
						}

						# record
						out.rownames = c(out.rownames, pattern$name)
						out = rbind(out, c(data.extrema.loc[i],
											iif(is.null(pattern$last.point),
												data.extrema.loc[(i + pattern$len - 1)],
												eval(pattern$last.point, envir = envir.data)
												)))
					}
				}
			}
		}
	}

	if(len(out)>0) {
		colnames(out) = spl('start,end')
		rownames(out) = out.rownames
	}
	return(out)
}

#############################################################################
# Find historical patterns in the data over a rolling window
#' @export
#############################################################################
find.all.patterns.window <- function()
{
	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')
	ticker = 'SPY'

	data = getSymbols(ticker, src = 'yahoo', from = '1970-01-01', auto.assign = F)
		data = adjustOHLC(data, use.Adjusted=T)

	data = data['2010::']
	#*****************************************************************
	# Search for all patterns over a rolling window
	#******************************************************************
	load.packages('sm')
	history = as.vector(coredata(Cl(data)))
	window.len = 90
	patterns = pattern.db()

	found.patterns = c()

	for(t in window.len : (len(history)-1)) {
		sample = history[(t - window.len + 1):t]
		obj = find.extrema( sample )

		if(len(obj$data.extrema.loc) > 0) {
			out =  find.patterns(obj, patterns = patterns, silent=F, plot=F)

			if(len(out)>0) found.patterns = rbind(found.patterns,cbind(t,out,t-window.len+out))
		}
		if( t %% 10 == 0) cat(t, 'out of', len(history), '\n')
	}
	colnames(found.patterns) = spl('t,start,end,tstart,tend')

	#*****************************************************************
	# Examine found patterns
	#******************************************************************
	# check what patterns are not found
	setdiff(unique(names(patterns)), unique(rownames(found.patterns)))

	# number of matches for each pattern
	frequency = tapply(rep(1,nrow(found.patterns)), rownames(found.patterns), sum)
	barplot(frequency)

	# determine starting Time for a pattern
	index = which(rownames(found.patterns)=='HS')
	found.patterns[ index[1:10],]

	# plot
	pattern.index = index[1]
	t = found.patterns[pattern.index, 't'];
	plot.patterns(data[1:t,], window.len, ticker, patterns)

	# plot start/end of this pattern
	sample = data[(t - window.len + 1):t]
		start.pattern = found.patterns[pattern.index, 'start']
		end.pattern = found.patterns[pattern.index, 'end']
	abline(v = index(sample)[start.pattern]);
	abline(v = index(sample)[end.pattern]);

	index(sample)[start.pattern]
	index(data[(t - window.len + start.pattern),])

}

#############################################################################
# Compute conditional returns for each pattern over a rolling window
#############################################################################
bt.patterns.test <- function()
{
	#*****************************************************************
	# Load historical data
	#******************************************************************
	load.packages('quantmod')
	ticker = 'SPY'

	data = getSymbols(ticker, src = 'yahoo', from = '1970-01-01', auto.assign = F)
		data = adjustOHLC(data, use.Adjusted=T)

	#data = data['2010::']

	#*****************************************************************
	# Setup
	#******************************************************************
	# page 14-15, L = 35 and d = 3, rolling the length of the window at L + d,
	# The parameter d controls for the fact that in practice we do not observe a
	# realization of a given pattern as soon as it has completed. Instead, we assume
	# that there may be a lag between the pattern completion and the time
	# of pattern detection. To account for this lag, we require that the final extremum
	# that completes a pattern occurs on day t + L - 1; hence d is the number
	# of days following the completion of a pattern that must pass before the pattern
	# is detected.
	#In particular, we compute postpattern returns starting from the end of trading
	#day t + L + d, that is, one day after the pattern has completed. For
	#example, if we determine that a head-and-shoulder pattern has completed
	# on day t + L - 1 (having used prices from time t through time t + L + d - 1),
	#we compute the conditional one-day gross return as Z1=Yt+L+d+1/Yt+L+d.

	#*****************************************************************
	# Search for all patterns over a rolling window
	#******************************************************************
	load.packages('sm')
	history = as.vector(coredata(Cl(data)))

	window.L = 35
	window.d = 3
	window.len = window.L + window.d

	patterns = pattern.db()

	found.patterns = c()

	for(t in window.len : (len(history)-1)) {
		ret = history[(t+1)]/history[t]-1

		sample = history[(t - window.len + 1):t]
		obj = find.extrema( sample )

		if(len(obj$data.extrema.loc) > 0) {
			out =  find.patterns(obj, patterns = patterns, silent=F, plot=F)

			if(len(out)>0) found.patterns = rbind(found.patterns,cbind(t,out,t-window.len+out, ret))
		}
		if( t %% 10 == 0) cat(t, 'out of', len(history), '\n')
	}
	colnames(found.patterns) = spl('t,start,end,tstart,tend,ret')

	#*****************************************************************
	# Clean found patterns
	#******************************************************************
	# remove patterns that finished after window.L
	found.patterns = found.patterns[found.patterns[,'end'] <= window.L,]

	# remove the patterns found multiple times, only keep first one
	pattern.names = unique(rownames(found.patterns))
	all.patterns = c()
	for(name in pattern.names) {
		index = which(rownames(found.patterns) == name)
		temp = NA * found.patterns[index,]

		i.count = 0
		i.start = 1
		while(i.start < len(index)) {
			i.count = i.count + 1
			temp[i.count,] = found.patterns[index[i.start],]
			subindex = which(found.patterns[index,'tstart'] > temp[i.count,'tend'])

			if(len(subindex) > 0) {
				i.start = subindex[1]
			} else break
		}
		all.patterns = rbind(all.patterns, temp[1:i.count,])
	}

	#*****************************************************************
	# Plot
	#******************************************************************
png(filename = 'plot1.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	# number of matches for each pattern
	frequency = tapply(rep(1,nrow(all.patterns)), rownames(all.patterns), sum)
	layout(1)
	barplot.with.labels(frequency/100, 'Frequency for each Pattern')
dev.off()

png(filename = 'plot2.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	# pattern seasonality
	all.patterns[,'ret'] = history[(all.patterns[,'t']+20)] / history[all.patterns[,'t']] - 1
	data_list = tapply(all.patterns[,'ret'], rownames(all.patterns), list)
	group.seasonality(data_list, '20 days after Pattern')
dev.off()

png(filename = 'plot3.png', width = 600, height = 500, units = 'px', pointsize = 12, bg = 'white')
	# time pattern seasonality
	layout(1)
	name = 'BBOT'
	index = which(rownames(all.patterns) == name)
	time.seasonality(data, all.patterns[index,'t'], 20, name)
dev.off()

	#t.test(out[,'ret'])$p.value
	#tapply(out[,'ret'], rownames(out), function(x) t.test(x)$p.value)

}

###############################################################################
# Pattern Matching
#
# Based on Foundations of Technical Analysis: Computational Algorithms, Statistical Inference, and Empirical Implementation
# by A.W. LO, H. MAMAYSKY, J. WANG
###############################################################################
# http://thepatternsite.com/
#' @export
###############################################################################
pattern.db <- function()
{
	# page 12
	patterns = list()

	#*****************************************************************
	# You can reference E1,E2,...,En and t1,t2,...,tn in pattern formula
	#******************************************************************
	# Head-and-shoulders (HS)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'max'
	pattern$formula = expression(
		# E3 > E1, E3 > E5
		E3 > E1 &
		E3 > E5 &

		# E1 and E5 are within 1.5 percent of their average
		abs(E1 - (E1+E5)/2) < 1.5/100 * (E1+E5)/2 &
		abs(E5 - (E1+E5)/2) < 1.5/100 * (E1+E5)/2 &

		# E2 and E4 are within 1.5 percent of their average
		abs(E2 - (E2+E4)/2) < 1.5/100 * (E2+E4)/2 &
		abs(E4 - (E2+E4)/2) < 1.5/100 * (E2+E4)/2
		)
	pattern$plot = expression({
		lines(c(d1,d2,d3,d4,d5), c(E1,E2,E3,E4,E5), lwd=10, col=col)
			text(d3, E3, 'HS', adj=c(0.5,-0.5), xpd=TRUE)
		})
	patterns$HS = pattern

	#*****************************************************************
	# Inverted Head-and-shoulders (IHS)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'min'
	pattern$formula = expression(
		# E3 < E1, E3 < E5
		E3 < E1 &
		E3 < E5 &

		# E1 and E5 are within 1.5 percent of their average
		abs(E1 - (E1+E5)/2) < 1.5/100 * (E1+E5)/2 &
		abs(E5 - (E1+E5)/2) < 1.5/100 * (E1+E5)/2 &

		# E2 and E4 are within 1.5 percent of their average
		abs(E2 - (E2+E4)/2) < 1.5/100 * (E2+E4)/2 &
		abs(E4 - (E2+E4)/2) < 1.5/100 * (E2+E4)/2
		)
	pattern$plot = expression({
		lines(c(d1,d2,d3,d4,d5), c(E1,E2,E3,E4,E5), lwd=10, col=col)
			text(d3, E3, 'IHS', adj=c(0.5,1), xpd=TRUE)
		})
	patterns$IHS = pattern

	#*****************************************************************
	# Broadening tops (BTOP)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'max'
	pattern$formula = expression(
		# E1 < E3 < E5
		E1 < E3 &
		E3 < E5 &
		E2 > E4
		)
	pattern$plot = expression({
		beta = ols(cbind(1,c(t1,t3,t5)),c(E1,E3,E5))$coefficients
		lines(c(d1,d3,d5), beta[1] + beta[2]*c(t1,t3,t5), lwd=10, col=col)
		lines(c(d2,d4), c(E2,E4), lwd=10, col=col)
			text(d3, min(E2,E4), 'BTOP', adj=c(0.5,1), xpd=TRUE)
		})
	patterns$BTOP = pattern

	#*****************************************************************
	# Broadening bottoms (BBOT)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'min'
	pattern$formula = expression(
		# E1 > E3 > E5
		E1 > E3 &
		E3 > E5 &
		E2 < E4
		)
	pattern$plot = expression({
		beta = ols(cbind(1,c(t1,t3,t5)),c(E1,E3,E5))$coefficients
		lines(c(d1,d3,d5), beta[1] + beta[2]*c(t1,t3,t5), lwd=10, col=col)
		lines(c(d2,d4), c(E2,E4), lwd=10, col=col)
			text(d3, max(E2,E4), 'BBOT', adj=c(0.5,0), xpd=TRUE)
		})
	patterns$BBOT = pattern

	#*****************************************************************
	# Triangle tops (TTOP)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'max'
	pattern$formula = expression(
		# E1 > E3 > E5
		E1 > E3 &
		E3 > E5 &
		E2 < E4
		)
	pattern$plot = expression({
		beta = ols(cbind(1,c(t1,t3,t5)),c(E1,E3,E5))$coefficients
		lines(c(d1,d3,d5), beta[1] + beta[2]*c(t1,t3,t5), lwd=10, col=col)
		lines(c(d2,d4), c(E2,E4), lwd=10, col=col)
			text(d3, min(E2,E4), 'TTOP', adj=c(0.5,1), xpd=TRUE)
		})
	patterns$TTOP = pattern

	#*****************************************************************
	# Triangle bottoms (TBOT)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'min'
	pattern$formula = expression(
		# E1 < E3 < E5
		E1 < E3 &
		E3 < E5 &
		E2 > E4
		)
	pattern$plot = expression({
		beta = ols(cbind(1,c(t1,t3,t5)),c(E1,E3,E5))$coefficients
		lines(c(d1,d3,d5), beta[1] + beta[2]*c(t1,t3,t5), lwd=10, col=col)
		lines(c(d2,d4), c(E2,E4), lwd=10, col=col)
			text(d3, max(E2,E4), 'TBOT', adj=c(0.5,0), xpd=TRUE)
		})
	patterns$TBOT = pattern

	#*****************************************************************
	# Rectangle tops (RTOP)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'max'
	pattern$formula = expression({
		avg.top = (E1+E3+E5)/3
		avg.bop = (E2+E4)/2

		# tops E1,E3,E5 are within 0.75 percent of their average
		abs(E1 - avg.top) < 0.75/100 * avg.top &
		abs(E3 - avg.top) < 0.75/100 * avg.top &
		abs(E5 - avg.top) < 0.75/100 * avg.top &

		# bottoms E2,E4 are within 0.75 percent of their average
		abs(E2 - avg.bop) < 0.75/100 * avg.bop &
		abs(E4 - avg.bop) < 0.75/100 * avg.bop &

		# lowest top > highest bottom
		min(E1,E3,E5) > max(E2,E4)
		})
	pattern$plot = expression({
		avg.top = (E1+E3+E5)/3
		avg.bop = (E2+E4)/2

		lines(c(d1,d3,d5), rep(avg.top,3), lwd=10, col=col)
		lines(c(d2,d4), rep(avg.bop,2), lwd=10, col=col)
			text(d3, min(E2,E4), 'RTOP', adj=c(0.5,-0.5), xpd=TRUE)
		})
	patterns$RTOP = pattern

	#*****************************************************************
	# Rectangle bottoms (RBOT)
	#******************************************************************
	pattern = list()
	pattern$len = 5
	pattern$start = 'min'
	pattern$formula = expression({
		avg.top = (E2+E4)/2
		avg.bop = (E1+E3+E5)/3

		# tops E2,E4 are within 0.75 percent of their average
		abs(E2 - avg.top) < 0.75/100 * avg.top &
		abs(E4 - avg.top) < 0.75/100 * avg.top &

		# bottoms E1,E3,E5 are within 0.75 percent of their average
		abs(E1 - avg.bop) < 0.75/100 * avg.bop &
		abs(E3 - avg.bop) < 0.75/100 * avg.bop &
		abs(E5 - avg.bop) < 0.75/100 * avg.bop &

		# lowest top > highest bottom
		min(E2,E4) > max(E1,E3,E5)
		})
	pattern$plot = expression({
		avg.top = (E2+E4)/2
		avg.bop = (E1+E3+E5)/3

		lines(c(d1,d3,d5), rep(avg.bop,3), lwd=10, col=col)
		lines(c(d2,d4), rep(avg.top,2), lwd=10, col=col)
			text(d3, max(E2,E4), 'RBOT', adj=c(0.5,0), xpd=TRUE)
		})
	patterns$RBOT = pattern

	#*****************************************************************
	# Analyzing Chart Patterns: Double Top And Double Bottom
	# http://www.investopedia.com/university/charts/charts4.asp
	#*****************************************************************
	# Double tops (DTOP), note in E and t first one is excluded
	#******************************************************************
	pattern = list()
	pattern$len = 3
	pattern$start = 'max'
	pattern$formula = expression({
		# Ea = max(E), ta = t[which.max(E)]
		second.top = max(E)
		second.top.t = t[which.max(E)]
		avg = (E1 + second.top)/2

		# E1 and Ea are within 1.5 percent of their average
		abs(E1         - avg) < 1.5/100 * avg &
		abs(second.top - avg) < 1.5/100 * avg &

		# ta - t1 > 22
		second.top.t - t1 > 22
		})
	pattern$plot = expression({
		second.top = max(E)
		second.top.d = d[which.max(E)]
		avg = (E1 + second.top)/2

		points(c(d1, second.top.d), c(E1, second.top), pch=2, lwd=2)
		lines(c(d1, second.top.d), rep(avg, 2), lwd=10, col=col)
			text(d2, avg, 'DTOP', adj=c(0.5,-0.5), xpd=TRUE)
		})
	pattern$last.point = expression(t[which.max(E)])
	patterns$DTOP = pattern

	#*****************************************************************
	# Double bottoms (DBOT)
	#******************************************************************
	pattern = list()
	pattern$len = 3
	pattern$start = 'min'
	pattern$formula = expression(
		# E1 and Ea = min(E) are within 1.5 percent of their average
		abs(E1 -         (E1+min(E))/2) < 1.5/100 * (E1+min(E))/2 &
		abs(max(E[-1]) - (E1+min(E))/2) < 1.5/100 * (E1+min(E))/2 &

		# ta - t1 > 22, ta = t[which.min(E)]
		t[which.min(E)] - t1 > 22
		)
	pattern$plot = expression({
		second.bot = min(E)
		second.bot.d = d[which.min(E)]
		avg = (E1 + second.bot)/2

		points(c(d1, second.bot.d), c(E1, second.bot), pch=2, lwd=2)
		lines(c(d1, second.bot.d), rep(avg, 2), lwd=10, col=col)
			text(d2, avg, 'DBOT', adj=c(0.5,1), xpd=TRUE)
		})
	pattern$last.point = expression(t[which.min(E)])
	patterns$DBOT = pattern

	# add name and convert start to +1/-1
	for(i in 1:len(patterns)) {
		patterns[[i]]$name = names(patterns)[i]
		patterns[[i]]$start = iif(patterns[[i]]$start == 'max', 1, -1)
	}

	return(patterns)
}


# An exercise on species disribution modelling with Megachile sculpturalis
# R packages to use: SDMTools, dismo, biomod, hSDM

# 04

# Setup
source('keys.R')
setwd(working_dir)

# Libraries
library(maptools)
library(data.table)
library(raster)
library(dismo)
library(ggplot2)
library(randomForest)
library(gbm)

# Params
map_crs = '+proj=longlat +datum=WGS84'
raster_dir = 'data/geo/1_separate/chelsa/bioclim/'
country_shp_dir = 'data/geo/1_separate/gadm/shp_pri'
data_in = 'data/2019-05-27-ejys-gbif-data/0018967-190415153152247-clean.csv'

# Initialize
data(wrld_simpl) # maptools
modelling_col = paste0('bio',1:19)
latlong_col = c('x', 'y')

# Read data
pres_dd = data.table::fread(data_in, integer64="character")
df_cols = names(pres_dd)
if(any(df_cols == "V1")) {
    pres_dd$V1 = NULL
}

# Subset presence data
native_range = c("JP", "KR", "CN", "TW")
pres_dd_native = pres_dd[countryCode %in% native_range]
pres_dd_native_sp = pres_dd_native

# Get simple map
native_long = c('japan', 'china', 'taiwan', 'korea')
native = ggplot2::map_data('world2', native_long)
# see https://stackoverflow.com/questions/8751497 on converting map_data to SpatialDF

# Get complex map
native_code = c('JPN', 'CHN', 'TWN', 'KOR', 'MNG', 'PRK', 'RUS')
native_code = paste0(country_shp_dir, "/gadm36_", native_code, "_0.shp")
native_code

shp_master = raster::shapefile(native_code[1])
for (i in 2:length(native_code)) {
    print(paste0("Binding for ", native_code[i], " at index ", i, "."))
    shp_new = raster::shapefile(native_code[i])
    shp_master = raster::bind(shp_master, shp_new)
}

# Get extent
native_extent = raster::extent(min(pres_dd_native$decimalLongitude)-1,
                               max(pres_dd_native$decimalLongitude)+1,
                               min(pres_dd_native$decimalLatitude)-1,
                               max(pres_dd_native$decimalLatitude)+1)
native_extent_pol = methods::as(native_extent, 'SpatialPolygons')
crs(native_extent_pol) = map_crs

# Crop shp to extent
shp_master_crop = raster::crop(shp_master, native_extent)

# Plot
base = ggplot2::ggplot() +
    geom_polygon(data = ggplot2::fortify(shp_master_crop),
                 aes(x=long, y = lat, group = group),
                 fill = "grey90", color = "grey70") +
        geom_polygon(data = native_extent_pol, aes(x=long, y = lat, group = group), fill = NA, color = "grey70")

# Get background values
files = list.files(raster_dir, pattern="tif", full.names=TRUE) # load background data
rast = raster::raster(files[1], pattern='tif', full.names=TRUE)
rast = raster::crop(rast, native_extent)
set.seed(1963); bg_random_points = dismo::randomPoints(rast, nrow(pres_dd_native)) # generate random points

# Making all of them in a dataframe
pres = cbind(1, pres_dd_native$decimalLongitude, pres_dd_native$decimalLatitude, row.names(pres_dd_native))
bg = cbind(0, bg_random_points, NA)
df = data.frame(rbind(pres, bg))
names(df) = c('pres_bg', 'x', 'y', 'id')
sapply(df, class)
df[] = lapply(df, as.character)
df[] = lapply(df, as.numeric)

sp::coordinates(df) = ~ x + y
raster::crs(df) = map_crs

# Getting predictors
files = list.files(raster_dir, pattern="tif", full.names=TRUE)
predictors = raster::stack(files)
predictors = raster::crop(predictors, native_extent)
names(predictors) = paste0("bio", 1:19)
crs(predictors) = map_crs
d = raster::extract(predictors, df)
m = cbind(df, d)
p = as.data.frame(m)

# Test/ train datasets
pres = p[p$pres_bg==1,]
bg = p[p$pres_bg==0,]

set.seed(1000)
pres_gp = kfold(pres, 5)
bg_gp = kfold(bg, 5)

pres_train = pres[pres_gp != 1,]
pres_test = pres[pres_gp == 1,]
bg_train = bg[bg_gp != 1,]
bg_test = bg[bg_gp == 1,]

# Plot
pdf('plots/2019-05-29-ejys-sampling_points.pdf', width=10, height=10)
base + theme_minimal() +
    geom_point(aes(x = x, y = y), data = as.data.frame(pres_train), color="royalblue4", size=1, shape=3) +
        geom_point(aes(x=x, y=y), data = as.data.frame(pres_test), color="royalblue4", size=1) +
            geom_point(aes(x=x, y=y), data = as.data.frame(bg_train), color="red3", size=1, shape=3) +
                geom_point(aes(x=x, y=y), data = as.data.frame(bg_test), color="red3", size=1) +
                    labs(x="Longitude, dd", y="Latitude, dd")
dev.off()

# Bioclim
pred_xy = as.matrix(pres_train[,latlong_col])
mod_cols = c('bio5', 'bio6', 'bio18', 'bio19')
bc = dismo::bioclim(pres_train[, mod_cols]); plot(bc, a=3, b=4, p=0.85)
result = dismo::evaluate(pres_test, bg_test, bc); result
thres = dismo::threshold(result, 'spec_sens')
pb = dismo::predict(predictors, bc, ext=native_extent, progress='')

pdf('plots/2019-05-29-ejys-predict-bioclim.pdf', width=20, height=10)
par(mfrow=c(1,2))
plot(pb, main='Bioclim, raw values')
plot(shp_master_crop, add=TRUE, border='dark grey')
plot(pb > thres, main='presence/absence')
plot(shp_master_crop, add=TRUE, border='dark grey')
points(pres_train[,latlong_col], pch='+')
dev.off()

# Domain
dm = dismo::domain(pres_train[, mod_cols])
result = dismo::evaluate(pres_test, bg_test, dm); result
thres = dismo::threshold(result, 'spec_sens')
pb = dismo::predict(predictors, dm, ext=native_extent, progress='')

pdf('plots/2019-05-29-ejys-predict-domain.pdf', width=20, height=10)
par(mfrow=c(1,2))
plot(pb, main='Domain, raw values')
plot(shp_master_crop, add=TRUE, border='dark grey')
plot(pb > thres, main='presence/absence')
plot(shp_master_crop, add=TRUE, border='dark grey')
points(pres_train[,latlong_col], pch='+')
dev.off()

# Domain
mh = dismo::mahal(pres_train[, mod_cols])
result = dismo::evaluate(pres_test, bg_test, mh); result
thres = dismo::threshold(result, 'spec_sens')
pb = dismo::predict(predictors, mh, ext=native_extent, progress='')

pdf('plots/2019-05-29-ejys-predict-mahal.pdf', width=20, height=10)
par(mfrow=c(1,2))
plot(pb, main='Mahalanobis distance, raw values')
plot(shp_master_crop, add=TRUE, border='dark grey')
plot(pb > thres, main='presence/absence')
plot(shp_master_crop, add=TRUE, border='dark grey')
points(pres_train[,latlong_col], pch='+')
dev.off()

# GLM
train = rbind(pres_train, bg_train)
test = rbind(pres_test, bg_test)
mod1 = glm(pres_bg ~ bio5 + bio6 + bio18 + bio19, family = binomial(link = "logit"), data=train)
summary(mod)
mod2 = glm(pres_bg ~ bio5 + bio6 + bio19, family = binomial(link = "logit"), data=train)
summary(mod2)
mod3 = glm(pres_bg ~ bio6 + bio19, family = binomial(link = "logit"), data=train)
summary(mod3)
result = dismo::evaluate(pres_test, bg_test, mod3)
thres = dismo::threshold(result, 'spec_sens')
pb = dismo:: predict(predictors, mod3, ext=native_extent, progress='')

pdf('plots/2019-05-29-ejys-predict-glm.pdf', width=20, height=10)
par(mfrow=c(1,2))
plot(pb, main='Mahalanobis distance, raw values')
plot(shp_master_crop, add=TRUE, border='dark grey')
plot(pb > thres, main='presence/absence')
plot(shp_master_crop, add=TRUE, border='dark grey')
points(pres_train[,latlong_col], pch='+')
dev.off()

xm = dismo::maxent(predictors, pred_xy)
plot(xm)
response(xm)

e = evaluate(as.matrix(pres_test[,latlong_col]), as.matrix(bg_test[,latlong_col]), xm, predictors)
px = predict(predictors, xm, ext=native_extent, progress='')
par(mfrow=c(1,2))
plot(px, main='Maxent, raw values')
plot(wrld_simpl, add=TRUE, border='dark grey')
tr = threshold(e, 'spec_sens')
plot(px > tr, main='presence/absence')
plot(wrld_simpl, add=TRUE, border='dark grey')
points(pres_train, pch='+')

# Convex hulls
hull <- dismo::convHull(pres_train, lonlat=TRUE)
e <- evaluate(hull, p=pres_test, a=backg_test)

# Did not do for random forest and SVM.
# Did not try model combination methods.
# Did not try geoIDW, voronoiHull, indicator kriging (gstat)