### Coastal Phenology Trend Analysis in Phenology Observations and Environmental
### Predictors by Jakob Assmann 13 March 2018

# Dependencies
library(dplyr)
library(MCMCglmm)
library(ggplot2)
library(parallel)
library(gridExtra)

# Housekeeping
script_path <- "scripts/users/jassmann/phenology/coastal_phenology/"
load(file =paste0(script_path, "coastal_phen.Rda"))

# Site names
site_names <- unique(as.character(coastal_phen$site_name))

# Site spp phen combos
site_spp_phen_combos <- unique(coastal_phen$site_spp_phen)

# Spp phen combos
spp_phen_combos <- sort(unique(coastal_phen$site_spp_phen))

# Set colours
colour_theme_sites <- data.frame(site_name = c(site_names),
                                 name_pretty =  c("Alexandra Fiord",
                                                  "Utqiaġvik",
                                                  "Qikiqtaruk",
                                                  "Zackenberg"),
                                 colour = c("#324D5CFF",
                                            "#46B29DFF",
                                            "#C2A33EFF",
                                            "#E37B40FF")) # 5th colour #F53855FF

colour_theme_spp_phen <- data.frame(site_name = c(rep(site_names[1], 8),
                                                  rep(site_names[2], 7),
                                                  rep(site_names[3], 3),
                                                  rep(site_names[4], 6)),
                                    site_spp_phen = spp_phen_combos,
                                    spp_phen = c(unique(sort(as.character(coastal_phen[coastal_phen$site_name == site_names[1],]$spp_phen))),
                                                 unique(sort(as.character(coastal_phen[coastal_phen$site_name == site_names[2],]$spp_phen))),
                                                 unique(sort(as.character(coastal_phen[coastal_phen$site_name == site_names[3],]$spp_phen))),
                                                 unique(sort(as.character(coastal_phen[coastal_phen$site_name == site_names[4],]$spp_phen)))),
                                    colour = c(
                                      colorRampPalette(c("#19262EFF","#84CBF2FF"),
                                                       interpolate = "linear")(8), # ALEXFIIORD
                                      colorRampPalette(c("#112B26FF","#5BE8CDFF"),
                                                       interpolate = "linear")(7), # BARROW
                                      colorRampPalette(c("#382F12FF","#C2A33EFF"),
                                                       interpolate = "linear")(3), # QHI
                                      colorRampPalette(c("#422413FF","#FF8A48FF"),
                                                       interpolate = "linear")(6) # ZACKENBERG
                                    ), stringsAsFactors = F)

# Helper function that returns ylab only for Alexfiord (first site)
ylab_filter <- function(label, site_to_plot){
  if(site_to_plot == "ALEXFIORD") {
    return(label)
  } else {
    return("")
  }
}

### Quality Control Phenology data----

## Check for NAs and quality in predictors and responses

# Phenology observations, upper and lower bounds
unique(coastal_phen$doy)
unique(coastal_phen$prior_visit)
sum(is.na(coastal_phen$doy))
sum(is.na(coastal_phen$prior_visit))
# remove NAs (211 values)
coastal_phen <- coastal_phen[!is.na(coastal_phen$doy),]
# nice!

# Snowmelt dates
unique(coastal_phen$snowmelt)
sum(is.na(coastal_phen$snowmelt))
# Some NAs in there (153)
coastal_phen <- coastal_phen[!is.na(coastal_phen$snowmelt),]
# Nice!

# Remaining predictors
unique(coastal_phen$phase_temp)
unique(coastal_phen$spring_temp)
unique(coastal_phen$apr_temp)
unique(coastal_phen$may_temp)
unique(coastal_phen$jun_temp)
unique(coastal_phen$onset_ice_melt)
unique(coastal_phen$spring_extent)

sum(is.na(coastal_phen$phase_temp))
sum(is.na(coastal_phen$spring_temp))
sum(is.na(coastal_phen$apr_temp))
sum(is.na(coastal_phen$may_temp))
sum(is.na(coastal_phen$jun_temp))
sum(is.na(coastal_phen$onset_ice_melt))
sum(is.na(coastal_phen$spring_extent))
# Okay. All good.

### Trend analysis fro phenological observations ----

# If previously run load from this file:
# load(paste0(script_path, "models/phen_trend_models.Rda"))

# Define function to run MCMCglmm models
trend_model <- function(site_spp_sphen_select){
  cphen_subset <- coastal_phen %>%
    filter(site_spp_phen == site_spp_sphen_select)
    model <- MCMCglmm(cbind(prior_visit, doy) ~ year,
                      random = ~ year_fac + plot_id,
                      data = as.data.frame(cphen_subset),
                      family = "cengaussian",
                      nitt = 1000000)
    return(model)
}

# Execute over all site_spp_phen_combinations with parallel processing
# models <-  mclapply(site_spp_phen_combos, trend_model, mc.cores = 4)
# names(models) <- make.names(paste0(site_spp_phen_combos, "_model"))
# list2env(models, envir = .GlobalEnv)

# Dont'r run in parallel, as we will not know which model will be associated
# with which output afterwards. Better run linearly.
model_list <- lapply(site_spp_phen_combos, trend_model)
names(model_list) <- make.names(paste0(site_spp_phen_combos, "_model"))
list2env(model_list, envir = .GlobalEnv)

### Gather outputs
## Prep data frame
phen_trends <- data.frame(site_spp_phen = site_spp_phen_combos,
                          intercept = NA,
                          intercept_l95 = NA,
                          intercept_u95 = NA,
                          intercept_esmpl = NA,
                          intercept_pMCMC = NA,
                          slope = NA,
                          slope_l95 = NA,
                          slope_u95 = NA,
                          slope_esmpl = NA,
                          slope_pMCMC = NA)
## Define funciton to extract slope parameters and estimates
extr_outputs <- function(site_spp_sphen_select){
  model <- get(paste0(site_spp_sphen_select, "_model"))
  model_sum <- summary(model)
  # retrive row index for output dataframe
  row_no <- which(phen_trends$site_spp_phen == site_spp_sphen_select)
  # use one liners to extract intersept and slope estimators
  phen_trends[row_no,2:6] <<- model_sum$solutions[1,]
  phen_trends[row_no,7:11] <<- model_sum$solutions[2,]
}

## Apply to all site_spp_phen combos
lapply(site_spp_phen_combos, extr_outputs)

### Claculate predictions
# prep data frame
phen_predicts <- data.frame(site_spp_phen = coastal_phen %>%
                              select(site_spp_phen, year) %>%
                              distinct(site_spp_phen, year) %>%
                              select(site_spp_phen) %>%
                              unlist() %>%
                              as.character(),
                            year = coastal_phen %>%
                              select(site_spp_phen, year) %>%
                              distinct(site_spp_phen, year) %>%
                              select(year) %>%
                              unlist() %>%
                              as.numeric(),
                            pred = NA,
                            pred_l95 = NA,
                            pred_u95 = NA)

# Define function to extract predicitons
extract_pred <- function(site_spp_phen_select){
  model <- get(paste0(site_spp_phen_select, "_model"))
  row_nos <- which(phen_predicts$site_spp_phen == site_spp_phen_select)
  preds <- predict.MCMCglmm(model, interval = "confidence", type = "response")
  preds <- unique(data.frame(preds, year = as.numeric(model$X[,2])))
  preds <- preds[,c(4,1,2,3)]
  phen_predicts[row_nos, 3:5] <<- preds[,2:4]
  paste0("Done with: ", site_spp_phen_select, " ;")
}
lapply(site_spp_phen_combos, extract_pred)

# create site name and spp_phen columns
phen_predicts$site_name <- gsub("_.*", "", phen_predicts$site_spp_phen)
phen_predicts$spp_phen <- gsub("^[A-Z]*_", "", phen_predicts$site_spp_phen)

### Plot phenology data with trends ----
# First without ZACK SILACA due to large errors
colour_theme_sites$start_year <- c(1989,1993,1999,1994)
colour_theme_sites$end_year <- c(2016,2016,2016,2011)
colour_theme_sites$early_doy <- c(130,130,130,130)
colour_theme_sites$late_doy <- c(220,220,220,220)

plot_phen <- function(site_to_plot){

  site_colours <- colour_theme_spp_phen[colour_theme_spp_phen$site_name == site_to_plot,]$colour
  site_colour <- colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$colour
  name_pretty <- colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$name_pretty
  site_phen <- coastal_phen %>% filter(site_name == site_to_plot) %>%
    group_by(spp_phen, year) %>% mutate(int_mean = (prior_visit + doy) /2) %>%
    summarise(phen_mean = round(mean(int_mean, na.rm = T)))
  site_phen$spp_phen <- factor(as.character(site_phen$spp_phen))
  site_preds <- phen_predicts %>%
    filter(site_name == site_to_plot)
  site_preds$spp_phen <- factor(site_preds$spp_phen)
  ribbon_alpha <- 0.5
  site_colours_ribbon <- site_colours
  if(site_to_plot == "ZACKENBERG"){
    site_phen$spp_phen <- factor(site_phen$spp_phen, levels = rev(levels(site_phen$spp_phen)))
    site_preds$spp_phen <- factor(site_preds$spp_phen, levels = rev(levels(site_preds$spp_phen)))
    site_colours <- rev(site_colours)
    # Exclude SILACA due to large error bars
    site_colours_ribbon <- c("#FF8A4800", "#D9753D80", "#B3613280", "#8D4C2880", "#67381D80", "#42241380")

    ribbon_alpha <- NA

  }

  ggplot() +
    geom_ribbon(data = site_preds[,], #-which(site_preds$spp_phen == "SILACA_flowering")
                mapping = aes(x = year,
                              ymin = pred_l95,
                              ymax = pred_u95,
                              fill = spp_phen,
                              group = spp_phen),
                alpha = ribbon_alpha,
                inherit.aes = FALSE) +
    geom_point(data = site_phen,
               mapping = aes(x = year,
                             y = phen_mean,
                             colour = spp_phen,
                             fill= spp_phen,
                             group = spp_phen),
               size = 4) +
    geom_line(data = site_preds,
              mapping = aes(x = year,
                            y = pred,
                            colour = spp_phen,
                            group = spp_phen),
              inherit.aes = FALSE,
              size = 1) +
    scale_colour_manual(values = site_colours) +
    scale_fill_manual(values = site_colours_ribbon) +

    scale_x_continuous(limits= c(colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$start_year,
                                 colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$end_year),
                       breaks = seq(1990, 2016, 5)) +
    scale_y_continuous(limits = c(colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$early_doy,
                                  colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$late_doy),
                       breaks = seq(100, 240, 20)) +
    xlab(label = "") +
    ylab(label = ylab_filter("Mean Phenology (DoY)", site_to_plot)) +
    annotate("text", x = (colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$end_year +
               colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$start_year) / 2,
             y = colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$late_doy,
             label = name_pretty,
             colour = site_colour, size = 7, hjust = 0.5) +
    theme_bw() +
    theme(panel.border = element_blank(),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          axis.line = element_line(colour = "black"),
          axis.text = element_text(colour = "black", size = 15),
          axis.title = element_text(size = 15),
          legend.position = "none")
}
# plot all sites
list2env(lapply(setNames(site_names,
                         make.names(paste0(site_names,
                                           "_phen_plot"))),
                plot_phen),
         envir = .GlobalEnv)

# Set panel layout
panel_layout <- rbind(c(1,2,3,4))

# Combine plots and export
plot_grob <- grid.arrange(ALEXFIORD_phen_plot,
                          BARROW_phen_plot,
                          QHI_phen_plot,
                          ZACKENBERG_phen_plot,
                          layout_matrix = panel_layout)
ggsave(filename = paste0(script_path, "/coastal_phen_plot_MCMCglmm_intmeans.png"),
       plot = plot_grob, scale = 1.7,
       width = 10,
       height = (10/3),
       dpi = 600)

# Second with ZACK SILACA due to large errors
plot_phen <- function(site_to_plot){

  site_colours <- colour_theme_spp_phen[colour_theme_spp_phen$site_name == site_to_plot,]$colour
  site_colour <- colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$colour
  name_pretty <- colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$name_pretty
  site_phen <- coastal_phen %>% filter(site_name == site_to_plot) %>%
    group_by(spp_phen, year) %>% mutate(int_mean = (prior_visit + doy) /2) %>%
    summarise(phen_mean = round(mean(int_mean, na.rm = T)))
  site_phen$spp_phen <- factor(as.character(site_phen$spp_phen))
  site_preds <- phen_predicts %>%
    filter(site_name == site_to_plot)
  site_preds$spp_phen <- factor(site_preds$spp_phen)
  ribbon_alpha <- 0.5
  site_colours_ribbon <- site_colours
  if(site_to_plot == "ZACKENBERG"){
    site_phen$spp_phen <- factor(site_phen$spp_phen, levels = rev(levels(site_phen$spp_phen)))
    site_preds$spp_phen <- factor(site_preds$spp_phen, levels = rev(levels(site_preds$spp_phen)))
    site_colours <- rev(site_colours)
    # Exclude SILACA due to large error bars
    site_colours_ribbon <- c("#FF8A4880", "#D9753D80", "#B3613280", "#8D4C2880", "#67381D80", "#42241380")

    ribbon_alpha <- NA
  }

  ggplot() +
    geom_ribbon(data = site_preds[,], #-which(site_preds$spp_phen == "SILACA_flowering")
                mapping = aes(x = year,
                              ymin = pred_l95,
                              ymax = pred_u95,
                              fill = spp_phen,
                              group = spp_phen),
                alpha = ribbon_alpha,
                inherit.aes = FALSE) +
    geom_point(data = site_phen,
               mapping = aes(x = year,
                             y = phen_mean,
                             colour = spp_phen,
                             fill= spp_phen,
                             group = spp_phen),
               size = 4) +
    geom_line(data = site_preds,
              mapping = aes(x = year,
                            y = pred,
                            colour = spp_phen,
                            group = spp_phen),
              inherit.aes = FALSE,
              size = 1) +
    scale_colour_manual(values = site_colours) +
    scale_fill_manual(values = site_colours_ribbon) +

    scale_x_continuous(limits= c(colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$start_year,
                                 colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$end_year),
                       breaks = seq(1990, 2016, 5)) +
    scale_y_continuous(limits = c(colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$early_doy,
                                  colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$late_doy),
                       breaks = seq(100, 240, 20)) +
    xlab(label = "") +
    ylab(label = ylab_filter("Mean Phenology (DoY)", site_to_plot)) +
    annotate("text", x = (colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$end_year +
                            colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$start_year) / 2,
             y = colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$late_doy,
             label = name_pretty,
             colour = site_colour, size = 7, hjust = 0.5) +
    theme_bw() +
    theme(panel.border = element_blank(),
          panel.grid.major = element_blank(),
          panel.grid.minor = element_blank(),
          axis.line = element_line(colour = "black"),
          axis.text = element_text(colour = "black", size = 15),
          axis.title = element_text(size = 15),
          legend.position = "none")
}
# plot all sites
list2env(lapply(setNames(site_names,
                         make.names(paste0(site_names,
                                           "_phen_plot"))),
                plot_phen),
         envir = .GlobalEnv)

# Set panel layout
panel_layout <- rbind(c(1,2,3,4))

# Combine plots and export
plot_grob <- grid.arrange(ALEXFIORD_phen_plot,
                          BARROW_phen_plot,
                          QHI_phen_plot,
                          ZACKENBERG_phen_plot,
                          layout_matrix = panel_layout)
ggsave(filename = paste0(script_path, "/coastal_phen_plot_MCMCglmm_intmeans_with_SILACA.png"),
       plot = plot_grob, scale = 1.7,
       width = 10,
       height = (10/3),
       dpi = 600)
### Calculate decadal advance ----
phen_trends <- phen_trends %>% mutate(adv_per_dec = slope * 10)

# Min and max advance
phen_trends %>% summarise(min_adv_per_dec = round(min(adv_per_dec),2),
                          max_adv_per_dec = round(max(adv_per_dec),2))

# Export
write.csv(phen_trends, file = paste0(script_path, "coastal_phen_trends.csv"), row.names = F)

# And safe the model files for the record

model_names <- ls()[grep("_model", ls())][-19] # excluding the model function
save(list = model_names, file = paste0(script_path, "models/phen_trend_models.Rda"))

# Check Convergance
lapply(model_names, function(x) {

  png(file = paste0(script_path, "../quality_control/phen_trends/", x, "_sol.png"))
  par(ask = F)
  plot(get(x)$Sol)
  dev.off()

  png(file = paste0(script_path, "../quality_control/phen_trends/", x, "_vcv.png"))
  par(ask = F)
  plot(get(x)$VCV)
  dev.off()

  }
  )
# Check summaries
for(x in 1:length(model_names)){
  print(model_names[x])
  print(summary(get(model_names[x])))
  readline("Hit button to see next summary:")
  }
summary(get(model_names[1]))

#
# ####### Aditional calcs: 1) Begining of season data -5 instead of -10 ----
#
# rm(list = ls())
# # Housekeeping
# script_path <- "scripts/users/jassmann/phenology/coastal_phenology/"
# load(file =paste0(script_path, "coastal_phen.Rda"))
#
# # remove NAs (211 values)
# coastal_phen <- coastal_phen[!is.na(coastal_phen$doy),]
#
# # Site names
# site_names <- unique(as.character(coastal_phen$site_name))
#
# # Site spp phen combos
# site_spp_phen_combos <- unique(coastal_phen$site_spp_phen)
#
# # Spp phen combos
# spp_phen_combos <- sort(unique(coastal_phen$site_spp_phen))
#
# # Set colours
# colour_theme_sites <- data.frame(site_name = c(site_names),
#                                  colour = c("#324D5CFF",
#                                             "#46B29DFF",
#                                             "#C2A33EFF",
#                                             "#E37B40FF")) # 5th colour #F53855FF
# colour_theme_spp_phen <- data.frame(site_name = c(rep(site_names[1], 8),
#                                                   rep(site_names[2], 7),
#                                                   rep(site_names[3], 3),
#                                                   rep(site_names[4], 6)),
#                                     site_spp_phen = spp_phen_combos,
#                                     spp_phen = c(unique(as.character(coastal_phen[coastal_phen$site_name == site_names[1],]$spp_phen)),
#                                                  unique(as.character(coastal_phen[coastal_phen$site_name == site_names[2],]$spp_phen)),
#                                                  unique(as.character(coastal_phen[coastal_phen$site_name == site_names[3],]$spp_phen)),
#                                                  unique(as.character(coastal_phen[coastal_phen$site_name == site_names[4],]$spp_phen))),
#                                     colour = c(
#                                       colorRampPalette(c("#19262EFF","#84CBF2FF"),
#                                                        interpolate = "linear")(8), # ALEXFIIORD
#                                       colorRampPalette(c("#112B26FF","#5BE8CDFF"),
#                                                        interpolate = "linear")(7), # BARROW
#                                       colorRampPalette(c("#382F12FF","#C2A33EFF"),
#                                                        interpolate = "linear")(3), # QHI
#                                       colorRampPalette(c("#422413FF","#FF8A48FF"),
#                                                        interpolate = "linear")(6) # ZACKENBERG
#                                     ), stringsAsFactors = F)
#
# # Helper function that returns ylab only for Alexfiord (first site)
# ylab_filter <- function(label, site_to_plot){
#   if(site_to_plot == "ALEXFIORD") {
#     return(label)
#   } else {
#     return("")
#   }
# }
#
#
# # adjust data set
# coastal_phen[(coastal_phen$doy - coastal_phen$prior_visit) == 10,
#              ]$prior_visit <-
#   coastal_phen[(coastal_phen$doy - coastal_phen$prior_visit) == 10,
#                ]$doy - 5
# # Define function to run MCMCglmm models
# trend_model <- function(site_spp_sphen_select){
#   cphen_subset <- coastal_phen %>%
#     filter(site_spp_phen == site_spp_sphen_select)
#   model <- MCMCglmm(cbind(prior_visit, doy) ~ year, data = as.data.frame(cphen_subset),
#                     family = "cengaussian",
#                     nitt = 20000)
#   return(model)
# }
#
# # Execute over all site_spp_phen_combinations
# model_list <- lapply(site_spp_phen_combos, trend_model)
# names(model_list) <- make.names(paste0(site_spp_phen_combos, "_model"))
# list2env(model_list, envir = .GlobalEnv)
#
# ### Gather outputs
# ## Prep data frame
# phen_trends <- data.frame(site_spp_phen = site_spp_phen_combos,
#                           intercept = NA,
#                           intercept_l95 = NA,
#                           intercept_u95 = NA,
#                           intercept_esmpl = NA,
#                           intercept_pMCMC = NA,
#                           slope = NA,
#                           slope_l95 = NA,
#                           slope_u95 = NA,
#                           slope_esmpl = NA,
#                           slope_pMCMC = NA)
# ## Define funciton to extract slope parameters and estimates
# extr_outputs <- function(site_spp_sphen_select){
#   model <- get(paste0(site_spp_sphen_select, "_model"))
#   model_sum <- summary(model)
#   # retrive row index for output dataframe
#   row_no <- which(phen_trends$site_spp_phen == site_spp_sphen_select)
#   # use one liners to extract intersept and slope estimators
#   phen_trends[row_no,2:6] <<- model_sum$solutions[1,]
#   phen_trends[row_no,7:11] <<- model_sum$solutions[2,]
# }
#
# ## Apply to all site_spp_phen combos
# lapply(site_spp_phen_combos, extr_outputs)
#
# ### Claculate predictions
# # prep data frame
# phen_predicts <- data.frame(site_spp_phen = coastal_phen %>%
#                               select(site_spp_phen, year) %>%
#                               distinct(site_spp_phen, year) %>%
#                               select(site_spp_phen) %>%
#                               unlist() %>%
#                               as.character(),
#                             year = coastal_phen %>%
#                               select(site_spp_phen, year) %>%
#                               distinct(site_spp_phen, year) %>%
#                               select(year) %>%
#                               unlist() %>%
#                               as.numeric(),
#                             pred = NA,
#                             pred_l95 = NA,
#                             pred_u95 = NA)
#
# # Define function to extract predicitons
# extract_pred <- function(site_spp_phen_select){
#   model <- get(paste0(site_spp_phen_select, "_model"))
#   row_nos <- which(phen_predicts$site_spp_phen == site_spp_phen_select)
#   preds <- predict.MCMCglmm(model, interval = "confidence", type = "response")
#   preds <- unique(data.frame(preds, year = as.numeric(model$X[,2])))
#   preds <- preds[,c(4,1,2,3)]
#   phen_predicts[row_nos, 3:5] <<- preds[,2:4]
#   paste0("Done with: ", site_spp_phen_select, " ;")
# }
# lapply(site_spp_phen_combos, extract_pred)
#
# # create site name and spp_phen columns
# phen_predicts$site_name <- gsub("_.*", "", phen_predicts$site_spp_phen)
# phen_predicts$spp_phen <- gsub("^[A-Z]*_", "", phen_predicts$site_spp_phen)
#
# ### Plot phenology data with trends ----
# plot_phen <- function(site_to_plot){
#
#   site_colours <- colour_theme_spp_phen[colour_theme_spp_phen$site_name == site_to_plot,]$colour
#   site_colour <- colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$colour
#   site_phen <- coastal_phen %>% filter(site_name == site_to_plot) %>%
#     group_by(spp_phen, year) %>% summarise(phen_mean = round(mean(doy, na.rm = T)))
#
#   site_preds <- phen_predicts %>%
#     filter(site_name == site_to_plot)
#
#   ggplot(data = site_phen, aes(x = year,
#                                y = phen_mean,
#                                colour = spp_phen,
#                                fill= spp_phen,
#                                group = spp_phen)) +
#     scale_colour_manual(values = site_colours) +
#     scale_fill_manual(values = site_colours) +
#     geom_point(size = 4) +
#     geom_ribbon(data = site_preds,
#                 mapping = aes(x = year,
#                               ymin = pred_l95,
#                               ymax = pred_u95,
#                               fill = spp_phen,
#                               group = spp_phen),
#                 alpha = 0.5,
#                 inherit.aes = FALSE) +
#     geom_line(data = site_preds,
#               mapping = aes(x = year,
#                             y = pred,
#                             colour = spp_phen,
#                             group = spp_phen),
#               inherit.aes = FALSE,
#               size = 1) +
#     scale_x_continuous(limits= c(1990, 2016), breaks = seq(1990, 2016, 5)) +
#     scale_y_continuous(limits = c(90, 250), breaks = seq(100, 240, 20)) +
#     xlab(label = "") +
#     ylab(label = ylab_filter("Mean Phenology (DoY)", site_to_plot)) +
#     annotate("text", x = 2014, y = 245, label = site_to_plot,
#              colour = site_colour, size = 7, hjust = 1) +
#     theme_bw() +
#     theme(panel.border = element_blank(),
#           panel.grid.major = element_blank(),
#           panel.grid.minor = element_blank(),
#           axis.line = element_line(colour = "black"),
#           axis.text = element_text(colour = "black", size = 15),
#           axis.title = element_text(size = 15),
#           legend.position = "none")
# }
# # plot all sites
# list2env(lapply(setNames(site_names,
#                          make.names(paste0(site_names,
#                                            "_phen_plot"))),
#                 plot_phen),
#          envir = .GlobalEnv)
#
# # Set panel layout
# panel_layout <- rbind(c(1,2,3,4))
#
# # Combine plots and export
# plot_grob <- grid.arrange(ALEXFIORD_phen_plot,
#                           BARROW_phen_plot,
#                           QHI_phen_plot,
#                           ZACKENBERG_phen_plot,
#                           layout_matrix = panel_layout)
# ggsave(filename = paste0(script_path, "/coastal_phen_plot_MCMCglmm_5d.png"),
#        plot = plot_grob, scale = 1.7,
#        width = 10,
#        height = (10/3),
#        dpi = 600)
#
# ### Calculate decadal advance ----
# phen_trends <- phen_trends %>% mutate(adv_per_dec = slope * 10)
#
# # Min and max advance
# phen_trends %>% summarise(min_adv_per_dec = round(min(adv_per_dec),2),
#                           max_adv_per_dec = round(max(adv_per_dec),2))
#
# # Export
# write.csv(phen_trends, file = paste0(script_path, "coastal_phen_trends_5d.csv"), row.names = F)
#
#
#
#
# ####### Aditional calcs: 2) Begining of season data -20 instead of -10 ----
#
# rm(list = ls())
# # Housekeeping
# script_path <- "scripts/users/jassmann/phenology/coastal_phenology/"
# load(file =paste0(script_path, "coastal_phen.Rda"))
#
# # remove NAs (211 values)
# coastal_phen <- coastal_phen[!is.na(coastal_phen$doy),]
#
# # Site names
# site_names <- unique(as.character(coastal_phen$site_name))
#
# # Site spp phen combos
# site_spp_phen_combos <- unique(coastal_phen$site_spp_phen)
#
# # Spp phen combos
# spp_phen_combos <- sort(unique(coastal_phen$site_spp_phen))
#
# # Set colours
# colour_theme_sites <- data.frame(site_name = c(site_names),
#                                  colour = c("#324D5CFF",
#                                             "#46B29DFF",
#                                             "#C2A33EFF",
#                                             "#E37B40FF")) # 5th colour #F53855FF
# colour_theme_spp_phen <- data.frame(site_name = c(rep(site_names[1], 8),
#                                                   rep(site_names[2], 7),
#                                                   rep(site_names[3], 3),
#                                                   rep(site_names[4], 6)),
#                                     site_spp_phen = spp_phen_combos,
#                                     spp_phen = c(unique(as.character(coastal_phen[coastal_phen$site_name == site_names[1],]$spp_phen)),
#                                                  unique(as.character(coastal_phen[coastal_phen$site_name == site_names[2],]$spp_phen)),
#                                                  unique(as.character(coastal_phen[coastal_phen$site_name == site_names[3],]$spp_phen)),
#                                                  unique(as.character(coastal_phen[coastal_phen$site_name == site_names[4],]$spp_phen))),
#                                     colour = c(
#                                       colorRampPalette(c("#19262EFF","#84CBF2FF"),
#                                                        interpolate = "linear")(8), # ALEXFIIORD
#                                       colorRampPalette(c("#112B26FF","#5BE8CDFF"),
#                                                        interpolate = "linear")(7), # BARROW
#                                       colorRampPalette(c("#382F12FF","#C2A33EFF"),
#                                                        interpolate = "linear")(3), # QHI
#                                       colorRampPalette(c("#422413FF","#FF8A48FF"),
#                                                        interpolate = "linear")(6) # ZACKENBERG
#                                     ), stringsAsFactors = F)
#
# # Helper function that returns ylab only for Alexfiord (first site)
# ylab_filter <- function(label, site_to_plot){
#   if(site_to_plot == "ALEXFIORD") {
#     return(label)
#   } else {
#     return("")
#   }
# }
#
# # Define function to run MCMCglmm models
# trend_model <- function(site_spp_sphen_select){
#   cphen_subset <- coastal_phen %>%
#     filter(site_spp_phen == site_spp_sphen_select)
#   model <- MCMCglmm(cbind(prior_visit, doy) ~ year, data = as.data.frame(cphen_subset),
#                     family = "cengaussian",
#                     nitt = 20000)
#   return(model)
# }
#
#
# # adjust data set
# # NB re-run begining of script to re-load data
# coastal_phen[(coastal_phen$doy - coastal_phen$prior_visit) == 10,
#              ]$prior_visit <-
#   coastal_phen[(coastal_phen$doy - coastal_phen$prior_visit) == 10,
#                ]$doy - 20
#
# # Execute over all site_spp_phen_combinations
# model_list <- lapply(site_spp_phen_combos, trend_model)
# names(model_list) <- make.names(paste0(site_spp_phen_combos, "_model"))
# list2env(model_list, envir = .GlobalEnv)
#
# ### Gather outputs
# ## Prep data frame
# phen_trends <- data.frame(site_spp_phen = site_spp_phen_combos,
#                           intercept = NA,
#                           intercept_l95 = NA,
#                           intercept_u95 = NA,
#                           intercept_esmpl = NA,
#                           intercept_pMCMC = NA,
#                           slope = NA,
#                           slope_l95 = NA,
#                           slope_u95 = NA,
#                           slope_esmpl = NA,
#                           slope_pMCMC = NA)
# ## Define funciton to extract slope parameters and estimates
# extr_outputs <- function(site_spp_sphen_select){
#   model <- get(paste0(site_spp_sphen_select, "_model"))
#   model_sum <- summary(model)
#   # retrive row index for output dataframe
#   row_no <- which(phen_trends$site_spp_phen == site_spp_sphen_select)
#   # use one liners to extract intersept and slope estimators
#   phen_trends[row_no,2:6] <<- model_sum$solutions[1,]
#   phen_trends[row_no,7:11] <<- model_sum$solutions[2,]
# }
#
# ## Apply to all site_spp_phen combos
# lapply(site_spp_phen_combos, extr_outputs)
#
# ### Claculate predictions
# # prep data frame
# phen_predicts <- data.frame(site_spp_phen = coastal_phen %>%
#                               select(site_spp_phen, year) %>%
#                               distinct(site_spp_phen, year) %>%
#                               select(site_spp_phen) %>%
#                               unlist() %>%
#                               as.character(),
#                             year = coastal_phen %>%
#                               select(site_spp_phen, year) %>%
#                               distinct(site_spp_phen, year) %>%
#                               select(year) %>%
#                               unlist() %>%
#                               as.numeric(),
#                             pred = NA,
#                             pred_l95 = NA,
#                             pred_u95 = NA)
#
# # Define function to extract predicitons
# extract_pred <- function(site_spp_phen_select){
#   model <- get(paste0(site_spp_phen_select, "_model"))
#   row_nos <- which(phen_predicts$site_spp_phen == site_spp_phen_select)
#   preds <- predict.MCMCglmm(model, interval = "confidence", type = "response")
#   preds <- unique(data.frame(preds, year = as.numeric(model$X[,2])))
#   preds <- preds[,c(4,1,2,3)]
#   phen_predicts[row_nos, 3:5] <<- preds[,2:4]
#   paste0("Done with: ", site_spp_phen_select, " ;")
# }
# lapply(site_spp_phen_combos, extract_pred)
#
# # create site name and spp_phen columns
# phen_predicts$site_name <- gsub("_.*", "", phen_predicts$site_spp_phen)
# phen_predicts$spp_phen <- gsub("^[A-Z]*_", "", phen_predicts$site_spp_phen)
#
# ### Plot phenology data with trends ----
# plot_phen <- function(site_to_plot){
#
#   site_colours <- colour_theme_spp_phen[colour_theme_spp_phen$site_name == site_to_plot,]$colour
#   site_colour <- colour_theme_sites[colour_theme_sites$site_name == site_to_plot,]$colour
#   site_phen <- coastal_phen %>% filter(site_name == site_to_plot) %>%
#     group_by(spp_phen, year) %>% summarise(phen_mean = round(mean(doy, na.rm = T)))
#
#   site_preds <- phen_predicts %>%
#     filter(site_name == site_to_plot)
#
#   ggplot(data = site_phen, aes(x = year,
#                                y = phen_mean,
#                                colour = spp_phen,
#                                fill= spp_phen,
#                                group = spp_phen)) +
#     scale_colour_manual(values = site_colours) +
#     scale_fill_manual(values = site_colours) +
#     geom_point(size = 4) +
#     geom_line(data = site_preds,
#               mapping = aes(x = year,
#                             y = pred,
#                             colour = spp_phen,
#                             group = spp_phen),
#               inherit.aes = FALSE,
#               size = 1) +
#     geom_ribbon(data = site_preds,
#                 mapping = aes(x = year,
#                               ymin = pred_l95,
#                               ymax = pred_u95,
#                               fill = spp_phen,
#                               group = spp_phen),
#                 alpha = 0.5,
#                 inherit.aes = FALSE) +
#     scale_x_continuous(limits= c(1990, 2016), breaks = seq(1990, 2016, 5)) +
#     scale_y_continuous(limits = c(90, 250), breaks = seq(100, 240, 20)) +
#     xlab(label = "") +
#     ylab(label = ylab_filter("Mean Phenology (DoY)", site_to_plot)) +
#     annotate("text", x = 2014, y = 245, label = site_to_plot,
#              colour = site_colour, size = 7, hjust = 1) +
#     theme_bw() +
#     theme(panel.border = element_blank(),
#           panel.grid.major = element_blank(),
#           panel.grid.minor = element_blank(),
#           axis.line = element_line(colour = "black"),
#           axis.text = element_text(colour = "black", size = 15),
#           axis.title = element_text(size = 15),
#           legend.position = "none")
# }
# # plot all sites
# list2env(lapply(setNames(site_names,
#                          make.names(paste0(site_names,
#                                            "_phen_plot"))),
#                 plot_phen),
#          envir = .GlobalEnv)
#
# # Set panel layout
# panel_layout <- rbind(c(1,2,3,4))
#
# # Combine plots and export
# plot_grob <- grid.arrange(ALEXFIORD_phen_plot,
#                           BARROW_phen_plot,
#                           QHI_phen_plot,
#                           ZACKENBERG_phen_plot,
#                           layout_matrix = panel_layout)
# ggsave(filename = paste0(script_path, "/coastal_phen_plot_MCMCglmm_20d.png"),
#        plot = plot_grob, scale = 1.7,
#        width = 10,
#        height = (10/3),
#        dpi = 600)
#
# ### Calculate decadal advance ----
# phen_trends <- phen_trends %>% mutate(adv_per_dec = slope * 10)
#
# # Min and max advance
# phen_trends %>% summarise(min_adv_per_dec = round(min(adv_per_dec),2),
#                           max_adv_per_dec = round(max(adv_per_dec),2))
#
# # Export
# write.csv(phen_trends, file = paste0(script_path, "coastal_phen_trends_20d.csv"), row.names = F)
#


#########################################################################################
# License Agreement
#
# THIS WORK IS PROVIDED UNDER THE TERMS OF THIS CREATIVE COMMONS PUBLIC LICENSE
# ("CCPL" OR "LICENSE"). THE WORK IS PROTECTED BY COPYRIGHT AND/OR OTHER
# APPLICABLE LAW. ANY USE OF THE WORK OTHER THAN AS AUTHORIZED UNDER THIS LICENSE
# OR COPYRIGHT LAW IS PROHIBITED.
#
# BY EXERCISING ANY RIGHTS TO THE WORK PROVIDED HERE, YOU ACCEPT AND AGREE TO BE
# BOUND BY THE TERMS OF THIS LICENSE. TO THE EXTENT THIS LICENSE MAY BE CONSIDERED
# TO BE A CONTRACT, THE LICENSOR GRANTS YOU THE RIGHTS CONTAINED HERE IN
# CONSIDERATION OF YOUR ACCEPTANCE OF SUCH TERMS AND CONDITIONS.
#
# BASELIne: Bayesian Estimation of Antigen-Driven Selection in Immunoglobulin Sequences
# Coded by: Mohamed Uduman & Gur Yaari
# Copyright 2012 Kleinstein Lab
# Version: 1.3 (01/23/2014)
#########################################################################################

op <- options();
options(showWarnCalls=FALSE, showErrorCalls=FALSE, warn=-1)
library('seqinr')
if( F & Sys.info()[1]=="Linux"){
  library("multicore")
}

# Load functions and initialize global variables
source("Baseline_Functions.r")

# Initialize parameters with user provided arguments
  arg <- commandArgs(TRUE)
  #arg = c(2,1,5,5,0,1,"1:26:38:55:65:104:116", "test.fasta","","sample")
  #arg = c(1,1,5,5,0,1,"1:38:55:65:104:116:200", "test.fasta","","sample")
  #arg = c(1,1,5,5,1,1,"1:26:38:55:65:104:116", "/home/mu37/Wu/Wu_Cloned_gapped_sequences_D-masked.fasta","/home/mu37/Wu/","Wu")
  testID <- as.numeric(arg[1])                    # 1 = Focused, 2 = Local
  species <- as.numeric(arg[2])                   # 1 = Human. 2 = Mouse
  substitutionModel <- as.numeric(arg[3])         # 0 = Uniform substitution, 1 = Smith DS et al. 1996, 5 = FiveS
  mutabilityModel <- as.numeric(arg[4])           # 0 = Uniform mutablity, 1 = Tri-nucleotide (Shapiro GS et al. 2002)  , 5 = FiveS
  clonal <- as.numeric(arg[5])                    # 0 = Independent sequences, 1 = Clonally related, 2 = Clonally related & only non-terminal mutations
  fixIndels <- as.numeric(arg[6])                 # 0 = Do nothing, 1 = Try and fix Indels
  region <- as.numeric(strsplit(arg[7],":")[[1]]) # StartPos:LastNucleotideF1:C1:F2:C2:F3:C3
  inputFilePath <- arg[8]                         # Full path to input file
  outputPath <- arg[9]                            # Full path to location of output files
  outputID <- arg[10]                             # ID for session output

  if(testID==5){
    traitChangeModel <- 1
    if( !is.na(any(arg[11])) ) traitChangeModel <- as.numeric(arg[11])    # 1 <- Chothia 1998
    initializeTraitChange(traitChangeModel)
  }

# Initialize other parameters/variables

  # Initialzie the codon table ( definitions of R/S )
  computeCodonTable(testID)

  # Initialize
  # Test Name
  testName<-"Focused"
  if(testID==2) testName<-"Local"
  if(testID==3) testName<-"Imbalanced"
  if(testID==4) testName<-"ImbalancedSilent"

  # Indel placeholders initialization
  indelPos <- NULL
  delPos <- NULL
  insPos <- NULL

  # Initialize in Tranistion & Mutability matrixes
  substitution <- initializeSubstitutionMatrix(substitutionModel,species)
  mutability <- initializeMutabilityMatrix(mutabilityModel,species)

  # FWR/CDR boundaries
  flagTrim <- F
  if( is.na(region[7])){
    flagTrim <- T
    region[7]<-region[6]
  }
  readStart = min(region,na.rm=T)
  readEnd = max(region,na.rm=T)
  if(readStart>1){
    region = region - (readStart - 1)
  }
  region_Nuc = c( (region[1]*3-2) , (region[2:7]*3) )
  region_Cod = region

  readStart = (readStart*3)-2
  readEnd = (readEnd*3)

    FWR_Nuc <- c( rep(TRUE,(region_Nuc[2])),
                  rep(FALSE,(region_Nuc[3]-region_Nuc[2])),
                  rep(TRUE,(region_Nuc[4]-region_Nuc[3])),
                  rep(FALSE,(region_Nuc[5]-region_Nuc[4])),
                  rep(TRUE,(region_Nuc[6]-region_Nuc[5])),
                  rep(FALSE,(region_Nuc[7]-region_Nuc[6]))
                )
    CDR_Nuc <- (1-FWR_Nuc)
    CDR_Nuc <- as.logical(CDR_Nuc)
    FWR_Nuc_Mat <- matrix( rep(FWR_Nuc,4), ncol=length(FWR_Nuc), nrow=4, byrow=T)
    CDR_Nuc_Mat <- matrix( rep(CDR_Nuc,4), ncol=length(CDR_Nuc), nrow=4, byrow=T)

    FWR_Codon <- c( rep(TRUE,(region[2])),
                  rep(FALSE,(region[3]-region[2])),
                  rep(TRUE,(region[4]-region[3])),
                  rep(FALSE,(region[5]-region[4])),
                  rep(TRUE,(region[6]-region[5])),
                  rep(FALSE,(region[7]-region[6]))
                )
    CDR_Codon <- (1-FWR_Codon)
    CDR_Codon <- as.logical(CDR_Codon)

# Read input FASTA file
  tryCatch(
    inputFASTA <- baseline.read.fasta(inputFilePath, seqtype="DNA",as.string=T,set.attributes=F,forceDNAtolower=F)
    , error = function(ex){
      cat("Error|Error reading input. Please enter or upload a valid FASTA file.\n")
      q()
    }
  )

  if (length(inputFASTA)==1) {
    cat("Error|Error reading input. Please enter or upload a valid FASTA file.\n")
    q()
  }

  # Process sequence IDs/names
  names(inputFASTA) <- sapply(names(inputFASTA),function(x){trim(x)})

  # Convert non nucleotide characters to N
  inputFASTA[length(inputFASTA)] = gsub("\t","",inputFASTA[length(inputFASTA)])
  inputFASTA <- lapply(inputFASTA,replaceNonFASTAChars)

  # Process the FASTA file and conver to Matrix[inputSequence, germlineSequence]
  processedInput <- processInputAdvanced(inputFASTA)
  matInput <- processedInput[[1]]
  germlines <- processedInput[[2]]
  lenGermlines = length(unique(germlines))
  groups <- processedInput[[3]]
  lenGroups = length(unique(groups))
  rm(processedInput)
  rm(inputFASTA)

#   # remove clones with less than 2 seqeunces
#   tableGL <- table(germlines)
#   singletons <- which(tableGL<8)
#   rowsToRemove <- match(singletons,germlines)
#   if(any(rowsToRemove)){
#     matInput <- matInput[-rowsToRemove,]
#     germlines <- germlines[-rowsToRemove]
#     groups <- groups[-rowsToRemove]
#   }
#
#   # remove unproductive seqs
#   nonFuctionalSeqs <- sapply(rownames(matInput),function(x){any(grep("unproductive",x))})
#   if(any(nonFuctionalSeqs)){
#     if(sum(nonFuctionalSeqs)==length(germlines)){
#       write.table("Unproductive",file=paste(outputPath,outputID,".txt",sep=""),quote=F,sep="\t",row.names=F,col.names=T)
#       q()
#     }
#     matInput <- matInput[-which(nonFuctionalSeqs),]
#     germlines <- germlines[-which(nonFuctionalSeqs)]
#     germlines[1:length(germlines)] <- 1:length(germlines)
#     groups <- groups[-which(nonFuctionalSeqs)]
#   }
#
#   if(class(matInput)=="character"){
#     write.table("All unproductive seqs",file=paste(outputPath,outputID,".txt",sep=""),quote=F,sep="\t",row.names=F,col.names=T)
#     q()
#   }
#
#   if(nrow(matInput)<10 | is.null(nrow(matInput))){
#     write.table(paste(nrow(matInput), "seqs only",sep=""),file=paste(outputPath,outputID,".txt",sep=""),quote=F,sep="\t",row.names=F,col.names=T)
#     q()
#   }

# replace leading & trailing "-" with "N:
  matInput <- t(apply(matInput,1,replaceLeadingTrailingDashes,readEnd))

  # Trim (nucleotide) input sequences to the last codon
  #matInput[,1] <- apply(matrix(matInput[,1]),1,trimToLastCodon)

#   # Check for Indels
#   if(fixIndels){
#     delPos <- fixDeletions(matInput)
#     insPos <- fixInsertions(matInput)
#   }else{
#     # Check for indels
#     indelPos <- checkForInDels(matInput)
#     indelPos <- apply(cbind(indelPos[[1]],indelPos[[2]]),1,function(x){(x[1]==T & x[2]==T)})
#   }

  # If indels are present, remove mutations in the seqeunce & throw warning at end
  #matInput[indelPos,] <- apply(matrix(matInput[indelPos,],nrow=sum(indelPos),ncol=2),1,function(x){x[1]=x[2]; return(x) })

  colnames(matInput)=c("Input","Germline")

  # If seqeunces are clonal, create effective sequence for each clone & modify germline/group definitions
  germlinesOriginal = NULL
  if(clonal){
    germlinesOriginal <- germlines
    collapseCloneResults <- tapply(1:nrow(matInput),germlines,function(i){
                                                                collapseClone(matInput[i,1],matInput[i[1],2],readEnd,nonTerminalOnly=(clonal-1))
                                                              })
    matInput = t(sapply(collapseCloneResults,function(x){return(x[[1]])}))
    names_groups = tapply(groups,germlines,function(x){names(x[1])})
    groups = tapply(groups,germlines,function(x){array(x[1],dimnames=names(x[1]))})
    names(groups) = names_groups

    names_germlines =  tapply(germlines,germlines,function(x){names(x[1])})
    germlines = tapply(   germlines,germlines,function(x){array(x[1],dimnames=names(x[1]))}   )
    names(germlines) = names_germlines
    matInputErrors = sapply(collapseCloneResults,function(x){return(x[[2]])})
  }

# Selection Analysis

#  if (length(germlines)>sequenceLimit) {
#    # Code to parallelize processing goes here
#    stop( paste("Error: Cannot process more than ", Upper_limit," sequences",sep="") )
#  }

#  if (length(germlines)<sequenceLimit) {}

    # Compute expected mutation frequencies
    matExpected <- getExpectedIndividual(matInput)

    # Count observed number of mutations in the different regions
    mutations <- lapply( 1:nrow(matInput),  function(i){
                                              #cat(i,"\n")
                                              seqI = s2c(matInput[i,1])
                                              seqG = s2c(matInput[i,2])
                                              matIGL = matrix(c(seqI,seqG),ncol=length(seqI),nrow=2,byrow=T)
                                              retVal <- NA
                                              tryCatch(
                                                retVal <- analyzeMutations2NucUri(matIGL)
                                                , error = function(ex){
                                                  retVal <- NA
                                                }
                                              )

                                              return( retVal )
                                            })

    matObserved <- t(sapply( mutations, processNucMutations2 ))
    numberOfSeqsWithMutations <- numberOfSeqsWithMutations(matObserved, testID)

    #if(sum(numberOfSeqsWithMutations)==0){
    #  write.table("No mutated sequences",file=paste(outputPath,outputID,".txt",sep=""),quote=F,sep="\t",row.names=F,col.names=T)
    #  q()
    #}

    matMutationInfo <- cbind(matObserved,matExpected)
    rm(matObserved,matExpected)

    #Bayesian  PDFs
    bayes_pdf = computeBayesianScore(matMutationInfo, test=testName, max_sigma=20,length_sigma=4001)
    bayesPDF_cdr = bayes_pdf[[1]]
    bayesPDF_fwr = bayes_pdf[[2]]
    rm(bayes_pdf)

    bayesPDF_germlines_cdr = tapply(bayesPDF_cdr,germlines,function(x) groupPosteriors(x,length_sigma=4001))
    bayesPDF_germlines_fwr = tapply(bayesPDF_fwr,germlines,function(x) groupPosteriors(x,length_sigma=4001))

    bayesPDF_groups_cdr = tapply(bayesPDF_cdr,groups,function(x) groupPosteriors(x,length_sigma=4001))
    bayesPDF_groups_fwr = tapply(bayesPDF_fwr,groups,function(x) groupPosteriors(x,length_sigma=4001))

    if(lenGroups>1){
      groups <- c(groups,lenGroups+1)
      names(groups)[length(groups)] = "All sequences combined"
      bayesPDF_groups_cdr[[lenGroups+1]] =   groupPosteriors(bayesPDF_groups_cdr,length_sigma=4001)
      bayesPDF_groups_fwr[[lenGroups+1]] =   groupPosteriors(bayesPDF_groups_fwr,length_sigma=4001)
    }

    #Bayesian  Outputs
    bayes_cdr =  t(sapply(bayesPDF_cdr,calcBayesOutputInfo))
    bayes_fwr =  t(sapply(bayesPDF_fwr,calcBayesOutputInfo))
    bayes_germlines_cdr =  t(sapply(bayesPDF_germlines_cdr,calcBayesOutputInfo))
    bayes_germlines_fwr =  t(sapply(bayesPDF_germlines_fwr,calcBayesOutputInfo))
    bayes_groups_cdr =  t(sapply(bayesPDF_groups_cdr,calcBayesOutputInfo))
    bayes_groups_fwr =  t(sapply(bayesPDF_groups_fwr,calcBayesOutputInfo))

    #P-values
    simgaP_cdr = sapply(bayesPDF_cdr,computeSigmaP)
    simgaP_fwr = sapply(bayesPDF_fwr,computeSigmaP)

    simgaP_germlines_cdr = sapply(bayesPDF_germlines_cdr,computeSigmaP)
    simgaP_germlines_fwr = sapply(bayesPDF_germlines_fwr,computeSigmaP)

    simgaP_groups_cdr = sapply(bayesPDF_groups_cdr,computeSigmaP)
    simgaP_groups_fwr = sapply(bayesPDF_groups_fwr,computeSigmaP)

    #Format output

    # Round expected mutation frequencies to 3 decimal places
    matMutationInfo[germlinesOriginal[indelPos],] = NA
    if(nrow(matMutationInfo)==1){
      matMutationInfo[5:8] = round(matMutationInfo[,5:8]/sum(matMutationInfo[,5:8],na.rm=T),3)
    }else{
      matMutationInfo[,5:8] = t(round(apply(matMutationInfo[,5:8],1,function(x){ return(x/sum(x,na.rm=T)) }),3))
    }

    listPDFs = list()
    nRows = length(unique(groups)) + length(unique(germlines)) + length(groups)

    matOutput = matrix(NA,ncol=18,nrow=nRows)
    rowNumb = 1
    for(G in unique(groups)){
      #print(G)
      matOutput[rowNumb,c(1,2,11:18)] = c("Group",names(groups)[groups==G][1],bayes_groups_cdr[G,],bayes_groups_fwr[G,],simgaP_groups_cdr[G],simgaP_groups_fwr[G])
      listPDFs[[rowNumb]] = list("CDR"=bayesPDF_groups_cdr[[G]],"FWR"=bayesPDF_groups_fwr[[G]])
      names(listPDFs)[rowNumb] = names(groups[groups==paste(G)])[1]
      #if(names(groups)[which(groups==G)[1]]!="All sequences combined"){
      gs = unique(germlines[groups==G])
      rowNumb = rowNumb+1
      if( !is.na(gs) ){
        for( g in gs ){
          matOutput[rowNumb,c(1,2,11:18)] = c("Germline",names(germlines)[germlines==g][1],bayes_germlines_cdr[g,],bayes_germlines_fwr[g,],simgaP_germlines_cdr[g],simgaP_germlines_fwr[g])
          listPDFs[[rowNumb]] = list("CDR"=bayesPDF_germlines_cdr[[g]],"FWR"=bayesPDF_germlines_fwr[[g]])
          names(listPDFs)[rowNumb] = names(germlines[germlines==paste(g)])[1]
          rowNumb = rowNumb+1
          indexesOfInterest = which(germlines==g)
          numbSeqsOfInterest =  length(indexesOfInterest)
          rowNumb = seq(rowNumb,rowNumb+(numbSeqsOfInterest-1))
          matOutput[rowNumb,] = matrix(   c(  rep("Sequence",numbSeqsOfInterest),
                                              rownames(matInput)[indexesOfInterest],
                                              c(matMutationInfo[indexesOfInterest,1:4]),
                                              c(matMutationInfo[indexesOfInterest,5:8]),
                                              c(bayes_cdr[indexesOfInterest,]),
                                              c(bayes_fwr[indexesOfInterest,]),
                                              c(simgaP_cdr[indexesOfInterest]),
                                              c(simgaP_fwr[indexesOfInterest])
          ), ncol=18, nrow=numbSeqsOfInterest,byrow=F)
          increment=0
          for( ioi in indexesOfInterest){
            listPDFs[[min(rowNumb)+increment]] =  list("CDR"=bayesPDF_cdr[[ioi]] , "FWR"=bayesPDF_fwr[[ioi]])
            names(listPDFs)[min(rowNumb)+increment] = rownames(matInput)[ioi]
            increment = increment + 1
          }
          rowNumb=max(rowNumb)+1

        }
      }
    }
    colsToFormat = 11:18
    matOutput[,colsToFormat] = formatC(  matrix(as.numeric(matOutput[,colsToFormat]), nrow=nrow(matOutput), ncol=length(colsToFormat)) ,  digits=3)
    matOutput[matOutput== " NaN"] = NA

    colnames(matOutput) = c("Type", "ID", "Observed_CDR_R", "Observed_CDR_S", "Observed_FWR_R", "Observed_FWR_S",
                            "Expected_CDR_R", "Expected_CDR_S", "Expected_FWR_R", "Expected_FWR_S",
                            paste( rep(testName,6), rep(c("Sigma","CIlower","CIupper"),2),rep(c("CDR","FWR"),each=3), sep="_"),
                            paste( rep(testName,2), rep("P",2),c("CDR","FWR"), sep="_")
    )
    fileName = paste(outputPath,outputID,".txt",sep="")
    write.table(matOutput,file=fileName,quote=F,sep="\t",row.names=T,col.names=NA)
    fileName = paste(outputPath,outputID,".RData",sep="")
    save(listPDFs,file=fileName)

indelWarning = FALSE
if(sum(indelPos)>0){
  indelWarning = "
Warning: The following sequences have either gaps and/or deletions, and have been ommited from the analysis.";
  indelWarning = paste( indelWarning , "
", sep="" )
  for(indels in names(indelPos)[indelPos]){
    indelWarning = paste( indelWarning , "
", indels, "
", sep="" )
  }
  indelWarning = paste( indelWarning , "

", sep="" )
}

cloneWarning = FALSE
if(clonal==1){
  if(sum(matInputErrors)>0){
    cloneWarning = "
Warning: The following clones have sequences of unequal length.";
    cloneWarning = paste( cloneWarning , "
", sep="" )
    for(clone in names(matInputErrors)[matInputErrors]){
      cloneWarning = paste( cloneWarning , "
", names(germlines)[as.numeric(clone)], "
", sep="" )
    }
    cloneWarning = paste( cloneWarning , "

", sep="" )
  }
}
cat(paste("Success",outputID,indelWarning,cloneWarning,sep="|"))


## Created on Friday, August 27, 2021 at 7:14pm EDT by Weekend Editor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

toolsDir <- "../../tools"                              # Various tools available from author
source(file.path(toolsDir, "graphics-tools.r"))        # Various graphics hacks

##
## After accounting for age and vax status to evade Simpson's paradox, show vaccine efficacy
## in Israel (which has much better medical records than the US!) vs age cohort.
##

doit <- function(cohorts    = c("12-15", "16-19", "20-29", "30-39", "40-49", "50-59",
                                "60-69", "70-79", "80-89", "90+"),
                 efficacies = c(100.0,   100.0,   100.0,   96.8,    93.9,    92.8,
                                 88.7,    89.6,    81.1,   92.4),
                 plotFile   = "./2021-08-29-covid-simpson-ve-by-age.png") {
  ## *** IWBNI we knew 95% cl bars on the efficacies, say by posterior Beta + Monte Carlo method
  withPNG(plotFile, 400, 400, FALSE, function() {      # Capture graphics to file
    withPars(function() {                              # Save/restore graphics params
      plot(x = 1 : length(cohorts), y = efficacies,    # Plot points & lines
           type = "b", pch = 21, col = "black", bg = "blue",
           xaxt = "n", xlab = NA, ylab = "Vaccine Efficacy (%)", ylim = c(0, 100),
           main = "Vaccine efficacy by age cohort")    # Horizontal axis done manually
      axis(side = 1, at = 1 : length(cohorts), labels = cohorts)
      title(xlab = "Age Cohort", line = 3.5)           # Horizontal axis title
    }, pty = "m",                                      # Maximal plotting area
       bg  = "white",                                  # White background
       mar = c(5, 3, 2, 1),                            # Margins for axis labels, title
       mgp = c(1.7, 0.5, 0),                           # Axis title, labels, ticks
       ps  = 16,                                       # Larger type size for file capture
       las = 2)                                        # Axis labels always perp to axis
  })                                                   # Done!
}                                                      #


#' Matching Estimators with Network Data
#'
#' \strong{WARNING}: This function is still in development and has not been tested throughly.
#' Following Aral et al. (2009), \code{netmatch} computes matching
#' estimators for network data. The function \code{netmatch_prepare}, which
#' prepares the data to be used with \code{\link[MatchIt:matchit]{matchit}} from
#' the \pkg{\link[MatchIt:MatchIt]{MatchIt}} package, is called by \code{netmatch}.
#'
#' @param dat \code{data.frame} with dynamic data. Must be of
#' \code{nrow(dat)==nslices(graph)*nnodes(graph)}.
#' @param graph List with sparse matrices.
#' @param timevar Character scalar. Name of time variable
#' @param depvar Character scalar. Name of the dependent variable
#' @param covariates Character vector. Name(s) of the control variable(s).
#' @param adopt_thr Either a numeric scalar or vector of length \code{nslices(graph)}.
#' Sets the threshold of \code{depvar} at which it is considered that an observation
#' has adopted a behavior.
#' @param treat_thr Either a numeric scalar or vector of length \code{nslices(graph)}.
#' Sets the threshold of \code{exposure} at which it is considered that an
#' observation is treated.
#' @param expo_pcent Logical scalar. When \code{TRUE}, exposure is computed
#' non-normalized (so it is a count rather than a percentage).
#' @param expo_lag Integer scalar. Number of lags to consider when computing
#' exposure. \code{expo_lag=1} defines exposure in T considering behavior and
#' network at T-1.
#' @param ... Further arguments to be passed to \code{\link[MatchIt:matchit]{matchit}}.
#' @return In the case of \code{netmatch_prepare}
#' \item{dat}{A \code{data.frame} with the original data (covariates), plus the
#' following new variables: \code{treat}, \code{adopt}, \code{exposure}.
#' }
#' \item{match_model}{A formula to be passed to \code{netmatch}}
#'
#' \code{netmatch} returns the following:
#' \item{fATT}{A numeric vector of length \eqn{N_1}{N1} (number of treated used
#' in the matching process). Treatment effects on the treated at the individual
#' level}
#' \item{match_obj}{The output from \code{matchit}.}
#' @name netmatch
#' @author
#' George G. Vega Yon
#' @references
#' Aral, S., Muchnik, L., & Sundararajan, A. (2009). Distinguishing
#' influence-based contagion from homophily-driven diffusion in dynamic networks.
#' Proceedings of the National Academy of Sciences of the United States of America,
#' 106(51), 21544–21549. \doi{10.1073/pnas.0908800106}
#'
#' Imbens, G. W., & Wooldridge, J. M. (2009). Recent Developments in the
#' Econometrics of Program Evaluation. Journal of Economic Literature, 47(1),
#' 5–86. \doi{10.1257/jel.47.1.5}
#'
#' King, G., & Nielsen, R. (2015). Why Propensity Scores Should Not Be Used for.
#'
#' Sekhon, J. S. (2008). The Neyman-Rubin Model of Causal Inference and Estimation
#' Via Matching Methods. The Oxford Handbook of Political Methodology.
#' \doi{10.1093/oxfordhb/9780199286546.003.0011}
#' @details
#'
#' In Aral et al. (2009), the matching estimator is used as a response to the
#' fact that the observed network is homophilous. Essentially, using exposure
#' as a treatment indicator, which is known to be endogenous, we can apply the
#' same principle of matching estimators in which, after controlling for characteristics
#' (covariates), individuals from the treated group (exposed to some behavior)
#' can be compared to individuals from the control group (not exposed to that
#' behavior), as the only difference between the two is the exposure.
#'
#' As pointed out in King & Nielsen (2015), it is suggested that, contrary to
#' what Aral et al. (2009), the matching is not performed over propensity score
#' since it is know that the later can increase imbalances in the data and thus
#' obtaining exactly the opposed outcome that matching based estimators pursue.
#'
#' A couple of good references for matching estimators are Imbens and Wooldridge
#' (2009), and Sekhon (2008).
NULL

#' @export
#' @rdname netmatch
netmatch_prepare <- function (
  dat, graph, timevar, depvar, covariates,
  treat_thr = rep(1L, length(graph)),
  adopt_thr = rep(1L, length(graph)),
  expo_pcent = FALSE,
  expo_lag = 0L
) {

  # Subset
  Y    <- as.matrix(dat[, depvar, drop=FALSE])
  X    <- as.matrix(dat[, covariates, drop=FALSE])
  Time <- as.matrix(dat[, timevar, drop=FALSE])

  # Checking thresholds
  if (length(treat_thr)==1)
    treat_thr <- rep(treat_thr, length(graph))
  if (length(adopt_thr)==1)
    adopt_thr <- rep(adopt_thr, length(graph))

  # Obtaining constants
  pers  <- sort(unique(Time))
  npers <- length(pers)
  n     <- length(Y)/npers

  if (expo_lag >= npers)
    stop("Not enought time points for such lag.")

  # Generating exposures and treatment
  expo  <- matrix(NA, ncol=npers, nrow=n)
  adopt <- matrix(NA, ncol=npers, nrow=n)
  treat <- matrix(NA, ncol=npers, nrow=n)
  ans   <- vector("list", npers)
  for (i in seq_along(pers)) {

    # Subset data
    per <- pers[i]
    y   <- Y[Time == per,, drop=FALSE]
    x   <- X[Time == per,, drop=FALSE]

    # Computing exposure and seting treatment
    adopt[,i] <- as.integer(y >= adopt_thr[i])

    # Skiping lags
    if (i <= expo_lag) next

    # Computing exposure (and normalizing if required)
    expo[,i]  <- as.vector(graph[[i-expo_lag]] %*% adopt[,i-expo_lag,drop=FALSE])
    if (expo_pcent)
      expo[,i] <- expo[,i]/(Matrix::rowSums(graph[[i-expo_lag]]) + 1e-20)

    # Assigning regime
    treat[,i] <- as.integer(expo[,i] >= treat_thr[i])

    # Creating dataset
    ans[[i]] <- data.frame(Y=y, X=x, treat=treat[,i],
                           adopt = adopt[,i-expo_lag],
                           expo  = expo[,i], check.names = FALSE)
    colnames(ans[[i]]) <-
      c("Y", covariates, "treat", "adopt", "expo")

  }

  # Model
  match_model <- as.formula(paste("treat ~", paste0(covariates, collapse=" + ")))

  # Returning outcome
  return(list(dat=ans, match_model=match_model))
}

#' @rdname netmatch
#' @export
netmatch <- function(
  dat, graph, timevar, depvar, covariates,
  treat_thr  = rep(1L, length(graph)),
  adopt_thr  = rep(1L, length(graph)),
  expo_pcent = FALSE,
  expo_lag   = 0L, ...) {

  # No so good for now.
  if (nslices(graph) != 2)
    stop("-netmatch- is currently supported only for nslices(graph) == 2.")

  # Preparing the data
  ans   <- netmatch_prepare(dat=dat, graph = graph, timevar = timevar,
                            depvar = depvar, covariates = covariates,
                            treat_thr = treat_thr, adopt_thr = adopt_thr,
                            expo_pcent = expo_pcent, expo_lag = expo_lag)

  # print(str(ans[[1]]))
  # Processing the data so we can use it with -matchit-
  dat <- ans$dat[[2]]
  rownames(dat) <- 1:nrow(dat)

  # Matching (with replacement)
  match_obj   <- MatchIt::matchit(ans$match_model, data=dat, ...)

  mmethod <- match_obj$call$method
  if (length(mmethod) && ("cem" %in% mmethod)) {

    # Retrieving sub classes
    dat1 <- MatchIt::match.data(match_obj, "treat")
    dat0 <- MatchIt::match.data(match_obj, "control")

    # Computing effect. At the end CEM gives weights (very simple)
    # coef(lm(Y~treat, data=match.data(match_obj), weights=weights))["treat"]
    fATT <- with(dat1, sum(Y*weights)/sum(weights)) -
      with(dat0, sum(Y*weights)/sum(weights))

  } else {
    match_index <- match_obj$match.matrix

    # Computing feasible Average Treatment Effect on the Treated
    fATT <- dat[,"Y"]

    matched_control <- lapply(1:nrow(match_index), function(x) {
      x <- match_index[x,,drop=TRUE]
      as.integer(x[!is.na(x)])
    })

    # Computing differences
    fATT <-Map(function(i1, i0) mean(fATT[i1] - fATT[i0]),
               i0=as.integer(rownames(match_index)),
               i1=matched_control
    )

    fATT <- mean(unlist(fATT, recursive = TRUE), na.rm=TRUE)
  }

  # Wrapping up
  return(list(
    fATT      = fATT,
    match_obj = match_obj,
    exposures = dat$expo
  )
  )

}


#' @export
#' @title coordinates.db
#' @description this is an assortment of coordinates for commonly used objects
#' @param \code{item} the desired object.  Valid values are 'gully','nens.ss.6-7','nens.ss.5-6','nens.ss.4-5','nens.ss.3-4','nens.ss.2-3','nens.ss.1-2','nens.ss.outside.1','nens.ss.outside.2','gulf-ss','nens-sens','cfa23.inshore-offshore','cfa23-cfa24','sens-cfa4x','shrimp.nw.sable','shrimp.louisburg','shrimp.bad.neighbours'
#' @return \code{}
#' @examples
#' coordinates.db('gully')
#' @note It is tempting to mark this as deprecated, as it is not clear that these objects will be updated to reflect a more definitive source
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  coordinates.db = function( item ) {

    if ( item=="gully" ) {
      a = as.data.frame( matrix( c(
          -59.10051192315181,44.21678274656149,
          -59.33516115171256,44.10057784448195,
          -59.13782200164582,43.91718619192973,
          -59.13430015596633,43.58357892651157,
          -58.58296879641245,43.58284385250472,
          -58.58345034613519,43.78360045129342,
          -59.10051192315181,44.21678274656149
        ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.6-7" ) {
      a = as.data.frame( matrix( c(
        -59.8669459147477,46.61829003097517,
        -59.86714927555937,46.1903922915425
      ), ncol=2, byrow=T ) )

      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.5-6" ) {
      a = as.data.frame( matrix( c(
        -60.15013169910874,46.61686051036362,
        -60.15070296987705,46.25403077923779
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.4-5" ) {
      a = as.data.frame( matrix( c(
        -58.57169296505639,46.61743715738334,
        -60.35101630484722,46.61743036291101
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.3-4" ) {
      a = as.data.frame( matrix( c(
        -60.32934961857659,46.73377402095574,
        -58.70455622211595,46.73425821633046
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.2-3" ) {
      a = as.data.frame( matrix( c(
        -60.29739776341232,46.8490837267233,
        -58.83935581691834,46.8522334225455
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.1-2" ) {
      a = as.data.frame( matrix( c(
        -60.39965967598059,47.00047832780142,
        -59.01461782671211,47.00028076937365
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.outside.1" ) {
      a = as.data.frame( matrix( c(
        -59.99891390682926,47.83103013198976,
        -58.56775382241514,46.61649379280151
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens.ss.outside.2" ) {
      a = as.data.frame( matrix( c(
        -57.78591208190541,46.00109962205628,
        -58.56775382241514,46.61649379280151
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="gulf-ss" ) {
      a = as.data.frame( matrix( c(
        -60.41568418984078,47.03853523297152,
        -60.00014897319883,47.83408958793515
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="nens-sens" ) {
      a = as.data.frame( matrix( c(
        -59.85247480316924,46.00291960992756,
        -57.78560987011954,46.00106076110973
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="cfa23.inshore-offshore" ) {
      a = as.data.frame( matrix( c(
        -59.92853837122961,44.69774735070251,
        -58.41005287016962,46.00038380222262
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="cfa23-cfa24" ) {
      a = as.data.frame( matrix( c(
        -60.66040620990439,45.58083805201212,
        -59.11881785180857,43.67610276909335
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="sens-cfa4x" ) {
      a = as.data.frame( matrix( c(
        -63.52502801857509,44.5005704612574,
        -63.33296001561555,44.33343763428088,
        -63.33161397633095,42.50186912534272
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="shrimp.nw.sable" ) {
      a = as.data.frame( matrix( c(
        -60.53348522264675,44.16713857065227,
        -59.83402446317178,44.16674842805921,
        -59.8337724318864,44.35020211840867,
        -60.53437630895549,44.35056350439965,
        -60.53348522264675,44.16713857065227
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="shrimp.louisburg" ) {
      a = as.data.frame( matrix( c(
        -59.16722567748156,45.50037490107675,
        -58.11756232854311,45.50029678441212,
        -58.11736586354162,45.91675134337378,
        -59.16724395727103,45.91694991968841,
        -59.16722567748156,45.50037490107675
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="shrimp.eastern" ) {
      a = as.data.frame( matrix( c(
        -60.99983106518073,44.58360971012488,
        -58.0005005513048,44.58361575122798,
        -58.00112052095971,44.9165492050831,
        -58.66697123168657,44.91801611900925,
        -58.66586013724016,45.00054787436935,
        -61.00063058037657,45.00080688407766,
        -60.99983106518073,44.58360971012488
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

    if ( item=="shrimp.bad.neighbours" ) {
      a = as.data.frame( matrix( c(
        -60.95065555250798,45.31550857725852,
        -60.08311721156429,45.46714417665778,
        -60.08371925586215,45.80040191216285
      ), ncol=2, byrow=T ) )
      a$elevation = 0
      names( a ) = c("lon", "lat", "elevation" )
      return( a )
    }

  }


###############################################################################
# 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/>.
###############################################################################
# Read GNU MathProg model
# 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
###############################################################################

###############################################################################
# Read GNU MathProg model
# based on Rglpk_read_file, modified to eliminate objective fn from constraint matrix
#' @export
###############################################################################
Rglpk.read.model <- function(file, type = c("MPS_fixed", "MPS_free", "CPLEX_LP", "MathProg"), ignore_first_row = FALSE, verbose = FALSE){
	if(!file.exists(file)) stop(paste("There is no file called", file, "!"))

  	type_db <- c("MPS_fixed" = 1L, "MPS_free"  = 2L, "CPLEX_LP"  = 3L, "MathProg"  = 4L)
  	obj <- list(file = tools::file_path_as_absolute(file), type = type_db[match.arg(type)])

	meta_data <- Rglpk:::glp_get_meta_data_from_file(obj, verbose)
	milp_data <- Rglpk:::glp_retrieve_MP_from_file(meta_data, ignore_first_row, verbose)
	MP_data <- Rglpk:::glp_merge_MP_data(meta_data, milp_data)

	dir_db <- c("free" = 1L, ">=" = 2L, "<=" = 3L, "DB" = 4L, "==" = 5L)
  	MP_data$direction_of_constraints <- names(dir_db[MP_data$direction_of_constraints])

	types <- rep("C", length.out = MP_data$n_objective_vars)
  	if(any(MP_data$objective_var_is_integer)) types[MP_data$objective_var_is_integer] <- "I"
  	if(any(MP_data$objective_var_is_binary)) types[MP_data$objective_var_is_binary] <- "B"
  	MP_data$types = types

	# remove objective fn from constraints
	index = which(MP_data$direction_of_constraints == 'free')
	if( length(index) > 0 ) {
		MP_data$constraint_matrix = as.matrix(MP_data$constraint_matrix)[-index,]
		MP_data$direction_of_constraints = MP_data$direction_of_constraints[-index]
		MP_data$right_hand_side = MP_data$right_hand_side[-index]
	}
	MP_data
}

###############################################################################
# Create constraints structure from model data (Rglpk.read.model)
#' @export
###############################################################################
Rglpk.create.constraints <- function( prob )
{
	#--------------------------------------------------------------------------
	# Create constraints
	#--------------------------------------------------------------------------
	n = prob$n_objective_vars

	lb = rep(NA,n)
		lb[prob$bounds$lower$ind] = prob$bounds$lower$val
	ub = rep(NA,n)
		ub[prob$bounds$upper$ind] = prob$bounds$upper$val
	constraints = new.constraints(n, lb = lb, ub = ub)

	# binary variables
	constraints$binary.index = which(prob$objective_var_is_binary == 1)
	if(len(constraints$binary.index) == 0) constraints$binary.index = 0

	#constraints
	if(is.null(dim(prob$constraint_matrix))) {
		prob$constraint_matrix = matrix(prob$constraint_matrix)
	} else {
		prob$constraint_matrix = t(prob$constraint_matrix)
	}

	index = which(prob$direction_of_constraints == '==')
	if(len(index)>0) constraints = add.constraints(prob$constraint_matrix[,index], type = '=', b = prob$right_hand_side[index], constraints)

	index = which(prob$direction_of_constraints == '<=')
	if(len(index)>0) constraints = add.constraints(prob$constraint_matrix[,index], type = '<=', b = prob$right_hand_side[index], constraints)

	index = which(prob$direction_of_constraints == '>=')
	if(len(index)>0) constraints = add.constraints(prob$constraint_matrix[,index], type = '>=', b = prob$right_hand_side[index], constraints)

	# objective function
	f.obj = prob$objective_coefficients
	dir = ifelse(prob$maximize, 'max', 'min')

   	prob$names = prob$objective_vars_names
   	prob$tickers = prob$objective_vars_names

    # find tickers wgt[AAPL]
    if(len(grep('\\[',prob$objective_vars_names)) > 0) {
    temp = matrix(spl(gsub(']','', prob$objective_vars_names),'\\['), nr=2)
    	prob$names = temp[1,]
    	prob$tickers = temp[2,]
    }

	return(list(constraints=constraints, f.obj=f.obj, dir=dir, prob=prob))
}

###############################################################################
# Parse Views / Constraints using GNU Mathprog specifications
#' @export
###############################################################################
parse.views = function(symbolnames, views) {
	load.packages('Rglpk')

	views = parse.expr(views)
	if (len(views)==0)
		return(list(
			A = matrix(0, nr=0, nc=len(symbolnames)),
			b = c(),
			meq = 0
		))

model.file = tempfile('temp.model')
on.exit(unlink(model.file))

	# create GNU MathProg model
	cat("
###############################################################################
# Define Variables
", join(paste0('var ', symbolnames, '>=0;'),'\n'), "

# Define Objective
minimize objective : ", join(symbolnames, '+'), ";

# Define Constraints
", join(paste0('V', 1:len(views), ':', views,';'),'\n'), "

###############################################################################
	", file = model.file, append = FALSE)

	#--------------------------------------------------------------------------
	# Read GNU MathProg model/Setup constraints/Solve QP problem
	#--------------------------------------------------------------------------
	# read model
	model = Rglpk.read.model(model.file,type = 'MathProg')

	# convert GNU MathProg model to constraint used in solve.QP
	temp = Rglpk.create.constraints(model)$constraints

	A = t(as.matrix(temp$A))
		colnames(A) = symbolnames

	list(
		A = A,
		b = temp$b,
		meq = temp$meq
	)
}

###############################################################################
# Helper function to find Minimum Variance Portfolio
#' @export
###############################################################################
min.var.portfolio.gmpl <- function(ia, constraints)
{
	#--------------------------------------------------------------------------
	# Adjust Covariance matrix
	#--------------------------------------------------------------------------
	load.packages('quadprog,corpcor')

	cov.temp = ia$cov

	# check if there are dummy variables
	n0 = ia$n
	n = nrow(constraints$A)
	if( n != nrow(cov.temp) ) {
		temp =  matrix(0, n, n)
		temp[1:n0, 1:n0] = cov.temp[1:n0, 1:n0]
		cov.temp = temp
	}

	if(!is.positive.definite(cov.temp)) {
		cov.temp <- make.positive.definite(cov.temp, 0.000000001)
	}

	#--------------------------------------------------------------------------
	# Solve QP problem
	#--------------------------------------------------------------------------
	binary.vec = 0
	if(!is.null(constraints$binary.index)) binary.vec = constraints$binary.index

	sol = solve.QP.bounds(Dmat = cov.temp, dvec = rep(0, nrow(cov.temp)) ,
		Amat=constraints$A, bvec=constraints$b, constraints$meq,
		lb = constraints$lb, ub = constraints$ub, binary.vec = binary.vec)

	if(binary.vec[1] != 0) cat(sol$counter,'QP calls made to solve problem with', len(binary.vec), 'binary variables using Branch&Bound', '\n')

	x = sol$solution[1:ia$n]
		names(x) = ia$symbols

	return(x)
}

###############################################################################
# Portfolio Optimization: Specify constraints with GNU MathProg language
#
# Examples:
# http://en.wikibooks.org/wiki/GLPK/GMPL_%28MathProg%29
# http://en.wikibooks.org/wiki/GLPK/Literature#Official_GLPK_documentation
#
# The GNU Linear Programming Kit (GLPK) : Resources, Tutorials
# http://spokutta.wordpress.com/tag/gnu-mathprog/
###############################################################################
portopt.mathprog.test <- function( )
{
	#*****************************************************************
	# Load packages
	#******************************************************************
	load.packages('quantmod,quadprog,corpcor')

	#--------------------------------------------------------------------------
	# Create historical input assumptions
	#--------------------------------------------------------------------------
	tickers = dow.jones.components()
	ia = aa.test.create.ia.custom(tickers, dates = '2000::2010')

	#--------------------------------------------------------------------------
	# Create Constraints & Solve QP problem
	#--------------------------------------------------------------------------
	n = ia$n

	# 0 <= x.i <= 1
	constraints = new.constraints(n, lb = 0, ub = 1)

	# SUM x.i = 1
	constraints = add.constraints(rep(1, n), 1, type = '=', constraints)

	# Solve QP problem
	x = min.var.portfolio.gmpl(ia, constraints)

	# plot weights
png(filename = 'plot1.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white')
	barplot(100*x, las=2, main='Minimum Variance Portfolio')
dev.off()

	#*****************************************************************
	# Load packages
	#******************************************************************
	# load Rglpk to read GNU MathProg files
	load.packages('Rglpk')

	#--------------------------------------------------------------------------
	# Create Constraints: GNU MathProg model
	#--------------------------------------------------------------------------
	model.file = 'model1.mod'

	# create GNU MathProg model
	cat('
###############################################################################
set SYMBOLS ;

# set min/max weights for individual stocks
var weight{i in SYMBOLS} >= 0, <= 1 ;

# objective function, NOT USED
minimize alpha : sum{i in SYMBOLS} weight[i] ;

# weights must sum to 1 (fully invested)
subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ;

data;

set SYMBOLS := ', ia$symbols, ';
###############################################################################
	', file = model.file, append = FALSE)

	#--------------------------------------------------------------------------
	# Read GNU MathProg model/Setup constraints/Solve QP problem
	#--------------------------------------------------------------------------
	# read model
	model = Rglpk.read.model(model.file,type = 'MathProg')

	# convert GNU MathProg model to constraint used in solve.QP
	constraints = Rglpk.create.constraints(model)$constraints

	# Solve QP problem
	x = min.var.portfolio.gmpl(ia, constraints)

	# plot weights
png(filename = 'plot2.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white')
	barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model')
dev.off()

	#--------------------------------------------------------------------------
	# Create Constraints: GNU MathProg model
	# Control Minimum Investment and Number of Assets: Portfolio Cardinality Constraints
	# http://systematicinvestor.wordpress.com/2011/10/20/minimum-investment-and-number-of-assets-portfolio-cardinality-constraints/
	#--------------------------------------------------------------------------
	model.file = 'model2.mod'

	# create GNU MathProg model
	cat('
###############################################################################
set SYMBOLS ;

# set min/max weights for individual stocks
var weight{i in SYMBOLS} >= 0, <= 1 ;

# add binary, 1 if held, 0 if not held
var held{SYMBOLS} binary;

# objective function, NOT USED
minimize alpha : sum{i in SYMBOLS} weight[i] ;

# weights must sum to 1 (fully invested)
subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ;

# min weight constraint for individual asset
subject to MinWgt {i in SYMBOLS} : weight[i] >= 0.025 * held[i];

# max weight constraint for individual asset
subject to MaxWgt {i in SYMBOLS} : weight[i] <= .20 * held[i] ;

# number of stocks in portfolio
subject to MaxAssetsLB : 0 <= sum {i in SYMBOLS} held[i] ;
subject to MaxAssetsUB : sum {i in SYMBOLS} held[i] <= 6 ;

data;

set SYMBOLS := ', ia$symbols, ';
###############################################################################
	', file = model.file, append = FALSE)

	#--------------------------------------------------------------------------
	# Read GNU MathProg model/Setup constraints/Solve QP problem
	#--------------------------------------------------------------------------
	# read model
	model = Rglpk.read.model(model.file,type = 'MathProg')

	# convert GNU MathProg model to constraint used in solve.QP
	constraints = Rglpk.create.constraints(model)$constraints

	# Solve QP problem
	x = min.var.portfolio.gmpl(ia, constraints)

	# plot weights
png(filename = 'plot3.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white')
	barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with Minimum Investment and Number of Assets Constraints')
dev.off()

	#--------------------------------------------------------------------------
	# Create Constraints: GNU MathProg model
	# Control Long and Short positions based on 130/30 Portfolio Construction
	# http://systematicinvestor.wordpress.com/2011/10/18/13030-porfolio-construction/
	#--------------------------------------------------------------------------
	model.file = 'model3.mod'

	# create GNU MathProg model
	cat('
###############################################################################
set SYMBOLS ;

# set min/max weights for individual stocks
var long {i in SYMBOLS} >= 0, <= 0.8 ;
var short{i in SYMBOLS} >= 0, <= 0.5 ;

# add binary, 1 if long, 0 if short
var islong{SYMBOLS} binary;

# objective function, NOT USED
minimize alpha : sum{i in SYMBOLS} long[i] ;

# weights must sum to 1 (fully invested)
subject to fully_invested : sum{i in SYMBOLS} (long[i] - short[i]) = 1 ;

# leverage is 1.6 = longs + shorts
subject to leverage : sum{i in SYMBOLS} (long[i] + short[i]) = 1.6 ;

# force long and short to be mutually exclusive (only one of them is greater then 0 for each i)
subject to long_flag  {i in SYMBOLS} : long[i]  <= islong[i] ;
subject to short_flag {i in SYMBOLS} : short[i] <= (1 - islong[i]) ;

data;

set SYMBOLS := ', ia$symbols, ';
###############################################################################
	', file = model.file, append = FALSE)

	#--------------------------------------------------------------------------
	# Read GNU MathProg model/Setup constraints/Solve QP problem
	#--------------------------------------------------------------------------
	# read model
	model = Rglpk.read.model(model.file,type = 'MathProg')

	# convert GNU MathProg model to constraint used in solve.QP
	constraints = Rglpk.create.constraints(model)$constraints

	# Solve QP problem, modify Input Assumptions to include short positions
	x = min.var.portfolio.gmpl(aa.test.ia.add.short(ia), constraints)

	# Compute total weight = longs - short
	x = x[1:ia$n] - x[-c(1:ia$n)]

	# plot weights
png(filename = 'plot4.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white')
	barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with 130:30 Constraints')
dev.off()

	# reduce problem size
	ia = aa.test.create.ia.custom(tickers[1:15], dates = '2000::2010')

	#--------------------------------------------------------------------------
	# Create Constraints: GNU MathProg model
	# Turnover Constraints : Control Maximum Trade Size and Number of Trades
	#--------------------------------------------------------------------------
	model.file = 'model4.mod'

	# create parameters to hold Current Weight
	param = ia$cov[,1,drop=F]
		colnames(param) = 'CurWgt'
		param[,'CurWgt'] = 1/ia$n

	# create GNU MathProg model
	cat('
###############################################################################
set SYMBOLS ;

param CurWgt{SYMBOLS} ;

# set min/max weights for individual stocks
var weight{i in SYMBOLS} >= 0, <= 1 ;

# TradePos[i] - TradeNeg[i] = CurWgt[i] - weight[i]
var TradePos{i in SYMBOLS} >= 0 ;
var TradeNeg{i in SYMBOLS} >= 0 ;

# Only one of TradePos or TradeNeg is > 0
var TradeFlag{SYMBOLS} binary;

# add binary, 1 if traded, 0 if not traded
var trade{SYMBOLS} binary;

# objective function, NOT USED
minimize alpha : sum{i in SYMBOLS} weight[i] ;

# weights must sum to 1 (fully invested)
subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ;

# setup Trades for individual asset
subject to TradeRange {i in SYMBOLS} : (CurWgt[i] - weight[i]) = (TradePos[i] - TradeNeg[i]) ;

# Only one of TradePos or TradeNeg is > 0
subject to TradeFlagPos {i in SYMBOLS} : TradePos[i] <= 100 * TradeFlag[i];
subject to TradeFlagNeg {i in SYMBOLS} : TradeNeg[i] <= 100 * (1 - TradeFlag[i]);

# min trade size constraint for individual asset
subject to MinTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) >= 0.01 * trade[i];
subject to MaxTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) <= .90 * trade[i] ;

# number of trades in portfolio
subject to MaxTrade : sum {i in SYMBOLS} trade[i] <= 48 ;

data;

set SYMBOLS := ', ia$symbols, ';

param : CurWgt:=
	', file = model.file, append = FALSE)

write.table(param, sep='\t', quote = F, col.names = F, file = model.file, append = TRUE)
cat(';
###############################################################################
	', file = model.file, append = TRUE)

	#--------------------------------------------------------------------------
	# Read GNU MathProg model/Setup constraints/Solve QP problem
	#--------------------------------------------------------------------------
	model = Rglpk.read.model(model.file,type = 'MathProg')
	constraints = Rglpk.create.constraints(model)$constraints

	# Solve QP problem
	x = min.var.portfolio.gmpl(ia, constraints)
		sqrt(x %*% ia$cov %*% x)

	# plot weights
png(filename = 'plot5.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white')
	barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with Turnover Constraints')
dev.off()

# reduce problem size
ia = aa.test.create.ia.custom(tickers[1:10], dates = '2000::2010')

	#--------------------------------------------------------------------------
	# Create Constraints: GNU MathProg model
	# Turnover Constraints : Control Maximum Trade Size and Number of Trades
	#--------------------------------------------------------------------------
	model.file = 'model4.mod'

	# create parameters to hold Current Weight
	param = ia$cov[,1,drop=F]
		colnames(param) = 'CurWgt'
		param[,'CurWgt'] = 1/ia$n

	# create GNU MathProg model
	cat('
###############################################################################
set SYMBOLS ;

param CurWgt{SYMBOLS} ;

# set min/max weights for individual stocks
var weight{i in SYMBOLS} >= 0, <= 1 ;

# TradePos[i] - TradeNeg[i] = CurWgt[i] - weight[i]
var TradePos{i in SYMBOLS} >= 0 ;
var TradeNeg{i in SYMBOLS} >= 0 ;

# Only one of TradePos or TradeNeg is > 0
var TradeFlag{SYMBOLS} binary;

# add binary, 1 if traded, 0 if not traded
var trade{SYMBOLS} binary;

# objective function, NOT USED
minimize alpha : sum{i in SYMBOLS} weight[i] ;

# weights must sum to 1 (fully invested)
subject to fully_invested : sum{i in SYMBOLS} weight[i] = 1 ;

# setup Trades for individual asset
subject to TradeRange {i in SYMBOLS} : (CurWgt[i] - weight[i]) = (TradePos[i] - TradeNeg[i]) ;

# Only one of TradePos or TradeNeg is > 0
subject to TradeFlagPos {i in SYMBOLS} : TradePos[i] <= 100 * TradeFlag[i];
subject to TradeFlagNeg {i in SYMBOLS} : TradeNeg[i] <= 100 * (1 - TradeFlag[i]);

# min trade size constraint for individual asset
subject to MinTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) >= 0.05 * trade[i];
subject to MaxTradeSize {i in SYMBOLS} : (TradePos[i] + TradeNeg[i]) <= .20 * trade[i] ;

# number of trades in portfolio
subject to MaxTrade : sum {i in SYMBOLS} trade[i] <= 8 ;

data;

set SYMBOLS := ', ia$symbols, ';

param : CurWgt:=
	', file = model.file, append = FALSE)

write.table(param, sep='\t', quote = F, col.names = F, file = model.file, append = TRUE)
cat(';
###############################################################################
	', file = model.file, append = TRUE)

	#--------------------------------------------------------------------------
	# Read GNU MathProg model/Setup constraints/Solve QP problem
	#--------------------------------------------------------------------------
	model = Rglpk.read.model(model.file,type = 'MathProg')
	constraints = Rglpk.create.constraints(model)$constraints

	# Solve QP problem
	x = min.var.portfolio.gmpl(ia, constraints)
		sqrt(x %*% ia$cov %*% x)

	# plot weights
png(filename = 'plot6.png', width = 600, height = 400, units = 'px', pointsize = 12, bg = 'white')
	barplot(100*x, las=2, main='Minimum Variance Portfolio using GNU MathProg model \n with Turnover Constraints')
dev.off()

}