## Produce results for WPRO

source("utils/extract-results.r")

##JOBIDs
dateDir <- "2020-05-11"
JOBID <- "1103566"
StanModel <- "base_wpro"
# Load files and results
resultsDir <- paste0("results/DateRep-", dateDir, "/")
figuresDir <- paste0("figures/DateRep-", dateDir, "/")
filename <- paste0(StanModel, '-',JOBID,"-stanfit.Rdata")
# filename <- paste0('base-',JOBID,".Rdata")
print(sprintf("loading: %s",paste0("results/DateRep-", dateDir, "/",
  filename)))
load(paste0("results/DateRep-", dateDir, "/", filename))

# system(paste0("Rscript covariate-size-effects.r ", "DateRep-", dateDir, "/", filename,
  # '-stanfit.Rdata'))
results <- StanResults(countries,JOBID,out,resultsDir)
plot_covariate_effects(resultsDir, out)

predictionR0 <- resultsR0(stan_data, out)

# Sort out intervention dates
covariates <- read.csv("data/interventions.csv",
  stringsAsFactors = FALSE)

if ((length(countries) == 2) & (countries[1] == countries[2])) {
  nCountries <- 1
} else {
  nCountries <- length(countries)
}

covariates <- TidyCovariates(nCountries, covariates)

results <- vector(mode = "list", length = nCountries)

for(ii in 1:nCountries) {
    print(ii)
    N <- length(dates[[ii]])
    country <- countries[[ii]]
    print(country)

    data_country <- CountryOutputs(ii,country,dates[[ii]],reported_cases,
      deaths_by_country,prediction,estimated.deaths,out$Rt)

    write.csv(data_country, paste0(figuresDir, 'SummaryResults-',JOBID,
      '-',countries[[ii]],'.csv'))

    country_covariates <- CountryCovariates(country, covariates,
      data_country$rt_max)

    write.csv(country_covariates, paste0(figuresDir, 'Interventions-',
      JOBID, '-',countries[[ii]],'.csv'))

    make_plots(data_country = data_country,
      covariates_country_long = country_covariates,
      filename = filename,
      figuresDir = figuresDir,
      country = country)

    results[[ii]] <- data_country
}

forecast <- 10

for(ii in 1:nCountries) {
    N <- length(dates[[ii]])
    country <- countries[[ii]]

    data_country <- CountryOutputs(ii,country,dates[[ii]],reported_cases,
      deaths_by_country,prediction,estimated.deaths,rt)

    data_country_forecast <- CountryForecast(ii,country,dates[[ii]],
      forecast,prediction, estimated.deaths)

    make_single_plot(data_country, data_country_forecast, filename,
      figuresDir, country, logy = FALSE,
      ymax = round(max(data_country$deaths), digits = -1))
}

forecastR0 <- vector(mode = "list", length = nCountries)

for(ii in 1:nCountries) {
  N <- length(dates[[ii]])
  country <- countries[[ii]]

  forecastR0[[ii]] <- CountryForecastR0(ii,country,dates[[ii]],
    forecast,predictionR0)

   write.csv(forecastR0[[ii]], paste0(figuresDir, 'R0_Results-',JOBID,
      '-',countries[[ii]],'.csv'))

  data_countryTest <- CountryOutputs(ii,country,dates[[ii]],reported_cases,
    deaths_by_country, prediction, estimated.deaths, out$Rt)

  data_country_forecastTest <- CountryForecast(ii,country,dates[[ii]],
    forecast, prediction, estimated.deaths)

  make_comparison_plot(data_countryTest, data_country_forecastTest,
    forecastR0[[ii]], "infections", filename, figuresDir, country,
    logy = TRUE, include_cases = TRUE,
    ymax = max(forecastR0[[ii]]$predicted_max))

  make_comparison_plot(data_countryTest, data_country_forecastTest,
    forecastR0[[ii]], "infections", paste0(filename, "linear"),
    figuresDir, country, logy = FALSE, include_cases = FALSE,
    ymax = max(forecastR0[[ii]]$predicted_max))

  make_comparison_plot(data_countryTest, data_country_forecastTest,
    forecastR0[[ii]], "deaths", filename, figuresDir, country,
    logy = TRUE, include_cases = TRUE,
    ymax = max(forecastR0[[ii]]$death_max))

  make_comparison_plot(data_countryTest, data_country_forecastTest,
    forecastR0[[ii]], "deaths", paste0(filename, "linear"),
    figuresDir, country, logy = FALSE, include_cases = FALSE,
    ymax = max(forecastR0[[ii]]$death_max))
}


# test funciones Web

testthat::test_that(
    "mostrar grado: devuelva grado",{
        source(here:::here("funcs","funciones.r"),encoding = "UTF-8") # asi toma la ultima version

        # setup
        cota_seccion <- c("Trabajos Originales")
        db_limpia <- "db_raab_grafos.sqlite"
        cota_anio <-  c(1996:2016)
        art_full <- articulos_todos_grafo(db_limpia,anios = cota_anio,secciones = cota_seccion)
        gb_ok <- armado_grafo_bipartito(art_full)
        g_aut <- extraccion_grafo_coautoria(gb_ok,art_full,width_multiplier = 3)

        in_value <- "a0185"
        g <- g_aut

        vertice <- get_vertex_from_click_vertex(g,in_value)

        grado <- igraph:::degree(g,vertice)
        #glimpse(grado)
        actual <- as.numeric(grado)
        expected <- 0

        expect_equal(actual, expected)

})


# Import R Packages and Modules
library("ggplot2")
library("dplyr")
library("leaflet")

# Import Crimes_2015 datasets
crimes <- read.csv('Crimes_2015.csv', header = TRUE, stringsAsFactors = TRUE)

# Plot Bar Chart showing crimes bases on Offense types
ggplot(crimes, aes(Offense, fill=Offense) ) + geom_bar() + ggtitle("Graph showing arrests based on types of offense.") + xlab("Offense") + ylab("Total Crimes") + labs(fill = "Offense types")

# Plot Bar Chart showing crimes bases on neighborhood
ggplot(crimes, aes(Neighborhood, fill=Neighborhood) ) + geom_bar() + ggtitle("Graph showing arrests based on Neighborhood.") + xlab("Neighborhood") + ylab("Total Crimes") + labs(fill = "Neighborhood")

# Plot Bar Chart showing crimes bases on Month
ggplot(crimes, aes(Month, fill=Month) ) + geom_bar(width = 0.5) + ggtitle("Graph showing arrests based on Month of crime.") + xlab("Month") + ylab("Total Crimes") + labs(fill = "Month")

# Plot Bar Chart showing crimes bases on Precinct
ggplot(crimes, aes(Precinct, fill=Precinct) ) + geom_bar(width = 0.5) + ggtitle("Graph showing arrests based on Precinct.") + xlab("Precinct") + ylab("Total Crimes") + labs(fill = "Precinct")

# Plot a map showing the first 20 rows from the `crimes` dataset
leaflet(data = crimes[1:20,]) %>% addTiles() %>%
  addMarkers(~Longitude, ~Latitude, popup = ~as.character(Description))

# Plot a clustered map of the first 1000 rows
leaflet(data = crimes[1:1000,]) %>% addProviderTiles("CartoDB.Positron") %>% addMarkers(
  ~Longitude,
  ~Latitude,
  popup = ~as.character(Description),
  clusterOptions = markerClusterOptions()
)

# Plot a pallete map
pal <- colorFactor(c("navy", "red", "green", "blue", "orange", "purple"), domain = c("1", "2", "3", "4", "5", "18"))
leaflet(data = crimes[1:100,]) %>% addTiles() %>% addCircleMarkers(
    ~Longitude,
    ~Latitude,
    popup = ~as.character(Description),
    radius = crimes$Precinct,
    color = ~pal(Precinct),
    stroke = FALSE,
    fillOpacity = 0.5
)


## reference: https://github.com/kevinblighe/EnhancedVolcano
VolcanoSC <- function(DEs, AdjustedCutoff, FCCutoff, LabellingCutoff, main)
{
  DEs$Significance <- "NS"
  DEs$Significance[(abs(DEs$avg_logFC) > FCCutoff)] <- "FC"
  DEs$Significance[(DEs$p_val<AdjustedCutoff)] <- "max_pval"
  DEs$Significance[(DEs$p_val<AdjustedCutoff) & (abs(DEs$avg_logFC)>FCCutoff)] <- "FC_max_pval"
  #table(DEs$Significance)

  DEs$Significance <- factor(DEs$Significance, levels=c("NS", "FC", "max_pval", "FC_max_pval"))

  plot <- ggplot(DEs, aes(x=avg_logFC, y=-log10(p_val))) +
    #Add points:
    #      Colour based on factors set a few lines up
    #      'alpha' provides gradual shading of colour
    #      Set size of points
    geom_point(aes(color=factor(Significance)), alpha=1/2, size=0.8) +

    #Choose which colours to use; otherwise, ggplot2 choose automatically (order depends on how factors are ordered in DEs$Significance)

    scale_color_manual(values=c(NS="grey80", FC="#AEC7E8", max_pval="royalblue", FC_max_pval="red2"), labels=c(NS="NS", FC=paste("LogFC>|", FCCutoff, "|", sep=""), max_pval=paste("max_pval <", AdjustedCutoff, sep=""), FC_max_pval=paste("max_pval <", AdjustedCutoff, " & LogFC>|", FCCutoff, "|", sep=""))) +

    #Set the size of the plotting window

    theme_bw(base_size=24) +

    #Modify various aspects of the plot text and legend

    theme(legend.background=element_rect(),
          plot.title=element_text(angle=0, size=12, face="bold", vjust=1),
          panel.grid.major=element_blank(), #Remove gridlines
          panel.grid.minor=element_blank(), #Remove gridlines
          axis.text.x=element_text(angle=0, size=12, vjust=1),
          axis.text.y=element_text(angle=0, size=12, vjust=1),
          axis.title=element_text(size=12),

          #Legend
          legend.position="top",                   #Moves the legend to the top of the plot
          legend.key=element_blank(),             #removes the border
          legend.key.size=unit(0.5, "cm"), #Sets overall area/size of the legend
          legend.text=element_text(size=8), #Text size
          title=element_text(size=8),             #Title text size
          legend.title=element_blank()) +         #Remove the title

    #Change the size of the icons/symbols in the legend
    guides(colour = guide_legend(override.aes=list(size=2.5))) +

    #Set x- and y-axes labels
    xlab(bquote(~Log[2]~ "fold change")) +
    ylab(bquote(~-Log[10]~max~italic(Pval))) +

    #Set the axis limits
    #xlim(-6.5, 6.5) +
    #ylim(0, 100) +

    #Set title
    ggtitle(main) +

    #Tidy the text labels for a subset of genes

    geom_text(data=subset(DEs, p_val<LabellingCutoff & abs(avg_logFC)>FCCutoff),
              aes(label=row.names(subset(DEs, p_val<LabellingCutoff & abs(avg_logFC)>FCCutoff))),
              size=2.25,
              #segment.color="black", #This and the next parameter spread out the labels and join them to their points by a line
              #segment.size=0.01,
              check_overlap=TRUE,
              vjust=1.0) +

    #Add a vertical line for fold change cut-offs
    geom_vline(xintercept=c(-FCCutoff, FCCutoff), linetype="longdash", colour="black", size=0.4) +

    #Add a horizontal line for P-value cut-off
    geom_hline(yintercept=-log10(AdjustedCutoff), linetype="longdash", colour="black", size=0.4)

  return(plot)

}


## Two-class sample data for classification metrics ----------------------------

rm(list = ls())
set.seed(7)
options(scipen = 999)
pred <- runif(1000)
act <- round(pred)
pred[sample(1000, 300)] <- runif(300) # noise

write.csv(data.frame(act, pred),
          file = "two-class-sample-data.csv",
          row.names = FALSE)

## Multi-class sample data for classification metrics --------------------------

## Sample data for regression metrics ------------------------------------------

rm(list = ls())
data(swiss)
fit <- lm(Fertility ~ ., data = swiss)
pred <- predict(fit)

write.csv(data.frame(act = swiss$Fertility,
                     pred = pred),
          file = "regression-sample-data.csv",
          row.names = FALSE)


canMakeNoRecursion <- function(x) {
  x <- toupper(x)
  charList <- strsplit(x, character(0))
  getCombos <- function(chars) {
    charBlocks <-  data.matrix(expand.grid(lapply(chars, function(char) which(blocks == char, arr.ind=TRUE)[, 1L])))
    charBlocks <- charBlocks[!apply(charBlocks, 1, function(row) any(duplicated(row))), , drop=FALSE]
    if (dim(charBlocks)[1L] > 0L) {
      t(apply(charBlocks, 1, function(row) apply(blocks[row, , drop=FALSE], 1, paste, collapse="")))
    } else {
      character(0)
    }
  }
  setNames(lapply(charList, getCombos), x)
}
canMakeNoRecursion(c("A",
           "BARK",
           "BOOK",
           "TREAT",
           "COMMON",
           "SQUAD",
           "CONFUSE"))


setwd("./")
result_path_save <-  "./"

source("https://raw.githubusercontent.com/liyujiao1026/pmediansolvers/master/Func1_SA.R")
source("https://raw.githubusercontent.com/liyujiao1026/pmediansolvers/master/Func2_GA.R")
source("https://raw.githubusercontent.com/liyujiao1026/pmediansolvers/master/Func3_PSO.R")
source("https://raw.githubusercontent.com/liyujiao1026/pmediansolvers/master/Func4_Bee.R")
source("https://raw.githubusercontent.com/liyujiao1026/pmediansolvers/master/Func5_Fish.R")
source("https://raw.githubusercontent.com/liyujiao1026/pmediansolvers/master/Func6_compare.R")

# 1. Read IKEA data ===================================================#
library(h5)
loadhdf5data <- function(h5File, dataset) {
            f <- h5file(h5File)
            nblocks <- h5attr(f[dataset], "nblocks")
            data <- do.call(cbind, lapply(seq_len(nblocks) - 1, function(i) {
                        data <- as.data.frame(f[paste0(dataset, "/block", i, "_values")][])
                        colnames(data) <- f[paste0(dataset, "/block", i, "_items")][]
                        data}))
            h5close(f)
            data
}

Distance.matrix <- loadhdf5data("./data/PHD_MatrixDist.h5", "matrix")
# #List of Settlements (X,Y, ID of node). 1938 lines
store_candidates <- read.csv("./data/PHD_Settlements.txt", header = F, sep = " ")
# List of population points : (X,Y, number of persons), 187679 lines
customer <- read.csv("./data/PHD_Pop.txt", header = F, sep = " ")
weight_customer <- customer[,3]
#-------------------------------------------#

# Check whether data is correct
dim(Distance.matrix) == c(187679, 1938)  #(187679 lines, 1938 columns)
dim(customer) == c(187679, 3) # population points : (X,Y, number_of_persons), 187679 lines

# 2. Settings =========================================#

set.seed(1)
# (1). P-median problem settings
N = nrow(store_candidates) # Number of candidates
p = 19 # Number of selected facilities

# (2). Iteration settings
ni <- 500 # Number of iterations
pop_size <- 100

# (3). Parameters settings
SA_temparature <- 500 # better the same as iteration time
SA_cool_rate <- 0.95

GA_prob_refine <- 0.9  # top 0.9 are selected
GA_prob_cross <- 0.8
GA_prob_mutation <- 0.2

PSO_c1 <- 0.7 # updating rate for pbest
PSO_c2 <- 0.3 # updating rate for gbest

BEE_maxtrial <- 100

FISH_crowdness <- 5  # how many peers are allowed in one group at most
FISH_visual_mutual <- 10  # how many common elements in solutions are assumed as one group: p/2
FISH_try_number <- 5

# 2. Running algorithms---------------------------------------#

result_compare <- Compare_Algorithm_Func(
            N,p,ni,pop_size,
            Distance.matrix, weight_customer,
            algorithms = c("SA","GA","PSO","BEE","FISH"),
            SA_temparature,  SA_cool_rate,
            GA_prob_refine,  GA_prob_cross,GA_prob_mutation,
            PSO_c1, PSO_c2,
            BEE_maxtrial,
            FISH_crowdness, FISH_visual_mutual, FISH_try_number,
            path_save = result_path_save)


#Test code

pi <- 3.1415


#install.packages("FLCore", repo = "http://flr-project.org/R")
#library(devtools)
#install_github("ices-tools-prod/msy")

library(msy)

nsamp <- 100  # number of stochatic runs for each option

Mstk<-SMS2FLStocks(sumfile=file.path(data.path,'summary.out'),
                         bio.interact=F, read.input=TRUE, read.output=TRUE,control=read.FLSMS.control())
lapply(Mstk,function(x) x@name) # just check

SSB.R.year.first<-SMS.control@SSB.R.year.first
SSB.R.year.last <-SMS.control@SSB.R.year.last
SSB.R.year.first[SSB.R.year.first==-1]<-SMS.control@first.year.model
SSB.R.year.last[SSB.R.year.last==-1]<-SMS.control@last.year.model

# read recruiment years used
recruit.years<-matrix(head(scan(file='recruitment_years.in',comment.char='#'),-1),ncol=SMS.control@last.year.model-SMS.control@first.year.model+1 ,byrow=T)
colnames(recruit.years)<-c(as.character(seq(SMS.control@first.year,SMS.control@last.year)))

dev<-'png'
nox<-3; noy<-3;
noxy<-nox*noy
i<-noxy

FITs<-list()

for (s in (1:length(Mstk))) {
  i<-i+1
  stk<-Mstk[[s]]
  class(stk)<-'FLStock'

  # move recruitment to first Quarter
  stk@stock.n[1,,,1,,]<-as.vector(stock.n(stk)[1,,,3,,])

  stk<-trim(stk,season=1,year=SSB.R.year.first[s]:(SSB.R.year.last[s]-1))  # Delete the most recent year (as driven by used S/R relation). SSB and recruit are there, but the rest of data is crap (first half-year only)

  harvest.spwn(stk)<-0
  m.spwn(stk)<-0
  #stk@stock.n<-stk@stock.n/1000
  cat('\n',sp.names[s+first.VPA-1],'\n SSB:\n');print(ssb(stk))

  models<- c("Ricker", "Segreg", "Bevholt")
  if ( Mstk[[s]]@name  %in% c('Herring')) models<- c("Ricker", "Segreg") # does not work with Ricker ?

  if (0==length(excl.years<-as.numeric(dimnames(recruit.years)[[2]][0==recruit.years[s,]]))) excl.years<-NULL
  FIT<-eqsr_fit(stk, nsamp = nsamp, models = models,
                    method = "Buckland",
                    id.sr = paste(sp.names[s+first.VPA-1],', ',SSB.R.year.first[s],'-',SSB.R.year.last[s],sep=''),
                    remove.years = excl.years)

  FITs[[s]]<-FIT
  if (i>=noxy) {
    if (dev=='png') cleanup()
    newplot(dev,filename=paste('equisim',s,sep='_'),nox,noy,Portrait=T);
    i<-0
  }
  eqsr_plot(FIT,Scale=0.001)
}

if (dev=='png') cleanup()

names(FITs[[1]])
FITs[[1]]$sr.det
FITs[[1]]$id.sr
lapply(FITs,function(x){ print(x$sr.det) })

out<-file.path(data.path,'op_eqsim.in');unlink(out)
sr<-function(x) {
  a<-x$sr.det
  dummy<-data.frame(model=c("Ricker", "Segreg", "Bevholt"))
  a<-merge(x=a,y=dummy,all.y=T)
  a[is.na(a$a),'a']<- 1
  a[is.na(a$b),'b']<- 1
  a[is.na(a$cv),'cv']<- 1
  a[is.na(a$n),'n']<- 0
  a[is.na(a$prop),'prop']<- 0
  print(a)

  a$model2<-ifelse(a$model=='Ricker',1,ifelse(a$model=='Segreg',3,ifelse(a$model=="Bevholt",2,NA)))
  a$Species.n<-first.VPA-1+match(substr(x$id.sr,1,3),substr(sp.names[first.VPA:nsp],1,3))
  a$n<-NULL
  write.table(a,file=out,append=T,col.names=F,row.names=F)

}
a<-lapply(FITs,sr)
a<-read.table(file=out,header=F)
names(a)<-c('m','a','b','cv','prop','model','Species.n')

a<-a[order(a$Species.n,a$model),]
a[a$m=='Segreg','a']<-log(a[a$m=='Segreg','a'])  # to fit to SMS
head(a)

unlink(out)
cat('### parameters from Eqsim (a, b,cv, proportion)  (1=Ricker, 2=Beverton&Holt, 3 = segmented regression)\n',file=out)
for (i in (1:dim(a)[[1]])) {
  cat(a[i,'a'],a[i,'b'],a[i,'cv'],a[i,'prop'],'#',sp.names[a[i,'Species.n']],as.character(a[i,'m']),'\n',file=out,append=T)
}

###  stochastic
head(FITs[[1]]$sr.sto)
dim((FITs[[1]]$sr.sto))

out<-file.path(data.path,'op_eqsim_stoch.in');unlink(out)
sr<-function(x) {
  a<-x$sr.sto
  a$model2<-ifelse(a$model=='Ricker',1,ifelse(a$model=='Segreg',100,ifelse(a$model=="Bevholt",2,NA)))
  a$iter<-1:nsamp
  a$Species.n<-first.VPA-1+match(substr(x$id.sr,1,3),substr(sp.names[first.VPA:nsp],1,3))
  #print(head(a))
  write.table(a,file=out,append=T,col.names=F,row.names=F)
}
a<-lapply(FITs,sr)
a<-read.table(file=out,header=F)
names(a)<-c('a','b','cv','m','model','iter','Species.n')

a<-a[order(a$Species.n,a$iter),]
a[a$m=='Segreg','a']<-log(a[a$m=='Segreg','a'])  # to fit to SMS
head(a)

unlink(out)

cat('### parameters from Eqsim\n',nsamp,'### number of samples\n### parameters,(a, b,cv, model)  (1=Ricker, 2=Beverton&Holt, 100 = segmented regression)\n',file=out)
a$label<-paste(" #",sp.names[a$Species.n], a$m,a$iter)
write.table(subset(a,select=c(a,b,cv,model,label)),file=out,append=T,col.names=F,row.names=F,quote=F)


require(reshape2) # For data handling
require(lme4) # Linear mixed-effects models
require(DHARMa) # Evaluate model fit
require(car) # Anova() function [instead of base R anova()]
require(emmeans) # Post-hoc analysis on the model

rm(list = ls()) # Remove variables/objects
graphics.off() # Close any open graphics

ELP_10 = read.csv("./Data/ELP_10_GABA_side_learning_Y_maze.csv", header = TRUE, stringsAsFactors = FALSE, sep = ";")
head(ELP_10, n = 1) # Check if data was imported correctly

ELP_10$Solution = ifelse(ELP_10$Solution == "G", "0.734mM GABA", "Control")

ELP_10$Initial_Decision_Binary = ifelse(ELP_10$Initial_Decision == ELP_10$Reward_Side, 1, 0)
ELP_10$Final_Decision_Binary = ifelse(ELP_10$Final_Decision == ELP_10$Reward_Side, 1, 0)
ELP_10$Switched_Decision_Binary = ifelse(ELP_10$Initial_Decision_Binary == ELP_10$Final_Decision_Binary, 0, 1)
paste0("Ants switched their final decision in ", round(sum(ELP_10$Switched_Decision_Binary) / nrow(ELP_10) * 100, 0), "% of the visits!")

table(ELP_10$Solution, ELP_10$Reward_Side) / 4

for (i in 1:nrow(ELP_10)) {
  if (ELP_10$Visit[i] == "2" & !is.na(ELP_10$Bridge_Nest_Duration[i])) {
    if (ELP_10$Bridge_Nest_Duration[i] != ELP_10$Time_Since_Marking[i]) {
      print(paste0("Warning: Row ", i, " was changed from ", ELP_10$Bridge_Nest_Duration[i], "s to ", ELP_10$Time_Since_Marking[i], "s!"))
      ELP_10$Bridge_Nest_Duration[i] = ELP_10$Time_Since_Marking[i]
    }
  }
  else if (ELP_10$Visit[i] == "2" & is.na(ELP_10$Bridge_Nest_Duration[i])) {
    ELP_10$Bridge_Nest_Duration[i] = ELP_10$Time_Since_Marking[i]
    print(paste0("Warning: Row ", i, " was changed and Bridge_Nest_Duration was NA!"))
  }
}

for (i in 1:nrow(ELP_10)) {
  if (ELP_10$Time_Since_Marking[i] <= 1800) {
    ELP_10$TSM_Bin[i] = "0-30"
  }
  else if (ELP_10$Time_Since_Marking[i] > 1800 & ELP_10$Time_Since_Marking[i] <= 3600) {
    ELP_10$TSM_Bin[i] = "30-60"
  }
  else {
    print("Warning: Undefined bins!")
  }
}

table(ELP_10$Solution, ELP_10$TSM_Bin, ELP_10$Reward_Side) / 4

ELP_10$Collection_Date = as.factor(ELP_10$Collection_Date)
ELP_10$Time_Collection = as.factor(ELP_10$Time_Collection)
ELP_10$Experimentor = as.factor(ELP_10$Experimentor)
ELP_10$Starvation_Period = as.factor(ELP_10$Starvation_Period)
ELP_10$Donor_Colony = as.factor(ELP_10$Donor_Colony)
ELP_10$Recipient_Colony = as.factor(ELP_10$Recipient_Colony)

ELP_10$Visit = as.factor(ELP_10$Visit)
ELP_10$Solution = as.factor(ELP_10$Solution)
ELP_10$Solution = relevel(ELP_10$Solution, "Control")
ELP_10$Reward_Side = as.factor(ELP_10$Reward_Side)
ELP_10$TSM_Bin = as.factor(ELP_10$TSM_Bin)

ELP_10$Initial_Decision_Binary = as.factor(ELP_10$Initial_Decision_Binary)
ELP_10$Final_Decision_Binary = as.factor(ELP_10$Final_Decision_Binary)

initial_final_diff = melt(ELP_10, measure.vars = c("Initial_Decision_Binary", "Final_Decision_Binary"))
initial_final_diff$value = as.factor(initial_final_diff$value)
head(initial_final_diff, n = 1) # Check if data was imported correctly

diff_model = glmer(value ~ variable + (1|Starvation_Period) + (1|Collection_Date), data = initial_final_diff, family = binomial, glmerControl(optimizer = "bobyqa", optCtrl = list(maxfun = 1000000000)))
Anova(diff_model)

e = emmeans(diff_model, ~variable, type = "response")
pairs(e)

mod1 = glmer(Final_Decision_Binary ~ (Reward_Side + Solution + TSM_Bin + Visit)^2  +
               (1|Starvation_Period) + (1|Collection_Date),
             data = ELP_10, family = "binomial", glmerControl(optimizer = "bobyqa", optCtrl = list(maxfun = 1000000000)))

simres = simulateResiduals(mod1)
plot(simres, asFactor = T)

summary(mod1)
Anova(mod1)
drop.scope(mod1)

mod2 = update(mod1, . ~ . - Reward_Side:Visit)
anova(mod1, mod2)

summary(mod2)
Anova(mod2)
drop.scope(mod2)

mod3 = update(mod2, . ~ . - TSM_Bin:Visit)
anova(mod2, mod3)

summary(mod3)
Anova(mod3)
drop.scope(mod3)

mod4 = update(mod3, . ~ . - Solution:TSM_Bin)
anova(mod3, mod4)

summary(mod4)
Anova(mod4)
drop.scope(mod4)

mod5 = update(mod4, . ~ . - Reward_Side:TSM_Bin)
anova(mod4, mod5)

summary(mod5)
Anova(mod5)
drop.scope(mod5)

mod6 = update(mod5, . ~ . - Solution:Visit)
anova(mod5, mod6)

summary(mod6)
Anova(mod6)
drop.scope(mod6)

mod7 = update(mod6, . ~ . - Reward_Side:Solution)
anova(mod6, mod7)

summary(mod7)
Anova(mod7)
drop.scope(mod7)

anova(mod1, mod7)
simres = simulateResiduals(mod7)
plot(simres, asFactor = T)

meanobj = emmeans(mod7, ~Visit, type = "response")
pairs(meanobj, adjust = "bonferroni")

meanobj = emmeans(mod7, ~TSM_Bin * Visit, type = "response")
test(meanobj)

meanobj = emmeans(mod7, ~Solution, type = "response")
test(meanobj)
pairs(meanobj, adjust = "bonferroni")

meanobj = emmeans(mod7, ~1, type = "response")
test(meanobj)

sessionInfo()


test_that("Gerador de grades", {

    # metodos entregam mesmo resultado
    grade_1 <- coordgrade(colinadummy, 20, 20)
    grade_2 <- coordgrade(colinadummy$CC, 20, 20)
    grade_3 <- coordgrade(as.data.frame(colinadummy$CC), 20, 20)
    expect_true(all(grade_1 == grade_2))
    expect_true(all(grade_2 == grade_3))

    # grade gerada com dhl e dpot inteiros
    expect_equal(length(unique(grade_1$hl)), 20)
    expect_equal(min(grade_1$hl), min(colinadummy$CC$hl))
    expect_equal(max(grade_1$hl), max(colinadummy$CC$hl))

    expect_equal(length(unique(grade_1$pot)), 20)
    expect_equal(min(grade_1$pot), min(colinadummy$CC$pot))
    expect_equal(max(grade_1$pot), max(colinadummy$CC$pot))

    grade_2 <- coordgrade(colinadummy, 30, 30, expande = c(.1, .1))

    deltahl  <- .1 * diff(range(colinadummy$CC$hl))
    deltapot <- .1 * diff(range(colinadummy$CC$pot))

    expect_equal(length(unique(grade_2$hl)), 30)
    expect_equal(min(grade_2$hl), min(colinadummy$CC$hl) - deltahl)
    expect_equal(max(grade_2$hl), max(colinadummy$CC$hl) + deltahl)

    expect_equal(length(unique(grade_2$pot)), 30)
    expect_equal(min(grade_2$pot), min(colinadummy$CC$pot) - deltapot)
    expect_equal(max(grade_2$pot), max(colinadummy$CC$pot) + deltapot)

    # grade gerada com dhl e dpot vetores

    grade_5 <- coordgrade(colinadummy, 20:40, 200:300)

    expect_equal(unique(grade_5$hl), 20:40)
    expect_equal(unique(grade_5$pot), 200:300)

    grade_5 <- coordgrade(colinadummy, 20:40, 200:300, expand = c(.1, .1))

    expect_equal(unique(grade_5$hl), 20:40)
    expect_equal(unique(grade_5$pot), 200:300)

    # grade gerada com byhl e bypot
    # os limites dos expect_equal aqui e no proximo teste foram pre calculados

    grade_3 <- coordgrade(colinadummy, byhl = .5, bypot = 5)

    expect_equal(min(grade_3$hl), 34)
    expect_equal(max(grade_3$hl), 61.5)
    expect_equal(seq(34, 61.5, by = .5), unique(grade_3$hl))

    expect_equal(min(grade_3$pot), 115)
    expect_equal(max(grade_3$pot), 455)
    expect_equal(seq(115, 455, by = 5), unique(grade_3$pot))

    # grade gerada com byhl e bypot e expand

    grade_4 <- coordgrade(colinadummy, byhl = .5, bypot = 5, expand = c(.1, .1))

    expect_equal(min(grade_4$hl), 31)
    expect_equal(max(grade_4$hl), 64)
    expect_equal(seq(31, 64, by = .5), unique(grade_4$hl))

    expect_equal(min(grade_4$pot), 85)
    expect_equal(max(grade_4$pot), 485)
    expect_equal(seq(85, 485, by = 5), unique(grade_4$pot))
})


#' Local ATE label
#'
#' @param object object with "local_lm" or "global_lm" class
#' @param label string of label format
#' @param digits decimal place
#'
#' @importFrom generics tidy
#' @importFrom dplyr case_when
#'
label_maker <- function(object, label, digits = 3) {
  decompose <- strsplit(label, "\\{|\\}")[[1]]
  textpart <- decompose[grep("[^'']", decompose)]
  numform <- paste0("%1.", digits, "f")

  res <- generics::tidy(object)

  textpart[grep("estimate", textpart)] <- sprintf(numform, res$estimate)
  textpart[grep("std.error", textpart)] <- sprintf(numform, res$std.error)
  textpart[grep("statistic", textpart)] <- sprintf(numform, res$statistic)
  textpart[grep("p.value", textpart)] <- sprintf(numform, res$p.value)
  textpart[grep("star", textpart)] <- dplyr::case_when(
    res$p.value <= .01 ~ "***",
    res$p.value < .05 ~ "**",
    res$p.value < .1 ~ "*",
    TRUE ~ ""
  )

  paste0(textpart, collapse = "")
}

#' Basic RD plot
#'
#' @param aggregate observed data aggregated by mass points
#' @param predict1 predicted data of treated
#' @param predict0 predicted data of control
#' @param cutoff cutoff value
#' @param ate_label In-plot text about local ATE estimates
#' @param ate_label_size In-plot text size
#' @param outcome_label Outcome label in plot title
#' @param ylim numeric vector of limits of y-axis
#' @param vjust numeric. Adjust in-plot text vertically
#' @param hjust numeric. Adjust in-plot text horizontally
#' @param xlab label of x-axis
#' @param ylab label of y-axis
#' @param \dots arguments of [simplegg()]
#'
#' @importFrom ggplot2 ggplot
#' @importFrom ggplot2 aes
#' @importFrom ggplot2 geom_point
#' @importFrom ggplot2 geom_line
#' @importFrom ggplot2 geom_vline
#' @importFrom ggplot2 annotate
#' @importFrom ggplot2 labs
#' @importFrom ggplot2 ylim
#'
#'
rdplot_internal_cutoff <- function(aggregate,
                                   predict1,
                                   predict0,
                                   cutoff,
                                   ate_label,
                                   ate_label_size = 5,
                                   outcome_label,
                                   ylim,
                                   vjust = 0,
                                   hjust = 0,
                                   xlab = "Running variable",
                                   ylab = "Average",
                                   ...) {
  x <- outcome <- d <- yhat1 <- yhat0 <- NULL

  title <- if (missing(outcome_label)) NULL else outcome_label

  g <- ggplot2::ggplot(aggregate, ggplot2::aes(x = x, y = outcome)) +
    ggplot2::geom_point(ggplot2::aes(shape = d), size = 2) +
    ggplot2::geom_line(ggplot2::aes(x = x + cutoff, y = yhat1), predict1) +
    ggplot2::geom_line(ggplot2::aes(x = x + cutoff, y = yhat0), predict0) +
    ggplot2::geom_vline(ggplot2::aes(xintercept = cutoff), linetype = 3) +
    ggplot2::annotate(
      "text", x = -Inf, y = Inf, label = ate_label,
      vjust = 1 + vjust, hjust = 0 + hjust, size = ate_label_size,
      family = getOption("discRD.plot_family")
    ) +
    ggplot2::labs(
      x = xlab,
      y = ylab,
      title = title,
      shape = NULL
    )

  if (missing(ylim)) {
    g + simplegg(font_family = getOption("discRD.plot_family"), ...)
  } else {
    g + ggplot2::ylim(ylim) +
      simplegg(font_family = getOption("discRD.plot_family"), ...)
  }

}


## ----echo = FALSE----------------------------------------------------------------------
knitr::opts_chunk$set(
  message = FALSE,
  warning = FALSE,
  collapse = TRUE,
  comment = "#>",
  fig.height = 4,
  fig.width = 8,
  fig.align = "center",
  cache = FALSE
)

## /* custom.css */

## .left-code {

##   color: #777;

##   width: 48%;

##   height: 92%;

##   float: left;

## }

## .right-plot {

##   width: 50%;

##   float: right;

##   padding-left: 1%;

## }

## ----echo=FALSE------------------------------------------------------------------------
library(tidyverse)
library(plotly)
library(gganimate)
library(datasauRus)

## ---- include = F----------------------------------------------------------------------
# Download cran data from metacran
library(cranlogs)
library(lubridate)
cran_dls <- cran_downloads(c("ggplot2", "plotly", "leaflet", "ggvis", "animint2", "rCharts", "gridSVG", "R2D3", "shiny", "crosstalk"),
                           from = "2019-01-01", to = today())
write_csv(cran_dls, file = "../../data/package-info-July-2021.csv")

## ---- echo=FALSE, fig.width=10, fig.height = 8-----------------------------------------
cran_dls <- read_csv(here::here("data/package-info-July-2021.csv"))
cran_summary <- cran_dls %>%
  mutate(date = ymd(date) %>% floor_date("week")) %>%
  group_by(package, date) %>%
  summarise(totaldown = sum(count))

label_summary <- cran_summary %>%
  ungroup() %>%
  group_by(package) %>%
  filter(totaldown == max(totaldown))

cran_summary %>%
  ggplot(aes(x = date, y = totaldown, colour=package)) +
  geom_line() +
  theme_bw() +
  theme(legend.position="none") +
  geom_text(
    aes(x = date, y = 1.05*totaldown, label=package),
    data = label_summary) +
  ylab("Monthly downloads") +
  xlab("Time") +
  scale_y_log10()

## ----plotly----------------------------------------------------------------------------
library(plotly)
plot_ly(data = economics, x = ~date, y = ~unemploy / pop)

## --------------------------------------------------------------------------------------
gg <- ggplot(data=economics, aes(x = date, y = unemploy / pop)) +
        geom_point() + geom_line()

ggplotly(gg)

## ----fig.width=6, fig.height=6---------------------------------------------------------
library(GGally)
p <- ggpairs(economics[,3:6])
ggplotly(p)

## --------------------------------------------------------------------------------------
data(canada.cities, package = "maps")
viz <- ggplot(canada.cities, aes(long, lat)) +
  borders(regions = "canada") +
  coord_equal() +
  geom_point(aes(text = name, size = log2(pop)), colour = "red", alpha = 1/4)
 ggplotly(viz)

## ----eval=FALSE------------------------------------------------------------------------
## sd <- highlight_key(txhousing, ~year)
##
## p <- ggplot(sd, aes(month, median)) +
##    geom_line(aes(group = year)) +
##    geom_smooth(data = txhousing, method = "gam") +
##    facet_wrap(~ city)
##
## gg <- ggplotly(p, height = 600, width = 1000) %>%
##    layout(title = "Click on a line to highlight a year")
##
## highlight(gg)

## ----echo=FALSE------------------------------------------------------------------------
sd <- highlight_key(txhousing, ~year)

p <- ggplot(sd, aes(month, median)) +
   geom_line(aes(group = year)) +
   geom_smooth(data = txhousing, method = "gam") +
   facet_wrap(~ city)

gg <- ggplotly(p, height = 600, width = 1000) %>%
   layout(title = "Click on a line to highlight a year")

highlight(gg)

## ---- echo=FALSE, fig.width = 8, fig.height = 6----------------------------------------
library(gapminder)

ggplot(gapminder, aes(gdpPercap, lifeExp, size = pop, colour = country)) +
  geom_point(alpha = 0.7) +
  scale_colour_manual(values = country_colors, guide=FALSE) +
  scale_size("Population size", range = c(2, 12), breaks=c(1*10^8, 2*10^8, 5*10^8, 10^9, 2*20^9)) +
  scale_x_log10() +
  facet_wrap(~continent) +
  theme(legend.position = "bottom") +
  # Here comes the gganimate specific bits
  labs(title = 'Year: {frame_time}', x = 'GDP per capita', y = 'life expectancy') +
  gganimate::transition_time(year) +
  gganimate::ease_aes('linear')

## ----plot1, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(economics) #<<

## ----output1, ref.label="plot1", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot2, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(economics) +
##   aes(date, unemploy) #<<

## ----output2, ref.label="plot2", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot3, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(economics) +
##   aes(date, unemploy) +
##   geom_line() #<<

## ----output3, ref.label="plot3", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot5-anim, eval=FALSE, echo=TRUE-------------------------------------------------
## ggplot(economics) +
##   aes(date, unemploy) +
##   geom_line() +
##   transition_reveal(date) #<<

## ----output5-anim, ref.label="plot5-anim", echo=FALSE, cache=TRUE, fig.height = 6------

## ----plot5, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(datasaurus_dozen)#<<

## ----output5, ref.label="plot5", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot6, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(datasaurus_dozen) +
##   aes(x, y, color=dataset)#<<

## ----output6, ref.label="plot6", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot7, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(datasaurus_dozen) +
##   aes(x, y, color=dataset) +
##   geom_point() #<<

## ----output7, ref.label="plot7", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot8, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(datasaurus_dozen) +
##   aes(x, y, color=dataset) +
##   geom_point() +
##   facet_wrap(~dataset)#<<

## ----output8, ref.label="plot8", echo=FALSE, cache=TRUE, fig.height = 6----------------

## ----plot9, eval=FALSE, echo=TRUE------------------------------------------------------
## ggplot(datasaurus_dozen) +
##   aes(x, y) +
##   geom_point() +
##   transition_states(dataset, 3, 1) + #<<
##   labs(title = "Dataset: {closest_state}") #<<
##

## ----output9, ref.label="plot9", echo=FALSE, cache=TRUE, fig.height = 6----------------

## --------------------------------------------------------------------------------------
library(gapminder)

ggplot(gapminder, aes(gdpPercap, lifeExp, size = pop, colour = country)) +
  geom_point(alpha = 0.7) +
  scale_colour_manual(values = country_colors, guide=FALSE) +
  scale_size("Population size", range = c(2, 12), breaks=c(1*10^8, 2*10^8, 5*10^8, 10^9, 2*20^9)) +
  scale_x_log10() +
  facet_wrap(~continent) +
  theme(legend.position = "bottom")


#' mrt_thorsson
#'
#' Calculated the mean radiant temperature from the solar radiation.  Modified based on direct and diffuse ratio. Assumes a uniform surround temperature of Ta && short wave solar radiation only;
#'
#' @param t numeric air temperature in degC.
#' @param tg numeric global short solar irradiance in Watt on mq.
#' @param wind numeric windspeed in meter per second.
#' @param diam numeric diameter of the sphere in millimeter. Input example 50 mm.
#' @return Mean Radiant temperature in degC
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references Thorsson et al, Different methods for estimating the mean radiant temperature in an outdoor urban setting, Int. J. Climatol.27  1983   1993 (2007)
#' @keywords  MRT
#'
#' @export
#'
#'
#'
#'

mrt_thorsson=function(t,tg,wind,diam) {
                         ct$assign("t", as.array(t))
                         ct$assign("tg", as.array(tg))
                         ct$assign("wind", as.array(wind))
                         ct$assign("diam", as.array(diam))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=mrt_thorsson(t[i],tg[i],wind[i],diam[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}

#' mrt_globe
#'
#' Given air temperature , the globe Temeperature, the wind speed and diameter mean radiant temperature is done according ISO 7726 1998.
#'
#' @param t numeric air temperature in degC.
#' @param tg numeric global short solar irradiance in Watt on mq.
#' @param wind numeric windspeed in meter per second.
#' @param diam numeric diameter of the sphere in millimeters. Input example 50 mm.
#' @return Mean Radiant temperature in degC
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  globe temperature
#'
#' @export
#'
#'
#'
#'

mrt_globe=function(t,tg,wind,diam) {
                         ct$assign("t", as.array(t))
                         ct$assign("tg", as.array(tg))
                         ct$assign("wind", as.array(wind))
                         ct$assign("diam", as.array(diam))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=mrt_globe(t[i],tg[i],wind[i],diam[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}

#' mrt_solar_proj
#'
#' Calculated the mean radiant temperature from the short solar irradiance with human projection factor. it assumes a uniform surround temperature of air temperature  and short wave solar radiation.
#'
#' @param t numeric        Air temperature in degC.
#' @param rh numeric       Relative humidity in percentage.
#' @param solar  numeric   Global solar radiation in Watt on mq.
#' @param sunelev numeric  Sun elevation angle in decimal degrees.
#' @param alb_sfc numeric  Mean albedo of surroundings. Default is 0.4.
#' @param emis_sfc numeric Surface emissivity.
#' @param fdir numeric    Ratio between directed ad diffuse radiation.
#' @return Mean Radiant temperature projected in degC.
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  fMRT
#'
#' @export
#'
#'
#'
#'

mrt_solar_proj=function(t,rh,solar,sunelev,alb_sfc,fdir,emis_sfc) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("solar", as.array(solar))
                         ct$assign("sunelev", as.array(sunelev))
                         ct$assign("albedo", as.array(alb_sfc))
                         ct$assign("emis_sfc", as.array(emis_sfc))
                         ct$assign("fdir", as.array(fdir))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=mrt_solar_proj(t[i],rh[i],solar[i],sunelev[i],albedo[i],emis_sfc[0],fdir[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


## setwd('stan')
library(data.table)
library(ggplot2)

source('../../functions.r')
source('../../data/parameters.r')

spplist  <- fread('../../data/species-info/species-list.csv')
setkey(spplist, code)
nspp <- nrow(spplist)

modeldat <- new.env()
load('../../generated/data.rdata', modeldat)

load('assets/mcmc-results.rdata')

plot_prior_posterior <- function(mc, mainlab=NULL, sublab=NULL, panel_scales = 'free_y', xlims = NULL, trans_x = NULL) {
    g <- ggplot(mc) +
        geom_density(aes(x = value, y = ..scaled.., fill = type), size = 0.1, colour = 'black') +
        facet_wrap(~ label, scales = panel_scales) +
        scale_x_continuous(limits = xlims, trans = trans_x) +
        scale_fill_manual(name = NULL, values = c(Prior = '#55555555', Posterior = "#238B4599")) +
        labs(x = 'log(Vulnerability)', y = 'Density') +
        theme_minimal() +
        theme(panel.grid.major.y=element_blank(),
              panel.grid.minor.y=element_blank(),
              strip.text=element_text(size = 6),
              axis.text = element_text(size = 6))
    if (!is.null(mainlab)) {
        if (!is.null(sublab)) {
            g <- g + ggtitle(mainlab, sublab)
        } else {
            g <- g + ggtitle(mainlab)
        }
    }
    return(g)
}

## * Table of estimates

qs <- mcsumm[grepl('^q', variable, perl=T) & !grepl('prior', variable, perl=T)]

qs[grepl('^q0', variable, perl=T),
   par_lab := 'Intercept']
qs[grepl('^q_f0', variable, perl=T),
   par_lab := 'Fishery group']
qs[grepl('^q_g0', variable, perl=T),
   par_lab := 'Species group']
qs[grepl('^q_gf0', variable, perl=T),
   par_lab := 'Species x fishery group']

qs[, fg_lab := flags[as.character(fishery_group)]]

qs[species_group == 'ANT', sp_lab := 'Antipodeans']
qs[species_group == 'RYL', sp_lab := 'Royals']
qs[species_group == 'WND', sp_lab := 'Wanderers']
qs[species_group == 'DIP', sp_lab := 'S. royal']
qs[species_group == 'DIQ', sp_lab := 'N. royal']
qs[species_group == 'DIW', sp_lab := 'Gibson\'s']
qs[species_group == 'DQS', sp_lab := 'Antipodean']
qs[species_group == 'TAM', sp_lab := 'Tristan + Amst.']

qs[vartype %in% 'q_gf0', sp_lab := upper1st(spplist[match(species, code), common_name])]
qs[vartype %in% 'q_gf0', lab := sprintf('%s in %s', sp_lab, fg_lab)]
qs[vartype %in% 'q_g0', lab := sp_lab]
qs[vartype %in% 'q_f0', lab := fg_lab]

qs_export <- qs[, .(par_lab, lab, mean, lcl, ucl, min, max)]
qs_export[, par_lab := factor(par_lab, levels = c('Intercept', 'Fishery group', 'Species group', 'Species x fishery group'))]
setorder(qs_export, par_lab, -mean)

fwrite(qs, 'assets/vulnerabilities-all.csv')
fwrite(qs_export, 'assets/vulnerabilities.csv')

## * Plot of prior/posterior

## ** Posteriors
mc <- mcmc[grepl('^q', variable, perl=T) & !grepl('prior', variable, perl=T)]
mc <- merge(mc, mc_attributes, by = c('variable'), all.x=T, all.y=F)
mc[, type := 'Posterior']

## ** Priors
priors <- mcmc[grepl('^q', variable, perl=T) & grepl('prior', variable, perl=T)]
priors_d <- rbindlist(lapply(qs$variable, function(v) {
    if (grepl('^q0|^q_f0|^q_g0', v)) {
        p <- priors[variable == 'q_prior']
    } else {
        p <- priors[variable == 'q_gf_prior']
    }
    p[, variable := v]
    p[, type := 'Prior']
    return(p)
}))
priors_d <- merge(priors_d, mc_attributes, by = c('variable'), all.x=T, all.y=F)

## ** Labels
prior_posterior <- rbind(priors_d, mc)

prior_posterior[grepl('^q0', variable, perl=T),
   par_lab := 'Intercept']
prior_posterior[grepl('^q_f0', variable, perl=T),
   par_lab := 'Fishery']
prior_posterior[grepl('^q_g0', variable, perl=T),
   par_lab := 'Species']
prior_posterior[grepl('^q_gf0', variable, perl=T),
   par_lab := 'Species x fishery']

prior_posterior[, fg_lab := flags[as.character(fishery_group)]]

prior_posterior[species_group == 'ANT', sp_lab := 'Antipodeans']
prior_posterior[species_group == 'RYL', sp_lab := 'Royals']
prior_posterior[species_group == 'WND', sp_lab := 'Wanderers']
prior_posterior[species_group == 'DIP', sp_lab := 'S. royal']
prior_posterior[species_group == 'DIQ', sp_lab := 'N. royal']
prior_posterior[species_group == 'DIW', sp_lab := 'Gibson\'s']
prior_posterior[species_group == 'DQS', sp_lab := 'Antipodean']
prior_posterior[species_group == 'TAM', sp_lab := 'Tristan + Amst.']

prior_posterior[, lab := paste(na.omit(c(sp_lab, fg_lab)), collapse=' in '), by = 1:nrow(prior_posterior)]
prior_posterior[, label := paste(setdiff(c(par_lab, lab), ''), collapse='\n'), by = 1:nrow(prior_posterior)]
prior_posterior[, label := factor(label, levels = unique(label))]

prior_posterior[, type := factor(type, levels = c('Prior', 'Posterior'))]

g <- plot_prior_posterior(prior_posterior, panel_scales='free', trans_x = 'log')

ggsave('assets/vulnerabilities_comparison-prior-posterior.png', g, width = 9, height = 7)


permuted.difference <- function(){

source('/data/Dropbox/phenocam_classification/code/image.plot.R')

labels.2006 <- read.table('../all-labels-2006.txt')
labels.2007 <- read.table('../all-labels-2007.txt')
labels.2008 <- read.table('../all-labels-2008.txt')
labels.2009 <- read.table('../all-labels-2009.txt')
labels.2010 <- read.table('../all-labels-2010.txt')

nrows <- dim(labels.2006)[1]
ncols <- dim(labels.2006)[2]

outputmatrix <- matrix(NA,nrows,ncols)

# for every class extract col from matrics

for (k in 1:ncols){

tmp <- matrix(NA,nrows,25)
x <- matrix(NA,nrows,5)

x[,1] <- labels.2006[,k]
x[,2] <- labels.2007[,k]
x[,3] <- labels.2008[,k]
x[,4] <- labels.2009[,k]
x[,5] <- labels.2010[,k]

#x[x == 15] <- NA

	for (i in 1:5){
		for (j in 1:5){
		diff <- abs(x[,i] - x[,j])
		diff[diff > 0 ] <- 1
		tmp[,i*j] <- diff
		}
	}

tmp <- as.matrix(rowSums(tmp,na.rm=T)/25)
outputmatrix[,k] <- tmp

}

outputmatrix <- apply(outputmatrix,1,function(x)1-mean(x,na.rm=T))
outputmatrix <- matrix(outputmatrix,480,640)
myImagePlot(outputmatrix)
write.table(outputmatrix,'permuted.differences.txt',quote=F,row.names=F,col.names=F)

}
permuted.difference()


## ============================================================================================
##
## predictDiagnosis
##
## ============================================================================================

computePredResMat <- function(predRes, predRes0, followUpTime, followUpTime0) {
  selPeriodStrs <- c("Year 1", "Year 1-2", "Year 3-4", "Year 5-6")
  selPeriodInterval <- matrix(NA, nrow=4, ncol=2)
  selPeriodInterval[1,] <- c(1,365)
  selPeriodInterval[2,] <- c(1,2*365)
  selPeriodInterval[3,] <- c(2*365+1,4*365)
  selPeriodInterval[4,] <- c(4*365+1,6*365)

  resMat <- matrix(NA, nrow=5, ncol=5)
  rownames(resMat) <- c("All years", selPeriodStrs)
  colnames(resMat) <- c("FN", "TP", "FP", "TN", "P-value")

  for (i in 0:length(selPeriodStrs)) {
    fn <- sum(!predRes>0)
    tp <- sum(predRes>0)
    fp <- sum(!predRes0<0)
    tn <- sum(predRes0<0)
    if (i>0) {
      sel <- followUpTime>selPeriodInterval[i,1] & followUpTime<=selPeriodInterval[i,2]
      sel0 <- followUpTime0>selPeriodInterval[i,1] & followUpTime0<=selPeriodInterval[i,2]
      fn <- sum(!predRes[sel]>0)
      tp <- sum(predRes[sel]>0)
      fp <- sum(!predRes0[sel0]<0)
      tn <- sum(predRes0[sel0]<0)
    }

    resMat[i+1,] <-
      c(fn, tp, fp, tn,
        fisher.test(matrix(c(tp, fn, fp, tn), ncol=2, byrow=F),
                    alternative="g")$p.value)
  }

  resMat
}

predictDiagnosis  <- function(dataList, n, nofGenes,  strFollowUpTime, strPlotFracCorr, strResMat,
                              m, m2, selPeriodStr, selPeriodInterval, selPeriodFromWith,
                              hasInsitu=FALSE) {

  ## Predict diagnosis using a leave-one-out approach, n=periodLength
  caseStr <- "Weight"
  caseN <- "N1"

  curDataList <- selectDataset(dataList, caseN, dataList$withSpread)
  data <- curDataList$data
  followUpTime <- curDataList$followUpTime
  weights <- curDataList$weights
  curDataList0 <- selectDataset(dataList, caseN, dataList$withoutSpread)
  data0 <- curDataList0$data
  followUpTime0 <- curDataList0$followUpTime
  weights0 <- curDataList0$weights
  if (hasInsitu) {
    curDataListInsitu <- selectDataset(dataList, caseN, dataList$insitu)
    dataInsitu <- curDataListInsitu$data
    followUpTimeInsitu <- curDataListInsitu$followUpTime
    weightsInsitu <- curDataListInsitu$weights
  }
  selFollowUpTime <- followUpTime0
  notSelFollowUpTime <- followUpTime
  if (selPeriodFromWith) {
    selFollowUpTime <- followUpTime
    notSelFollowUpTime <- followUpTime0
  }
  nofPeriods <- length(selFollowUpTime)-n+1

  ## Select genes for predictor
  ## Find sorting of genes from analyses for "Weights" in predictor
  ## Weights with sign for genes selected for predictor:  Number of genes selected?

  predRes <- matrix(NA, ncol=length(nofGenes), nrow=ncol(data))
  predRes0 <- matrix(NA, ncol=length(nofGenes), nrow=ncol(data0))
  rownames(predRes) <- colnames(data)
  rownames(predRes0)  <- colnames(data0)
  colnames(predRes) <- colnames(predRes0) <- nofGenes
  if (hasInsitu) {
    predResInsitu <- matrix(NA, ncol=length(nofGenes), nrow=ncol(dataInsitu))
    colnames(predResInsitu) <- nofGenes
  }

  for (p in 1:nofPeriods)
    print(c(selFollowUpTime[p+n-1]-selFollowUpTime[p],
            sum(notSelFollowUpTime %in% selFollowUpTime[p]:selFollowUpTime[p+n-1])))

  meanTimeForPeriod <- rep(NA, nofPeriods)
  for (p in 1:nofPeriods)
    meanTimeForPeriod[p] <- (selFollowUpTime[p+n-1]+selFollowUpTime[p])/2

  bestPeriod <- rep(NA, length(followUpTime))
  bestPeriod0 <- rep(NA, length(followUpTime0))
  bestPeriod[followUpTime < mean(meanTimeForPeriod[1:2])] <- 1
  bestPeriod0[followUpTime0 < mean(meanTimeForPeriod[1:2])] <- 1
  bestPeriod[followUpTime > mean(meanTimeForPeriod[(length(meanTimeForPeriod)-1):
                                                   (length(meanTimeForPeriod))])] <- nofPeriods
  bestPeriod0[followUpTime0 > mean(meanTimeForPeriod[(length(meanTimeForPeriod)-1):
                                                     (length(meanTimeForPeriod))])] <- nofPeriods
  if (hasInsitu) {
    bestPeriodInsitu <- rep(NA, length(followUpTimeInsitu))
    bestPeriodInsitu[followUpTimeInsitu < mean(meanTimeForPeriod[1:2])] <- 1
    bestPeriodInsitu[followUpTimeInsitu >
                     mean(meanTimeForPeriod[(length(meanTimeForPeriod)-1):
                                            (length(meanTimeForPeriod))])] <- nofPeriods
  } else {
    bestPeriodInsitu <- c()
  }

  for (p in 2:(nofPeriods-1)) {
    bestPeriod[followUpTime >= mean(meanTimeForPeriod[(p-1):p]) &
               followUpTime <= mean(meanTimeForPeriod[(p):(p+1)])] <- p
    bestPeriod0[followUpTime0 >= mean(meanTimeForPeriod[(p-1):p]) &
                followUpTime0 <= mean(meanTimeForPeriod[(p):(p+1)])] <- p
    if (hasInsitu) {
      bestPeriodInsitu[followUpTimeInsitu >= mean(meanTimeForPeriod[(p-1):p]) &
                       followUpTimeInsitu <= mean(meanTimeForPeriod[(p):(p+1)])] <- p
    }
  }

  for (p in unique(sort(c(bestPeriod, bestPeriod0, bestPeriodInsitu)))) {
    selInd <-  (1:length(followUpTime))[followUpTime>=selFollowUpTime[p] &
                                        followUpTime<=selFollowUpTime[p+n-1]]
    selInd0 <- (1:length(followUpTime0))[followUpTime0>=selFollowUpTime[p] &
                                         followUpTime0<=selFollowUpTime[p+n-1]]

    leaveOut <- which(bestPeriod==p)
    leaveOut0 <- which(bestPeriod0==p)
      if (hasInsitu) {
        leaveOutInsitu <- which(bestPeriodInsitu==p)
      }

    ## Predict for group1
    if (length(leaveOut)>0)
      for (i in leaveOut) {
        curData <- data[, selInd[selInd!=i]]
        curWeights <- weights[, selInd[selInd!=i]]
        curFollowUpTime <- followUpTime[selInd[selInd!=i]]
        curData0 <- data0[, selInd0]
        curWeights0 <- weights0[, selInd0]
        curFollowUpTime0 <- followUpTime0[selInd0]

        mu1 <- computeMean(curData, curWeights)
        mu0 <- computeMean(curData0, curWeights0)
        var1 <- computeVar(curData, curWeights)
        var0 <- computeVar(curData0, curWeights0)

        weight <- as.numeric((mu1-mu0)/sqrt(var1 + var0))
        sortList <- sort.list(abs(weight), decreasing=TRUE)

        for (j in 1:length(nofGenes)) {
          selGenes <- sortList[1:nofGenes[j]]
          predRes[i, j] <- sum(weight[selGenes]*data[selGenes,i])
        }
      }

    ## Predict for group0
    if (length(leaveOut0)>0)
      for (i in leaveOut0) {
        curData <- data[, selInd]
        curWeights <- weights[, selInd]
        curFollowUpTime <- followUpTime[selInd]
        curData0 <- data0[, selInd0[selInd0!=i]]
        curWeights0 <- weights0[, selInd0[selInd0!=i]]
        curFollowUpTime0 <- followUpTime0[selInd0[selInd0!=i]]

        mu1 <- computeMean(curData, curWeights)
        mu0 <- computeMean(curData0, curWeights0)
        var1 <- computeVar(curData, curWeights)
        var0 <- computeVar(curData0, curWeights0)

        weight <- as.numeric((mu1-mu0)/sqrt(var1+var0))
        sortList <- sort.list(abs(weight), decreasing=TRUE)
        for (j in 1:length(nofGenes)) {
          selGenes <- sortList[1:nofGenes[j]]
          predRes0[i, j] <- sum(weight[selGenes]*data0[selGenes,i])
        }
      }

    ## Predict for groupInsitu
    if (hasInsitu) {
      if (length(leaveOutInsitu)>0) {
        curData <- data[, selInd]
        curWeights <- weights[, selInd]
        curFollowUpTime <- followUpTime[selInd]
        curData0 <- data0[, selInd0]
        curWeights0 <- weights0[, selInd0]
        curFollowUpTime0 <- followUpTime0[selInd0]

        mu1 <- computeMean(curData, curWeights)
        mu0 <- computeMean(curData0, curWeights0)
        var1 <- computeVar(curData, curWeights)
        var0 <- computeVar(curData0, curWeights0)

        weight <- as.numeric((mu1-mu0)/sqrt(var1+var0))
        sortList <- sort.list(abs(weight), decreasing=TRUE)

        for (i in leaveOutInsitu) {
          for (j in 1:length(nofGenes)) {
            selGenes <- sortList[1:nofGenes[j]]
            predResInsitu[i, j] <- sum(weight[selGenes]*dataInsitu[selGenes,i])
          }
        }
      }
    }
  }

  for (nGenes in nofGenes) {

    resMat <- computePredResMat(predRes[,paste(nGenes)], predRes0[,paste(nGenes)],
                                followUpTime, followUpTime0)
    write.table(resMat, paste(strResMat, nGenes, ".txt", sep=""), sep="\t")

    ## === Print correctly and wrongly classified and p-value ===
    print(paste("Number of genes selected:", nGenes))
    ##
    fn <- sum(!predRes[,paste(nGenes)]>0)
    tp <- sum(predRes[,paste(nGenes)]>0)
    fp <- sum(!predRes0[,paste(nGenes)]<0)
    tn <- sum(predRes0[,paste(nGenes)]<0)
    print("FN TP FP TN:")
    print(c(fn, tp, fp, tn))
    print("p-value in Fisher test, all years:")
    print(fisher.test(matrix(c(tp, fn, fp, tn), ncol=2, byrow=F), alternative="g")$p.value)
    ##
    sel <- followUpTime>selPeriodInterval[1] & followUpTime<=selPeriodInterval[2]
    sel0 <- followUpTime0>selPeriodInterval[1] & followUpTime0<=selPeriodInterval[2]
    fn <- sum(!predRes[,paste(nGenes)][sel]>0)
    tp <- sum(predRes[,paste(nGenes)][sel]>0)
    fp <- sum(!predRes0[,paste(nGenes)][sel0]<0)
    tn <- sum(predRes0[,paste(nGenes)][sel0]<0)
    print("FN TP FP TN:")
    print(c(fn, tp, fp, tn))
    print(paste("p-value in Fisher test, ", selPeriodStr, ":", sep=""))
    print(fisher.test(matrix(c(tp, fn, fp, tn), ncol=2, byrow=F), alternative="g")$p.value)
    ##
    print("")

    ## === Plot correctly and wrongly classified ===
    plotDataList <- dataList
    plotCorrectPredWithS <- predRes[,paste(nGenes)]>0
    plotCorrectPredWithoutS <- predRes0[,paste(nGenes)]<=0
    ##save(plotDataList, plotCorrectPredWithS, plotCorrectPredWithoutS,
    ##     file=paste(strFollowUpTime, nGenes, ".pdf.R", sep=""))
    plotFollowUpTimesWithPredRes(dataList, predRes[,paste(nGenes)]>0,
                                 predRes0[,paste(nGenes)]<=0,
                                 paste(strFollowUpTime, nGenes, ".pdf", sep=""))

    ## === Plot fraction of correctly classified ===

    pdf(paste(strPlotFracCorr, nGenes, ".pdf", sep=""), height=7, width=15)

    tVecStart <- min(followUpTime):(max(followUpTime)-m2)
    tVecStop <- tVecStart+m2
    tVecMean <- tVecStart+m
    isCorr <- predRes[,paste(nGenes)]>0
    fracCorr <- rep(NA, length(tVecStart))
    for (i in 1:length(tVecStart))
      fracCorr[i] <- mean(isCorr[followUpTime>=tVecStart[i] & followUpTime<=tVecStop[i]])
    keep <- !is.na(fracCorr)
    ##
    plotX <- tVecMean[keep]
    plotY <- runmed(fracCorr[keep],m2)
    plotXlim <- rev(range(dataList$followUpTime))
    ##save(plotX, plotY, plotXlim, file=paste(strPlotFracCorr, nGenes, ".pdf.red.R", sep=""))
    ##
    plot(tVecMean[keep], runmed(fracCorr[keep],m2), xlim=rev(range(dataList$followUpTime)),
         type="l", ylim =c(0,1), xlab="Follow up time (days)", ylab="Fraction correctly classified",
         cex=1.4, cex.axis=1.4, cex.lab=1.4, col=2)

    tVecStart <- min(followUpTime0):(max(followUpTime0)-m2)
    tVecStop <- tVecStart+m2
    tVecMean <- tVecStart+m
    isCorr <- predRes0[,paste(nGenes)]<=0
    fracCorr <- rep(NA, length(tVecStart))
    for (i in 1:length(tVecStart))
      fracCorr[i] <- mean(isCorr[followUpTime0>=tVecStart[i] & followUpTime0<=tVecStop[i]])
    keep <- !is.na(fracCorr)
    ##
    plotX <- tVecMean[keep]
    plotY <- runmed(fracCorr[keep],m2)
    ##save(plotX, plotY, plotXlim, file=paste(strPlotFracCorr, nGenes, ".pdf.black.R", sep=""))
    ##
    lines(tVecMean[keep], runmed(fracCorr[keep], m2),  cex=1.4, cex.axis=1.4, cex.lab=1.4, col=1)

    abline(h=0.5, lty=2)
    for (i in 0:7)
      abline(v=365*i)

    dev.off()
  }
}


#!/usr/bin/env Rscript
#----------------------------------------------------------------------------------------------------------------#
# Filename:
#   ppa_sibgc_v1.r
# Description:
#   R implementation of the Perfect Plasticity Approximation (PPA) with simply biogeochemistry (PPA-SiBGC).
# Version:
#   1.0
# Authors:
#   Adam Erickson,   Washington State University
#   Nikolay Strigul, Washington State University
# Modified:
#   June 30, 2018
# Procedure:
#   (1) Generate constant growth, mortality, and regeneration coefficients from plot data
#   (2) Generate above- and below-ground stoichiometric coefficients from databases
#   (3) Run the Sortie-PPA model:
#     (*) Generate cohorts from tree inventory data
#     (*) Initialize values for allometry, biomass, C, and N from species, type, DBH
#     (a) Soil respiration
#     (b) Regeneratation
#     (c) Sort by height descending
#     (d) Calculate cumulative crown area (CCA)
#     (e) Calculate Z* height and nearest cohort
#     (f) Mortality
#     (g) Growth
#     (h) Allometry
#     (i) Biomass fractions
#     (j) Carbon fractions
#     (k) Nitrogen fractions
#     (l) Save yearly results to CSV
#     (m) Save final results to CSV
#   (4) Compare model results against empirical data
# Notes:
#   Sortie-PPA is based on the assumption that tree canopies are perfectly plastic. This reduces
#   the variance in canopy join heights to zero, creating a single canopy join height known as z*.
#   The approximation allows for model simplification and mathematical tractability. The spatial
#   location of trees is discarded. Growth and mortality are modeled by their mean values for each
#   species and type (adults = above z*; saplings = below z*). Coefficients are used to modify
#   growth rates per the fraction of light received by trees above and below the z* threshold.
#   Aboveground biomass is modeled using equations from Chojnacky, Heath, and Jenkins (2014).
#   Belowground biomass as well as C,N dynamics are modeled using allometry and stoichiometry.
# Examples:
#   Rscript --vanilla ppa_v50.r
#   Rscript --vanilla ppa_v50.r --wd /Users/null/test --verbose
#----------------------------------------------------------------------------------------------------------------#
Version <- "5.0"

# Debugging
options(error=quote({dump.frames(to.file=TRUE); q()}))

# Print banner and pause
Banner <- readLines("sortie_ppa_ansi_shadow.txt")
cat(Banner, sep="\n")

# Print version
message("")
message("Authors: Adam Erickson, Nikolay Strigul")
message(paste("Version:", Version, "\n"))
Sys.sleep(0)

# Remove existing outputs
outputs_files   <- dir("outputs", recursive=FALSE, full.names=TRUE)
outputs_deleted <- file.remove(outputs_files)

# Fetch trailing command line arguments
args <- commandArgs(trailingOnly=TRUE)

# Default verbosity setting
Verbose <- FALSE

# Set working directory
if (length(args) == 0) {
  message(paste0("Working directory: ", getwd()))
} else if (length(args) == 1) {
  Verbose <- args[1] %in% c("--v", "--verbose")
  stopifnot(Verbose)
} else if (length(args) == 2) {
  flag   <- args[1]
  stopifnot(flag %in% c("--wd", "--dir"))
  folder <- args[2]
  if (flag=="--wd" || flag=="--dir") {
    setwd(folder)
    message(paste("Working directory:", getwd()))
  } else {
    message("Flag not recognized.")
  }
} else if (length(args) == 3) {
  flag   <- args[1]
  stopifnot(flag %in% c("--wd", "--dir"))
  folder  <- args[2]
  setwd(folder)
  message(paste("Working directory:", getwd()))
  Verbose <- args[3] %in% c("--v", "--verbose")
  stopifnot(Verbose)
} else {
  stop("Error: Only 0 or 2 arguments may be passed.", call.=FALSE)
}

# Libraries #

# Functions #

# Round to the nearest integer by step
round_int <- function(x, step) {
  return(step * round(x / step))
}

# Bin trees into cohorts by rounding DBH to the nearest cm; check n-trees
# Expects CSV file with species, type, dbh, age (optional)
GenerateCohorts <- function(Trees, interval=1) {
  n_trees <- nrow(Trees)
  Trees$dbh <- round_int(Trees$dbh, interval)
  if("age" %in% tolower(colnames(Trees))) {
    age <- aggregate(Trees$age, by=list(Trees$species, Trees$type, Trees$dbh), FUN=mean)
    colnames(age) <- c("species","type","dbh","age")
    Trees <- subset(Trees, select= -c(age))
    Trees <- merge(Trees, age, by=c("species","type","dbh"))
  }
  cohorts <- data.frame(table(Trees$species, Trees$type, Trees$dbh))
  colnames(cohorts) <- c("species","type","dbh","n_trees")
  cohorts$n_trees <- cohorts$n_trees + 1
  Trees <- merge(Trees, cohorts, by=c("species","type","dbh"))
  Trees <- Trees[!duplicated(Trees[,c("species","type","dbh")]), ]
  Trees <- Trees[Trees$dbh > 0 & !is.na(Trees$n_trees), ]
  Trees$id <- 1:nrow(Trees)
  if ("age" %in% tolower(colnames(Trees))) {
    Trees <- Trees[, c("id","species","type","age","dbh","n_trees")]
  } else {
    Trees <- Trees[, c("id","species","type","dbh","n_trees")]
  }
  message(paste(n_trees, "trees merged to", nrow(Trees), "cohorts containing",
                sum(Trees$n_trees), "trees"))
  return(Trees)
}

# Create biomass, C, and N compartments
Initialize <- function(Trees, ...) {
  # Create columns
  Trees$height              <- NA
  Trees$crown_l             <- NA
  Trees$crown_r             <- NA
  Trees$crown_a             <- NA
  Trees$ba                  <- NA
  Trees$crown_a_cumsum      <- NA
  Trees$biomass_ag          <- NA
  Trees$biomass_stem        <- NA
  Trees$biomass_branch      <- NA
  Trees$biomass_leaf        <- NA
  Trees$biomass_root_coarse <- NA
  Trees$biomass_root_fine   <- NA
  Trees$biomass_soil        <- NA
  Trees$biomass_bg          <- NA
  Trees$biomass_total       <- NA
  Trees$c_ag                <- NA
  Trees$c_bg                <- NA
  Trees$c_total             <- NA
  Trees$anpp                <- NA
  Trees$n_ag                <- NA
  Trees$n_bg                <- NA
  Trees$n_total             <- NA
  Trees$annp                <- NA
  # Update each species and type; vectorized
  for (species in unique(Trees$species)) {
    if (!species %in% AllometryLUT$species) { stop("Species not found in allometry table") }
    s <- Trees$species==species
    for (type in unique(Trees[s,]$type)) {
      st <- Trees$species==species & Trees$type==type
      index <- AllometryLUT$species==species & AllometryLUT$type==type
      allometry <- AllometryLUT[index,]
      Trees[st,]$height  <- 1.35 + (30-1.35) * (1-exp(-(allometry$h_coeff * Trees[st,]$dbh)))
      Trees[st,]$height  <- ifelse(Trees[st,]$height > 30, 30, Trees[st,]$height) # limit height to 30m
      Trees[st,]$type    <- ifelse(Trees[st,]$dbh > 10, "adult", "sapling")
      Trees[st,]$crown_l <- allometry$cd  * Trees[st,]$dbh
      Trees[st,]$crown_r <- allometry$cr1 * Trees[st,]$dbh^allometry$cr2
      Trees[st,]$crown_a <- Trees[st,]$crown_r^2 * pi
      Trees[st,]$ba      <- Trees[st,]$dbh^2 * 0.00007854 # forester's constant for DBH (cm); m2
    }
    # Biomass allocation or partitioning
    if (!species %in% BiomassLUT$species) { stop("Species not found in biomass table") }
    index <- BiomassLUT$species==species
    biomass <- BiomassLUT[index,]
    if (CohortMode) {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh)) * Trees[s,]$n_trees
    } else {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh))
    }
    Trees[s,]$biomass_stem        <- Trees[s,]$biomass_ag * biomass$fraction_stem
    Trees[s,]$biomass_branch      <- Trees[s,]$biomass_ag * biomass$fraction_branch
    Trees[s,]$biomass_leaf        <- Trees[s,]$biomass_ag * biomass$fraction_leaf
    Trees[s,]$biomass_root_coarse <- Trees[s,]$biomass_ag * exp(-1.4485 - 0.03476 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_root_fine   <- Trees[s,]$biomass_ag * exp(-1.8629 - 0.77534 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_soil        <- Trees[s,]$biomass_ag * biomass$fraction_soil
    Trees[s,]$biomass_bg          <- Trees[s,]$biomass_root_coarse + Trees[s,]$biomass_root_fine +
                                     Trees[s,]$biomass_soil
    Trees[s,]$biomass_total       <- Trees[s,]$biomass_ag + Trees[s,]$biomass_bg
    # C fraction
    #index <- CarbonLUT$species==species
    carbon <- CarbonLUT #[index,]
    Trees[s,]$c_ag <- Trees[s,]$biomass_ag *
      ((biomass$fraction_stem   * carbon$fraction_stem)   +
       (biomass$fraction_branch * carbon$fraction_branch) +
       (biomass$fraction_leaf   * carbon$fraction_leaf))
    Trees[s,]$c_bg <- Trees[s,]$biomass_ag *
      ((biomass$fraction_root * carbon$fraction_root) +
       (biomass$fraction_soil * carbon$fraction_soil))
    Trees[s,]$c_total <- Trees[s,]$c_ag + Trees[s,]$c_bg
    Trees[s,]$anpp    <- NA
    # C:N stoichiometry
    if (!species %in% StoichiometryLUT$species) { stop("Species not found in stoichiometry table") }
    index <- StoichiometryLUT$species==species
    stoichiometry <- StoichiometryLUT[index,]
    Trees[s,]$n_ag <- Trees[s,]$c_ag /
      ((biomass$fraction_stem   * stoichiometry$cn_stem)   +
       (biomass$fraction_branch * stoichiometry$cn_branch) +
       (biomass$fraction_leaf   * stoichiometry$cn_leaf))
    Trees[s,]$n_bg <- Trees[s,]$c_bg /
      ((biomass$fraction_root * stoichiometry$cn_root)  +
       (biomass$fraction_soil * stoichiometry$cn_soil))
    Trees[s,]$n_total <- Trees[s,]$n_ag + Trees[s,]$n_bg
    Trees[s,]$annp    <- NA
  }
  return(Trees)
}

# Ensure column names and tree type are lower case
ensure_lowercase <- function(Trees) {
  colnames(Trees) <- tolower(colnames(Trees))
  Trees$type <- tolower(Trees$type)
  return(Trees)
}

# Check if year is a leap year (366 days instead of 365)
leap_year <- function(year) {
  return(ifelse((year %%4 == 0 & year %%100 != 0) | year %%400 == 0, TRUE, FALSE))
}

# Soil respiration, monthly mean; heterotrophic + autotrophic
# g C m-2 day-1; kg C m-2 day-1
# Parameters:
#  Ta = monthly mean temperature (°C)
#  P  = monthly mean precipitation (cm)
# Raich, Potter, Bhagawati, 2002, Interannual variability in global soil respiration, 1980-94, Global Change Biology, 8, pp. 800-12.
# https://onlinelibrary.wiley.com/doi/abs/10.1046/j.1365-2486.2002.00511.x
respiration_soil <- function(Ta, P) {
  if (Ta < -13.3) {
    Rs <- 0
  } else {
    if (Ta > 33.5) { Ta <- 33.5 } # bound the temperature response
    e  <- exp(1)  # Euler's constant
    Q  <- 0.05452 # soil respiration rate change wrt temperature (°C-1)
    F  <- 1.250   # soil respiration rate at 0°C (g C m-2 day-1)
    K  <- 4.259   # hyperbolic respiration-rainfall curve half-saturation constant (mm month-1)
    Rs <- F * e^(Q * Ta) * (P / (K + P))
  }
  return(Rs / 1000)
}

# Simple SOC model
# Mg C ha-1 cm-1; kg C m-2; midpoint of profile depth; Approximates integral in 1 cm steps
# Domke et al. (2017) Toward inventory-based estimates of soil organic carbon in forests of the United States, Ecological Applications, 27(4), pp. 1223–1235.
# https://www.fs.fed.us/nrs/pubs/jrnl/2017/nrs_2017_domke_001.pdf
soc_depth = function(order, depth_cm=100) {
  soc_table = data.frame(
    order     = c("All","Alfisols","Andisols","Aridisols","Entisols","Histosols","Inceptisols",
                  "Mollisols","Spodosols","Ultisols","Vertisols"),
    intercept = c(1.1795,1.1122,1.3837,0.2065,0.9300,1.6227,1.1631,1.0163,1.4262,1.1576,0.5145),
    slope     = c(-0.8228,-0.8330,-0.8425,-0.1300,-0.7207,-1.0109,-0.7331,-0.6214,-0.9801,-0.8867,-0.2427)
  )
  coeffs = as.numeric(soc_table[soc_table$order==order,][,c("intercept","slope")])
  soc    = sapply(seq(1, depth_cm, 1), function(x) 10^(coeffs[1] + coeffs[2] * log10(x)))
  soc    = sum(soc) / 10  # convert to kg m-2 integrated over depth
  return(soc)
}

# Time #
start_time <- proc.time()
loop_times <- c()

# Data #

# Load lookup tables (LUTs) into memory; expects CSV files in lut folder
Configuration    <- read.csv("configuration.csv",     stringsAsFactors=FALSE, nrows=1)
Trees            <- read.csv("trees.csv",             stringsAsFactors=FALSE)
Climate          <- read.csv("climate.csv",           stringsAsFactors=FALSE)
GrowthLUT        <- read.csv("lut/growth.csv",        stringsAsFactors=FALSE)
MortalityLUT     <- read.csv("lut/mortality.csv",     stringsAsFactors=FALSE)
RegenerationLUT  <- read.csv("lut/regeneration.csv",  stringsAsFactors=FALSE)
AllometryLUT     <- read.csv("lut/allometry.csv",     stringsAsFactors=FALSE)
BiomassLUT       <- read.csv("lut/biomass.csv",       stringsAsFactors=FALSE)
StoichiometryLUT <- read.csv("lut/stoichiometry.csv", stringsAsFactors=FALSE)
CarbonLUT        <- read.csv("lut/carbon.csv",        stringsAsFactors=FALSE, nrows=1)

# Model #

# Optional: process in parallel
#nCores <- as.integer(Configuration$n_cores)
#if (nCores > 1) {
#  library(doParallel)
#  cl <- parallel::makeCluster(nCores)
#  doParallel::registerDoParallel(cl)
#}

# Optional: Generate cohorts from initial tree list
CohortMode <- as.logical(Configuration$cohort_mode)
if (CohortMode == TRUE) {
  message("Generating cohorts...")
  Trees <- GenerateCohorts(Trees)
}

# Initialize tree biomass
message("Initializing...")
Trees <- Initialize(Trees)

# Ensure column names and tree type are lower case
Trees <- ensure_lowercase(Trees)

# Number of years to run model; e.g., 2000-2049 (50 years)
StartYear <- as.numeric(Configuration$start_year)
EndYear   <- as.numeric(Configuration$end_year)
Years     <- StartYear:EndYear # 200 years

# Amount of light suppressed cohorts receive
UnderstoryAdult   <- as.numeric(Configuration$understory_adult)   # 0.1
UnderstorySapling <- as.numeric(Configuration$understory_sapling) # 0.7

# id placeholder
id_holder <- nrow(Trees)

# Run the simulation
message("Starting simulation...")
message("=========================================================================")
for (year in Years) {

  loop_start_time <- proc.time()

  if (Verbose) {
    message("=========================================================================")
    message(paste("Year:", year))
    message(paste("n-Trees:", nrow(Trees)))
    message("=========================================================================")
  }

  # Append or update year; vectorized
  Trees$year <- year

  # Increment tree age; vectorized; regeneration yields age 0
  Trees$age <- Trees$age + 1

  # Calculate soil respiration
  if (Verbose) {
    message("Computing soil respiration...")
  }
  climate  <- Climate[Climate$year==year,]
  n_days <- list(
    "1"  = 31,
    "2"  = ifelse(leap_year(year), 29, 28),
    "3"  = 31,
    "4"  = 30,
    "5"  = 31,
    "6"  = 30,
    "7"  = 31,
    "8"  = 31,
    "9"  = 30,
    "10" = 31,
    "11" = 30,
    "12" = 31
  )
  Rs_month <- c()
  for (month in climate$month) {
    month_days <- as.numeric(n_days[as.character(month)])
    month_i    <- climate[climate$month==month,]
    Rs         <- respiration_soil(Ta=month_i$temperature, P=month_i$precipitation)
    Rs         <- Rs * month_days
    Rs_month   <- c(Rs_month, Rs)
  }
  Rs_year        <- sum(Rs_month) # * Configuration$field_area
  respiration_df <- data.frame(year=year, r_soil=Rs_year)

  # Calculate soil organic C and N
  c_so   <- soc_depth(order=Configuration$soil_order, depth_cm=100)
  n_so   <- c_so / mean(StoichiometryLUT$cn_soil, na.rm=TRUE)
  som_df <- data.frame(year=year, c_so=c_so, n_so=n_so)

  # Sort trees by descending height; vectorized
  if (Verbose) {
    message("Sorting...")
  }
  Trees <- Trees[order(Trees$height, decreasing=TRUE), ]

  # Calculate cumulative crown area; vectorized
  if (Verbose) {
    message("Calculating culumative crown area...")
  }
  if (CohortMode) {
    Trees$crown_a_cumsum <- cumsum(Trees$crown_a * Trees$n_trees)
  } else {
    Trees$crown_a_cumsum <- cumsum(Trees$crown_a)
  }

  # Calculate z* and closest cohort; vectorized
  if (Verbose) {
    message("Calculating Z*...")
  }
  index    <- which.min(abs(Trees$crown_a_cumsum - Configuration$field_area))
  zstar_df <- Trees[index,]
  if (Verbose) {
    message(paste("Z* height:", zstar_df$height))
  }

  # Dataframe placeholders
  mortality_df <- data.frame(matrix(ncol=nrow(Trees), nrow=0))
  colnames(mortality_df) <- colnames(Trees)
  regeneration_df <- data.frame(matrix(ncol=nrow(Trees), nrow=0))
  colnames(regeneration_df) <- colnames(Trees)

  # Loop over each species
  for (species in unique(Trees$species)) {

    # Skip species not found in lookup tables
    if (!species %in% GrowthLUT$species) {
      next
    }

    # Species index
    s <- Trees$species==species

    # Regeneration; species
    if (Verbose) {
      message("Applying regeneration...")
    }
    n_replicates <- length(which(s))
    index <- RegenerationLUT$species==species
    n_saplings <- RegenerationLUT[index,]$mean
    # new sapling used in regeneration
    new_sapling <- data.frame(species=species, type="sapling", age=0, dbh=1,
      height=2, crown_r=0.1, crown_l=0.845, crown_a=0.0314, ba=0.00008,
      crown_a_cumsum=NA, biomass_ag=NA, biomass_stem=NA, biomass_branch=NA,
      biomass_leaf=NA, biomass_root_coarse=NA, biomass_root_fine=NA,
      biomass_soil=NA, biomass_bg=NA, biomass_total=NA, c_ag=NA, c_bg=NA,
      c_total=NA, anpp=NA, n_ag=NA, n_bg=NA, n_total=NA, annp=NA, year=year)
    if (CohortMode & n_replicates > 0) {
      new_sapling$id <- id_holder
      new_sapling$n_trees <- n_saplings
      Trees <- rbind(Trees, new_sapling)
      regeneration_df <- rbind(regeneration_df, new_sapling)
      id_holder <- id_holder + 1 #+ n_replicates
    } else if (n_replicates > 0){
      n_trees <- nrow(trees)
      new_saplings <- do.call(rbind, replicate(n_replicates * n_saplings, new_sapling, simplify=FALSE))
      new_saplings$id <- id_holder:(id_holder + (n_replicates * n_saplings) - 1)
      Trees <- rbind(Trees, new_saplings)
      regeneration_df <- rbind(regeneration_df, new_saplings)
      id_holder <- id_holder + (n_replicates * n_saplings)
    }

    # Recalculate species index after regeneration
    s <- Trees$species==species

    # Loop over each type within each species
    for (type in unique(Trees[s,]$type)) {

      # Species and type index
      st <- Trees$species==species & Trees$type==type

      # Mortality; species & type
      if (Verbose) {
        message("Applying mortality...")
      }
      index <- MortalityLUT$species==species & MortalityLUT$type==type
      mortality <- MortalityLUT[index,]
      random_uniform <- runif(1, min=0, max=1)
      if (random_uniform < mortality$probability) {
        kill_fraction <- runif(1, min=0, max=1) # random uniform
        if (CohortMode) {
          kill_n <- round(nrow(Trees[st,]) * kill_fraction)
          if (kill_n > 0) {
            # Kill fraction of cohorts
            kill_index <- sample(which(st), kill_n, replace=FALSE)
            mortality_df <- rbind(mortality_df,  Trees[kill_index,])
            Trees <- Trees[-kill_index,] # kill trees
            # Optional: kill fraction within cohorts and then remove dead cohorts
            #Trees[st,]$n_trees <- Trees[st,]$n_trees - kill_n # kill trees
            #mortality_df <- cbind(data.frame(year=year), Trees[st,])
            #mortality_df$n_trees <- round(mortality_df$n_trees * kill_fraction)
          }
          #dead_cohorts <- Trees$n_trees < 1 | is.na(Trees$n_trees) | is.na(Trees$dbh)
          #if(any(dead_cohorts)) {
          #  Trees <- Trees[-which(dead_cohorts),] # remove dead trees/cohorts
          #  message("Removal")
          #  stopifnot(!anyNA(Trees[st,]$dbh) | !anyNA(Trees[st,]$n_trees)) # "PIAB" "sapling"
          #}
        } else {
          kill_n <- round(nrow(Trees[st,]) * kill_fraction)
          if (kill_n > 0) {
            kill_index <- sample(which(st), kill_n, replace=FALSE)
            mortality_df <- rbind(mortality_df, Trees[kill_index,])
            Trees <- Trees[-kill_index,] # kill trees
          }
        }
      }

      # Recalculate species and type index after mortality
      st <- Trees$species==species & Trees$type==type

      # Skip ahead if species or type is all dead
      if (nrow(Trees[st,]) < 1) {
        next
      }

      # Growth; species & type
      index <- GrowthLUT$species==species & GrowthLUT$type==type
      growth <- GrowthLUT[index,]
      if (type=="adult") {
        Trees[st,]$dbh <- ifelse(Trees[st,]$crown_a_cumsum < Configuration$field_area,
                                 Trees[st,]$dbh + growth$mean,
                                 Trees[st,]$dbh + growth$mean * UnderstoryAdult)
      } else if (type=="sapling") {
        Trees[st,]$dbh <- Trees[st,]$dbh + growth$mean * UnderstorySapling
      } else {
        message("Error: Type not recognized")
      }

      # Allometry; species & type
      if (Verbose) {
        message("Calculating allometry...")
      }
      index <- AllometryLUT$species==species & AllometryLUT$type==type
      allometry <- AllometryLUT[index,]
      Trees[st,]$height  <- 1.35 + (30-1.35) * (1-exp(-(allometry$h_coeff * Trees[st,]$dbh)))
      Trees[st,]$height  <- ifelse(Trees[st,]$height > 30, 30, Trees[st,]$height) # limit height to 30m
      Trees[st,]$type    <- ifelse(Trees[st,]$dbh > 10, "adult", "sapling")
      Trees[st,]$crown_l <- allometry$cd  * Trees[st,]$dbh
      Trees[st,]$crown_r <- allometry$cr1 * Trees[st,]$dbh^allometry$cr2
      Trees[st,]$crown_a <- Trees[st,]$crown_r^2 * pi
      Trees[st,]$ba      <- Trees[st,]$dbh^2 * 0.00007854 # forester's constant for DBH (cm); m2
    } # end type loop

    # Calculate species index after regeneration and mortality
    s <- Trees$species==species

    # Skip ahead if species is all dead
    if (nrow(Trees[s,]) < 1) {
      next
    }

    # Biomass expansion factors and allocation or partitioning; species
    # DBH to AGB and AGB to BGB (Chojnacky, Heath, Jenkins, 2014)
    # To add...? BGB to leaf and steam (Enquist and Niklas, 2002)
    if (Verbose) {
      message("Calculating biomass...")
    }
    index <- BiomassLUT$species==species
    biomass <- BiomassLUT[index,]
    if (CohortMode) {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh)) * Trees[s,]$n_trees
    } else {
      Trees[s,]$biomass_ag <- exp(biomass$b0 + biomass$b1 * log(Trees[s,]$dbh))
    }
    Trees[s,]$biomass_stem        <- Trees[s,]$biomass_ag * biomass$fraction_stem
    Trees[s,]$biomass_branch      <- Trees[s,]$biomass_ag * biomass$fraction_branch
    Trees[s,]$biomass_leaf        <- Trees[s,]$biomass_ag * biomass$fraction_leaf
    Trees[s,]$biomass_root_coarse <- Trees[s,]$biomass_ag * exp(-1.4485 - 0.03476 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_root_fine   <- Trees[s,]$biomass_ag * exp(-1.8629 - 0.77534 * log(Trees[s,]$dbh))
    Trees[s,]$biomass_soil        <- Trees[s,]$biomass_ag * biomass$fraction_soil
    Trees[s,]$biomass_bg          <- Trees[s,]$biomass_root_coarse + Trees[s,]$biomass_root_fine +
                                     Trees[s,]$biomass_soil
    Trees[s,]$biomass_total       <- Trees[s,]$biomass_ag + Trees[s,]$biomass_bg

    # Year naught total C and N for ANPP and ANNP calculations
    c_total_previous <- Trees[s,]$c_total
    n_total_previous <- Trees[s,]$n_total

    # C fraction; species
    if (Verbose) {
      message("Calculating C fraction...")
    }
    #index <- CarbonLUT$species==species
    carbon <- CarbonLUT #[index,]
    Trees[s,]$c_ag <- Trees[s,]$biomass_ag *
      (biomass$fraction_stem   * carbon$fraction_stem) +
      (biomass$fraction_branch * carbon$fraction_branch) +
      (biomass$fraction_leaf   * carbon$fraction_leaf)
    Trees[s,]$c_bg <- Trees[s,]$biomass_ag *
      (biomass$fraction_root * carbon$fraction_root) +
      (biomass$fraction_soil * carbon$fraction_soil)
    Trees[s,]$c_total <- Trees[s,]$c_ag + Trees[s,]$c_bg
    if (year > min(Years)) {
      Trees[s,]$anpp <- Trees[s,]$c_total - c_total_previous
    }
    # C:N stoichiometry; species
    if (Verbose) {
      message("Calculating N fraction...")
    }
    index <- StoichiometryLUT$species==species
    stoichiometry <- StoichiometryLUT[index,]
    Trees[s,]$n_ag <- Trees[s,]$c_ag /
      (biomass$fraction_stem   * stoichiometry$cn_stem)   +
      (biomass$fraction_branch * stoichiometry$cn_branch) +
      (biomass$fraction_leaf   * stoichiometry$cn_leaf)
    Trees[s,]$n_bg <- Trees[s,]$c_bg /
      (biomass$fraction_root * stoichiometry$cn_root) +
      (biomass$fraction_soil * stoichiometry$cn_soil)
    Trees[s,]$n_total <- Trees[s,]$n_ag + Trees[s,]$n_bg
    if (year > min(Years)) {
      Trees[s,]$annp <- Trees[s,]$n_total - n_total_previous
    }
  } # end species loop

  # Fix order of regeneration_df columns
  regeneration_df <- regeneration_df[,colnames(Trees)]

  # Calculate NEE and add to fluxes; NEE calculation based on Equation 1 in:
  #   Clark et al. (2001) Measuring Net Primary Production in Forests: Concepts and Field Methods,
  #   Ecological Applications, 11(2), pp. 356-370.
  # and
  #   Reichstein et al. (2005) On the separation of net ecosystem exchange into assimilation and
  #   ecosystem respiration: review and improved algorithm, Global Change Biology, 11, pp. 1424–1439.
  # Convert C to CO2 in ANPP
  fluxes_df <- data.frame(
    year   = year,
    nee    = (respiration_df$r_soil * Configuration$field_area) - sum(Trees$anpp, na.rm=TRUE),
    r_soil = (respiration_df$r_soil * Configuration$field_area)
  )

  # Save annual tree/cohort results
  write.csv(Trees, file=paste0("outputs/trees_", year, ".csv"), row.names=FALSE,
    fileEncoding="UTF-8")

  # Append results to CSV
  header_boolean <- year == Years[1]

  suppressWarnings(write.table(som_df, file="outputs/som.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  suppressWarnings(write.table(fluxes_df, file="outputs/fluxes.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  suppressWarnings(write.table(zstar_df, file="outputs/zstar.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  suppressWarnings(write.table(regeneration_df, file="outputs/regeneration.csv",
    append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  # Mortality is non-deterministic
  if (nrow(mortality_df) > 0 | header_boolean) {
    suppressWarnings(write.table(mortality_df, file="outputs/mortality.csv",
      append=TRUE, col.names=header_boolean, row.names=FALSE, sep=",", fileEncoding="UTF-8"))
  }

  # Calculate loop time
  loop_time <- proc.time() - loop_start_time
  loop_time <- as.numeric(loop_time["elapsed"])
  message(paste(paste0("Year: ", year, ","), "Duration (sec):", round(loop_time, 2)))
  loop_times <- c(loop_times, loop_time)
} # end year loop

# Calculate total time
total_time <- proc.time() - start_time
total_time <- as.numeric(total_time["elapsed"])
message("=========================================================================")
message("Simulation complete")
message(paste("Years:", length(Years)))
message(paste("Duration (sec):", round(total_time, 2)))
message("=========================================================================")

# Export loop times to CSV
loop_times_df <- data.frame(year=Years, time=loop_times)
write.table(loop_times_df, file="outputs/loop_times.csv", col.names=TRUE,
  row.names=FALSE, sep=",", fileEncoding="UTF-8")

# End #


# Use this script to assemble statistics for:
#   1. raw
#   2. stepwise f0, f1, f2
#   3. intensity features
#
# all extracted from the IDS dataset using PraatMasterScript.praat for further analysis
# Script written by Courtney Hilton & Cody Moser

# libraries ---------------------------------------------------------------

library(tidyverse)
library(here)

# load data ---------------------------------------------------------------

data <- read_csv(here("data", "Praat_MasterData.csv"))
mirrri <- read_csv(here("data", "mir_roughness_rolloff_inharm"))
mirras <- read_csv(here("data", "mir_reconcatenated_attack_summary"))
mirtp <- read_csv(here("data", "mir_tempo_pulseclarity"))
npvi <- read_csv(here("data", "npvi_summary"))
tm <- read_csv(here("data", "tm_summary"))

# Processing --------------------------------------------------------------

data <- data %>%
   group_by(id) %>%
   mutate(
      # Calculate stepwise euclidian travel distance for intensity
      praat_intensitytravel = sqrt((intensity - lag(intensity))^2),
      # Calculate stepwise euclidian travel distance for intensity
      praat_f0travel = sqrt((f0 - lag(f0))^2),
      # Calculate stepwise euclidian travel distance for vowel space
      praat_voweltravel = sqrt((sqrt(f1^2 + f2^2) - lag(sqrt(f1^2 + f2^2)))^2),
      # Change 0 to NA
      across(c(f0,f1,f2, intensity), ~ ifelse(.x == 0, NA, .x)),
      # remove extra bit on ID var
      id = str_sub(id, 1,6)
      )

# set column names for reference
colnames(data) <- c(
  "id",
  "time",
  "praat_f0",
  "praat_f1",
  "praat_f2",
  "praat_intensity",
  "praat_intensity_travel",
  "praat_f0_travel",
  "praat_vowel_travel"
)

# Caclulate summary data --------------------------------------------------

summarydata <- data %>%
  group_by(id) %>%
  summarize(
    praat_f0_mean = mean(praat_f0, na.rm = TRUE),
    praat_f0_median = median(praat_f0, na.rm = TRUE),
    praat_f0_std = sd(praat_f0, na.rm = TRUE),
    praat_f0_min = min(praat_f0, na.rm = TRUE),
    praat_f0_max = max(praat_f0, na.rm = TRUE),
    praat_f0_first_quart = quantile(praat_f0, probs = 0.25, na.rm = TRUE),
    praat_f0_third_quart = quantile(praat_f0, probs = 0.75, na.rm = TRUE),
    praat_f0_IQR = IQR(praat_f0, na.rm = TRUE),
    praat_f1_mean = mean(praat_f1, na.rm = TRUE),
    praat_f1_median = median(praat_f1, na.rm = TRUE),
    praat_f1_std = sd(praat_f1, na.rm = TRUE),
    praat_f1_min = min(praat_f1, na.rm = TRUE),
    praat_f1_max = max(praat_f1, na.rm = TRUE),
    praat_f1_first_quart = quantile(praat_f1, probs = 0.25, na.rm = TRUE),
    praat_f1_third_quart = quantile(praat_f1, probs = 0.75, na.rm = TRUE),
    praat_f1_IQR = IQR(praat_f1, na.rm = TRUE), praat_f2_mean = mean(praat_f2, na.rm = TRUE),
    praat_f2_median = median(praat_f2, na.rm = TRUE),
    praat_f2_std = sd(praat_f2, na.rm = TRUE),
    praat_f2_min = min(praat_f2, na.rm = TRUE),
    praat_f2_max = max(praat_f2, na.rm = TRUE),
    praat_f2_first_quart = quantile(praat_f2, probs = 0.25, na.rm = TRUE),
    praat_f2_third_quart = quantile(praat_f2, probs = 0.75, na.rm = TRUE),
    praat_f2_IQR = IQR(praat_f2, na.rm = TRUE),
    praat_intensity_mean = mean(praat_intensity, na.rm = TRUE),
    praat_intensity_median = median(praat_intensity, na.rm = TRUE),
    praat_intensity_std = sd(praat_intensity, na.rm = TRUE),
    praat_intensity_min = min(praat_intensity, na.rm = TRUE),
    praat_intensity_max = max(praat_intensity, na.rm = TRUE),
    praat_intensity_first_quart = quantile(praat_intensity, probs = 0.25, na.rm = TRUE),
    praat_intensity_third_quart = quantile(praat_intensity, probs = 0.75, na.rm = TRUE),
    praat_intensity_IQR = IQR(praat_intensity, na.rm = TRUE),
    praat_intensitytravel_mean = mean(praat_intensity_travel, na.rm = TRUE),
    praat_intensitytravel_median = median(praat_intensity_travel, na.rm = TRUE),
    praat_intensitytravel_std = sd(praat_intensity_travel, na.rm = TRUE),
    praat_intensitytravel_min = min(praat_intensity_travel, na.rm = TRUE),
    praat_intensitytravel_max = max(praat_intensity_travel, na.rm = TRUE),
    praat_intensitytravel_first_quart = quantile(praat_intensity_travel, probs = 0.25, na.rm = TRUE),
    praat_intensitytravel_third_quart = quantile(praat_intensity_travel, probs = 0.75, na.rm = TRUE),
    praat_intensitytravel_IQR = IQR(praat_intensity_travel, na.rm = TRUE),
    praat_voweltravel_mean = mean(praat_vowel_travel, na.rm = TRUE),
    praat_voweltravel_median = median(praat_vowel_travel, na.rm = TRUE),
    praat_voweltravel_std = sd(praat_vowel_travel, na.rm = TRUE),
    praat_voweltravel_min = min(praat_vowel_travel, na.rm = TRUE),
    praat_voweltravel_max = max(praat_vowel_travel, na.rm = TRUE),
    praat_voweltravel_first_quart = quantile(praat_vowel_travel, probs = 0.25, na.rm = TRUE),
    praat_voweltravel_third_quart = quantile(praat_vowel_travel, probs = 0.75, na.rm = TRUE),
    praat_voweltravel_IQR = IQR(praat_vowel_travel, na.rm = TRUE),
    praat_f0travel_mean = mean(praat_f0_travel, na.rm = TRUE),
    praat_f0travel_median = median(praat_f0_travel, na.rm = TRUE),
    praat_f0travel_std = sd(praat_f0_travel, na.rm = TRUE),
    praat_f0travel_min = min(praat_f0_travel, na.rm = TRUE),
    praat_f0travel_max = max(praat_f0_travel, na.rm = TRUE),
    praat_f0travel_first_quart = quantile(praat_f0_travel, probs = 0.25, na.rm = TRUE),
    praat_f0travel_third_quart = quantile(praat_f0_travel, probs = 0.75, na.rm = TRUE),
    praat_f0travel_IQR = IQR(praat_f0_travel, na.rm = TRUE),
    praat_f0_range = praat_f0_max - praat_f0_min,
    praat_f1_range = praat_f1_max - praat_f1_min,
    praat_f2_range = praat_f2_max - praat_f2_min,
    praat_intensity_range = praat_intensity_max - praat_intensity_min,
    praat_intensitytravel_range = praat_intensitytravel_max - praat_intensitytravel_min,
    praat_voweltravel_range = praat_voweltravel_max - praat_voweltravel_min,
    praat_f0travel_range = praat_f0travel_max - praat_f0travel_min,
    praat_f0travel_rate_median = median(praat_f0_travel / time, na.rm = TRUE),
    praat_f0travel_rate_IQR = IQR(praat_f0_travel / time, na.rm = TRUE),
    praat_voweltravel_rate_median = median(praat_vowel_travel / time, na.rm = TRUE),
    praat_voweltravel_rate_IQR = IQR(praat_vowel_travel / time, na.rm = TRUE),
    praat_intensitytravel_rate_median = median(praat_intensity_travel / time, na.rm = TRUE),
    praat_intensitytravel_rate_IQR = IQR(praat_intensity_travel / time, na.rm = TRUE),
    # sum file length, f0, vowel space, and intensity for gross travel rates
    timesum = sum(time),
    f0sum = sum(praat_f0_travel, na.rm = TRUE),
    vowelsum = sum(praat_vowel_travel, na.rm = TRUE),
    intensitysum = sum(praat_intensity_travel, na.rm = TRUE),
    # calculate gross travel rates
    praat_f0_travel_rate_default = (f0sum / timesum),
    praat_voweltravel_rate_default = (vowelsum / timesum),
    praat_intensitytravel_rate_default = (intensitysum / timesum)
  ) %>%
   ungroup() %>%
   # Remove unnecessary variables (minimums and sums)
   select(-c(
      praat_voweltravel_min,
      praat_intensitytravel_min,
      praat_f0travel_min,
      timesum,
      f0sum,
      vowelsum,
      intensitysum
   ))

# Add song info to files --------------------------------------------------

summarydata <- summarydata %>%
  transmute(
    id = id,
    voc_type = substr(id,6,6),
    song = case_when(
      endsWith(id, "A")  ~ 1 ,
      endsWith(id, "B")  ~ 0 ,
      endsWith(id, "C")  ~ 1 ,
      endsWith(id, "D")  ~ 0 ,
      ),
    infdir = case_when(
      endsWith(id, "A")  ~ 1 ,
      endsWith(id, "B")  ~ 1 ,
      endsWith(id, "C")  ~ 0 ,
      endsWith(id, "D")  ~ 0 ,
      ),
    id_site = substr(id,1,3),
    id_person = substr(id,1,5),
    ) %>%
  merge(summarydata, by = "id")

# Combine summary statistics from Praat with additional files -------------

df_list <- list(summarydata, mirrri, mirras, mirtp, npvi, tm)
summarydata %>% reduce(full_join, by='id')

# Save output -------------------------------------------------------------

write_csv(summarydata, here("results", "praatsummary.csv"))


# IDEAL POINTS ---

sel.trunc <- function(i){
        if (!is.na(north) & i==north){
            draw ~ dnorm(x.mean[i], x.tau[i])T(,0)

                               for(i 1:n.members)){
     theta[i] ~ sel.trunc (x.mean[i], x.tau[i]); # auto-regressive process
}

        setdiff(1:9, c(NA,NA))

            theta[north] ~ ifelse (is.na(north)==FALSE, dnorm(x.mean[north], x.tau[north])T(0,) # normal + truncada
    ifelse (is.na(south)==FALSE) theta[south] ~ dnorm(x.mean[south], x.tau[south])T(,0) # normal - truncada


guess_if_intercept = function(x){
	x = as.data.frame(x)
	is_intercept = rep(F,ncol(x))
	for(i in 1:ncol(x)){
		vals = sort(unique(x[,i]))
		if(length(vals)==1){
			if(vals==1){
				is_intercept[i] = T
			}
		}else{
			if(length(vals)==2){
				if(all(vals==c(0,1))){
					is_intercept[i] = T
				}
			}
		}
	}
	return(is_intercept)
}