#' Creates phylogenetic tree and generates a single trait for each species.
#'
#' @param b Birth rate.
#' @param d Death rate.
#' @param n_taxa A number of species in the tree.
#' @param model A model, under which trait should be generated ("BM" or "OU").
#' @param sigma A standard-deviation of the random component for each branch.
#' @param alpha A strength of the selective constraint for each branch in OU model.
#'
#' @return List consisting of phylogenetic tree, matrix of phylogenetic distances, trait and matrix of trait distances.
#' @export
#'
#' @examples
#' sim_tree_n_traits(b = 0.1, d = 0, n_taxa = 500, model = "BM", sigma = 0.1, alpha = 0.1)

sim_tree_n_traits <- function(b = 0.1, d = 0, n_taxa = 500, model = "BM", sigma = 0.1, alpha = 0.1){
  tree <- geiger::sim.bdtree(b = b, d = d, stop = "taxa", n = n_taxa)
  dist.phy <- cophenetic(tree)
  colnames(dist.phy) <- rownames(dist.phy) <- 1:n_taxa

  tr <- ape::rTraitCont(tree, model = model, sigma = sigma, alpha = alpha)
  trait <- (tr - min(tr)) / (max(tr) - min(tr)) * 100
  names(trait) <- 1:length(trait)
  tr.dist <- as.matrix(dist(trait))

  res <- list(phylo = tree, phylo_dist = dist.phy, trait = trait, trait_dist = tr.dist)

  return(res)
}


#' wbdt
#'
#' Given t air temperature (Celsius), rh relative humidity (percentage)  gives  Wet-bulb dry temperature (WBDT).
#'
#' @param t    numeric Air temperature in degC.
#' @param rh   numeric Relative humidity in percentage.
#' @param pair numeric Mean Wind speed in meters per second.
#' @return Wet-bulb dry temperature in degC.
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  WBDT
#'
#' @export
#'
#'
#'
#'

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


install.packages("tidyverse")
library(readr)
library(stringr)
library(tidyr)
library(dplyr)
library(jsonlite)

# Diversify your bonds, anchor your REGEX
has_required <- function(entry) {
  return (
        str_detect(entry["byr"],"^\\d{4}$") &
        as.numeric(entry["byr"]) >= 1920 &
        as.numeric(entry["byr"]) <= 2002 &
        str_detect(entry['iyr'], "\\d{4}") &
        as.numeric(entry["iyr"]) >= 2010 &
        as.numeric(entry["iyr"]) <= 2020 &
        str_detect(entry["eyr"], "\\d{4}") &
        as.numeric(entry["eyr"]) >= 2020 &
        as.numeric(entry["eyr"]) <= 2030 &
        str_detect(entry["hgt"], "(\\d{3}cm)|(\\d{2}in)") &
        str_detect(entry["hcl"], "^#[0-9|a-f]{6}$") &
        str_detect(entry["ecl"],"^(amb|blu|brn|grn|gry|hzl|oth)$") &
        str_detect(entry["pid"], "^\\d{9}$")
      )
}

data <- read_file("input.txt") %>%
  str_replace_all("\r\n\r\n", "\"},{\"") %>%
  str_replace_all("\r\n","\",\"") %>%
  str_replace_all(" ","\",\"") %>%
  str_replace_all(":","\":\"")

data <- str_c("[{\"",data, "\"}]") %>%
  fromJSON()

# Part 1
data <- data %>%
  drop_na(byr) %>%
  drop_na(iyr) %>%
  drop_na(eyr) %>%
  drop_na(hgt) %>%
  drop_na(hcl) %>%
  drop_na(ecl) %>%
  drop_na(pid)

# Part 2
valid <- NULL
for(i in 1:nrow(data)) {
  entry <- data[i,]
  if(has_required(entry)) {
    if(str_detect(entry["hgt"], "\\d{3}cm")) {
      hgt <- as.numeric(str_sub(entry["hgt"],1,3))
      if(hgt >= 150 & hgt <= 193) {
        valid <- rbind(valid, entry)
      }
    }
    if(str_detect(entry["hgt"], "\\d{2}in")) {
      hgt <- as.numeric(str_sub(entry["hgt"],1,2))
      if(hgt >= 59 & hgt <= 76) {
        valid <- rbind(valid, entry)
      }
    }
  }
}


  green.red <- function (n) {
    # the default colour scheme ... note additional ones can be passed .. check the main prg
    colour = NA
    n = n-2
    if ((n <- as.integer(n[1])) > 0) {
      even.n <- n%%2 == 0
      green = 2/6
      red = 0
      blue = 4/6
      k <- n%/%2
      l1 <- k + 1 - even.n
      l2 <- n - k + even.n
      colour = c(
          if (l1 > 0) { hsv( h=green, s=seq(1, ifelse(even.n, 1/k, 0), length=l1), v=1) },
          if (l2 > 1) { hsv( h=red, s=seq(0, 1, length=l2), v=1) }
      )
    }
    return( colour )
  }


library(arules)
library(arulesViz)

TR <- read.transactions("LEBENSMITTEL_TR.CSV", sep = ",")
TR
summary(TR)

itemFrequencyPlot(TR, topN = 15, type = "absolute")
#image(TR)

RULES <- apriori(TR,
	parameter = list(
		supp = 0.001,
		conf = 0.5,
		target = "rules"))
RULES

inspect(sort(RULES, by = "lift"))
plot(RULES, method = "graph")

inspect(subset(RULES, subset = lhs %ain% as.vector(c("ROLLS.BUNS", "SODA"))))


# "SHAP  for Mid to higher severity"

# setting
```{r}

########################## Data setting
### Setting
rm(list=ls(all=TRUE))

library(data.table)
library(dplyr)
library(ggplot2)
library(car)
library(psych)
library(pROC)
library(epitools)
library(tableone)
library(caret)
library(tictoc)
library(Boruta)

library("DALEX")
library("iBreakDown")
library("r2d3")
library("data.table")
library("dplyr")
library("ggplot2")

library(doParallel)
detectCores(all.tests = FALSE, logical = TRUE)
cl <- makePSOCKcluster(27)
registerDoParallel(cl)

set.seed(1234)

######################### Input data
Data <- fread("Data_demo.csv", encoding = "UTF-8" )
Data$V1 <- NULL

Data_train <- Data[TrainTest == "Train", , ] #*eligible
Data_train <- data.frame(Data_train)

Data_test <- Data[TrainTest == "Test", , ] #*eligible
#Data_test <- data.frame(Data_test)

###########################
###########################
###########################

Model <- readRDS("gamSpline_temp.rds")
Model[5]
Model[6]

Select_predictor <- Model[6]
Select_predictor <- c("LogPopulation100000", Select_predictor$optVariables)
Select_predictor

### object for SHAP
library(gam)

explain_Model <- explain(Model,
                           data = Data_train[, Select_predictor],
                           y = Data_train$SeverityHigherMid,
                           label = "gam"
						   )

Obs <- Data_train$SeverityHigherMid
Pred <- explain_Model$y_hat

RMSE <- function(Obs, Pred){
	Dif <- Pred - Obs
	RMSE <- round(sqrt(mean(Dif**2)), 6)
	return(RMSE)
}

RMSE(Obs, Pred)

### loop

stopCluster(cl)
cl <- makePSOCKcluster(27)
registerDoParallel(cl)

tic()

Hoge <- c()

Select_row <- sample(1:nrow(Data_train), size = 3000)

Hoge <- foreach(iii = Select_row, .combine = "rbind") %do%{

SHAP_model <- shap(explain_Model, Data_train[iii, ], B = 5)

Kari <- SHAP_model %>% data.table()
Kari[, ID := iii, ]
Kari

}

toc()
stopCluster(cl)

fwrite(Hoge, "SHAP_all.csv")

###
Hoge <- fread("SHAP_all.csv")

SHAP_data <- Hoge %>%
	group_by(ID, variable_name) %>%
	summarize(
		Variable_value = first(variable_value),
		Contribution = mean(contribution)
		) %>%
	data.table() %>%
	print()

SHAP_data[, Contribution := as.numeric(Contribution), ]
SHAP_data[, Variable_value := as.numeric(Variable_value), ]

SHAP_data[, Variable_value_scale := scale(Variable_value), by = variable_name]

SHAP_data %>%
	group_by(variable_name) %>%
	summarize(
		mean(Variable_value_scale),
		sd(Variable_value_scale),
		)

### plot SHAP
Var <- c(
"temperature", "temperature_past1d_max_diff", "temperature_past1d_mean_diff", "temperature_past1d_min_diff", "DownwardSolarRadiation_kwm2", "relativeHumidity", "precip1Hour", "windSpeed_ms",

"Population_over_65_100000", "Age_median_city", "SexRatioF", "Mean_income_city_2015", "Green_area_percent",

"RainySeason", "DifDateRain", "holiday_flag", "Hour", "Month"
)

#"LogPopulation100000"

SHAP_data[Variable_value_scale > 5, , ]

SHAP_data[Variable_value_scale < -5, , ]

SHAP_data[abs(Contribution) > 20, , ]

SHAP_data[, Variable_value_scale := ifelse(Variable_value_scale > 5, 5, Variable_value_scale), ]

ggplot(data = SHAP_data) +
    coord_flip() +
	ggforce::geom_sina(
	    aes(x = variable_name, y = Contribution, color = Variable_value_scale),
	    method = "counts", size = 3,
		#maxwidth = .7,
		alpha = 3) +
	#scale_color_gradient(low = "lightblue", high = "red") +
	scale_y_continuous(limits = c(-20, 20), breaks = seq(-20, 20, 5)) +
	scale_x_discrete(limits = rev(Var)) +
	scale_color_gradient(low = "#FFCC33", high = "#6600CC") +
	theme_bw()

ggsave("Out_SHAP_sever.png", width = 10, height = 15)

SHAP_data <- SHAP_data[abs(Contribution) <= 20, , ]

fwrite(SHAP_data, "Out_data_figure5_SHAP_gam.csv")


### Instalar nuevas librerías
### install.packages("ggplot2")
### install.packages("ggmap")

library(tidyverse)
library(ggmap)
library(tibble)

register_google (key = "XXXXXXXXXX")

### Ejemplo

Londres <- geocode("London, UK", zoom = 13)
ggmap(get_map(Londres, maptype = "watercolor"))

### Ejemplo

Micasa <- get_map("ArcGeek", maptype = "roadmap", zoom = 15)
ggmap(Micasa)

lat = c(-4.008664, -4, -4.005)
lon = c(-79.210894, -79.22, -79.20)

Tabla = data.frame (cbind(lat,lon))

ggmap(Micasa) +
  geom_point(data = Tabla,
             aes(x = lon, y = lat),
             color = "red",
             size = 3,
             shape = 15) +
  ggtitle("Puntos de muestreo") +
  labs (x = "longitud", y = "latitud")


library(memuse)
suppressMessages(library(fmlr))
set.seed(1234)

m = 1e7
n = 5

cat("pre:\n")
Sys.procmem()

r = matrix(runif(m*n))
cat("\npost alloc:\n")
Sys.procmem()

x = as_cpumat(r, copy=FALSE)
cat("\npost convert:\n")
Sys.procmem()

cp = linalg_crossprod(x)
cat("\npost crossprod:\n")
Sys.procmem()


ucenje = function(podatki, formula, algoritem) {
  switch(
    algoritem,
    lin.reg = lm(formula, data = podatki),
    log.reg = glm(formula, data = podatki, family = "binomial"),
    ng = ranger(formula, data = podatki)
  )
}

napovedi = function(podatki, model, algoritem) {
  switch(
    algoritem,
    lin.reg = predict(model, podatki),
    log.reg = ifelse(
      predict(model, podatki, type = "response") >= 0.5,
      1, -1
    ),
    ng = predict(model, podatki)$predictions
  )
}

napaka_regresije = function(podatki, model, algoritem) {
  podatki %>%
    bind_cols(Rating_Magnusa.hat = napovedi(podatki, model, algoritem)) %>%
    mutate(
      izguba = (Rating_Magnusa - Rating_Magnusa.hat) ^ 2
    ) %>%
    select(izguba) %>%
    unlist() %>%
    mean()
}

izbira_modela <- function(formule, stevilo_polinomov) {
  for (i in 1:stevilo_polinomov){
    formula <- formule[[i]]

  }
}

napaka_regresije1 = function(podatki, model) {
  podatki %>%
    bind_cols(Rating_Magnusa.hat = predict(model, podatki)$predictions) %>%
    mutate(
      izguba = (Rating_Magnusa - Rating_Magnusa.hat) ^ 2
    ) %>%
    select(izguba) %>%
    unlist() %>%
    mean()
}


library(exptest)

co.exp.test(x, simulate.p.value=FALSE, nrepl=2000)


predict.pspline.face <- function(object, argvals.new, ...) {

  # require(splines)
  stopifnot(class(object) == "pspline.face")

  knots <- object$knots
  p <- object$p
  B <- spline.des(knots = knots, x = argvals.new, ord = p + 1, outer.ok = TRUE, sparse = TRUE)$design
  return(as.vector(B %*% object$theta))
}


#
# Linear regression predictor with infinite memory
#
lsPredictor <- function() {
    xVals <- c()
    yVals <- c()
    learnClosed <- FALSE
    r <- NULL

    learn <- function(x, y) {
        xVals <<- append(xVals, x)
        yVals <<- append(yVals, y)
    }

    predict <- function(x) {
        if(!learnClosed) {
            learnClosed <<- TRUE
            r <<- lm(yVals ~ xVals)
        }
        return(r$coefficients[[2]]*x + r$coefficients[[1]])
    }

    return(list(predict=predict, learn=learn))
}


#' @export
#'
#' @title coef.eoar - Coefficient extractor for EoAR models.
#'
#' @description Extracts the log-linear model coefficients from an
#' \code{eoar} model object.  See \code{\link{eoar}}.
#'
#' @param obj An object of class \code{eoar}.
#'
#' @return Estimates of the log-linear model's coefficients.
#'
#' @author Trent McDonald
#'
#' @seealso \code{\link{eoar}}, \code{\link{labels.eoar}}
#'
#' @examples
#' # A 3 year study of 7 sites. 21 "cells". lambda change = 20/year
#' set.seed(9430834) # fixes Y and g of this example, but not the RNG's used in chains
#' ns <- 3
#'
#' ny <- 7
#' g <- data.frame(
#'  alpha = rnorm(ns*ny,70,2),
#'  beta = rnorm(ns*ny,700,25)
#' )
#' Y <- rbinom(ns*ny, c(rep(20,ny), rep(40,ny), rep(60,ny)), g$alpha/(g$alpha+g$beta))
#'
#' df <- data.frame(year=factor(c(rep("2015",ny),rep("2016",ny),rep("2017",ny))),
#'    Year=c(rep(1,ny),rep(2,ny),rep(3,ny)))
#'
#' # Uninformed eoar (use low number of iterations because it's and example)
#' eoar.1 <- eoar(Y~year, g, df, nburn = 1000, niters= 50*10, nthins = 10 )
#'
#' coef(eoar.1)
coef.eoar <- function(obj){
  obj$estimates[obj$coef.labels,"Estimate"]
}


fit.isoreg <- function(iso, x0)
{
  o = iso$o
  if (is.null(o))
    o = 1:length(x)
  x = iso$x[o]
  y = iso$yf
  ind = cut(x0, breaks = x, labels = FALSE, include.lowest = TRUE)
  min.x <- min(x)
  max.x <- max(x)
  adjusted.knots <- iso$iKnots[c(1, which(iso$yf[iso$iKnots] > 0))]
  fits = sapply(seq(along = x0), function(i) {
    j = ind[i]

    # Handles the case where unseen data is outside range of the training data
    if (is.na(j)) {
      if (x0[i] > max.x) j <- length(x)
      else if (x0[i] < min.x) j <- 1
    }

    # Find the upper and lower parts of the step
    upper.step.n <- min(which(adjusted.knots > j))
    upper.step <- adjusted.knots[upper.step.n]
    lower.step <- ifelse(upper.step.n==1, 1, adjusted.knots[upper.step.n -1] )

    # Perform a liner interpolation between the start and end of the step
    denom <- x[upper.step] - x[lower.step]
    denom <- ifelse(denom == 0, 1, denom)
    val <- y[lower.step] + (y[upper.step] - y[lower.step]) * (x0[i] - x[lower.step]) / (denom)

    # Ensure we bound the probabilities to [0, 1]
    val <- ifelse(val > 1, max.x, val)
    val <- ifelse(val < 0, min.x, val)
    val <- ifelse(is.na(val), max.x, val) # Bit of a hack, NA when at right extreme of distribution
    val
  })
  fits
}


library(tidyverse)
library(WDI)
library(data.table)
library(countrycode)
library(zoo)
library(scales)
library(ggforce)
library(viridisLite)
library(rnaturalearth)
library(rnaturalearthdata)
library(sf)
library(cowplot)
# library(RcppRoll)
# install.packages('roll')
library(roll)
library(gganimate)
library(gifski)
library(readxl)
library(sf)
library(RColorBrewer)
library(gridExtra)
library(fpc)
library(dbscan)
library(factoextra)
library(ggrepel)

setwd("~/Public_Policy/Projects/COVID-19")

# population_by_state = filter(annual_population_by_state, date == max(date))
population_by_state = read_csv('data/state_pop_2018.csv', skip = 1) %>%
  rename(
    state_name = `Geographic Area Name`,
    value = `Estimate!!Total`
  )

us_population = sum(population_by_state$value)

state_stringency = read_csv("https://raw.githubusercontent.com/OxCGRT/USA-covid-policy/master/data/OxCGRT_US_latest.csv") %>%
  mutate(
    date = as.Date(Date %>% as.character(), format = '%Y%m%d')
  )

state_name_mappings = tibble(state_name = state.name, state_abbr = state.abb)

us_states_covid_data = read_csv('http://covidtracking.com/api/states/daily.csv') %>%
  mutate(
    date = as.Date(as.character(date), format = '%Y%m%d'),
    location_type = 'US State',
    data_source = 'covidtracking.com',
    location_key = paste(state, location_type, data_source, sep = '|')
  ) %>%
  arrange(location_key, date) %>%
  rename(
    total_cases = positive,
    total_deaths = death,
    total_tests = total,
    location = state
  ) %>%
  mutate(
    percent_positive_cases = total_cases / (total_cases + negative),
    tests_with_results = negative + total_cases,
    case_fatality_rate = total_deaths / total_cases
  ) %>%
  left_join(
    state_name_mappings, by = c('location' = 'state_abbr')
  ) %>%
  left_join(
    select(population_by_state, state_name, state_pop = value)
  ) %>%
  left_join(
    state_stringency, by = c('state_name' = 'RegionName', 'date' = 'date')
  )

# get ranks of stringency based on either case 100/1000 date

dim(us_states_covid_data)
dim(us_states_covid_data)

names(state_stringency)
state_stringency$RegionName %>% table()
?month
?day
ggplot(state_stringency, aes(lubridate::day(date), StringencyIndex, group = RegionName)) +
  theme_bw() +
  facet_wrap(~month(date)) +
  geom_step(colour = 'gray')
  # geom_hline(aes(yintercept = mean(StringencyIndex, na.rm = T)), colour = 'red')

  # geom_step(data = filter(state_stringency, RegionName %in% c('Florida', 'Arizona', 'Texas', 'South Dakota')), aes(colour = RegionName), size = 1.25)


require(ggplot2)
require(reshape2)

source('fmm_multivariate_generative.r')

dimension = 2

config = list(
    k = 4
  , l = rep(0, dimension)
  , r = diag(0.05, dimension)
  , b = dimension
  , w = diag(1, dimension)
  , n = 10000
  )

set.seed(42)

d = model(
    config$k, config$l, config$r
  , config$b, config$w, config$n
  )

framed = lapply(d, function(mat) { data.frame(x = mat[,1], y = mat[,2]) })
melted = melt(framed, id.vars = c('x', 'y'))

p = ggplot(melted, aes(x, y, colour = factor(L1))) + geom_point(alpha = 0.2)


\name{only_A_estimate}
\alias{only_A_estimate}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Estimating the attachment function in isolation by PAFit method
}
\description{
This function estimates the attachment function \eqn{A_k} by PAFit method. The method has a hyper-parameter \eqn{r}. It first performs a cross-validation step to select the optimal parameter \eqn{r} for the regularization of \eqn{A_k}, then uses that \eqn{r} to estimate the attachment function with the full data.
}
\usage{
only_A_estimate(net_object                             ,
                net_stat   = get_statistics(net_object),
                p          = 0.75                      ,
                stop_cond  = 10^-8                     ,
                mode_reg_A = 0                         ,
                MLE        = FALSE                     ,
               ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
 \item{net_object}{
    an object of class \code{PAFit_net} that contains the network.
  }
  \item{net_stat}{
    An object of class \code{PAFit_data} which contains summerized statistics needed in estimation. This object is created by the function \code{\link{get_statistics}}. The default value is \code{get_statistics(net_object)}.
  }
  \item{p}{Numeric. This is the ratio of the number of new edges in the learning data to that of the full data. The data is then divided into two parts: learning data and testing data based on \code{p}. The learning data is used to learn the node fitnesses and the testing data is then used in cross-validation. Default value is \code{0.75}.}
\item{stop_cond}{Numeric. The iterative algorithm stops when \eqn{abs(h(ii) - h(ii + 1)) / (abs(h(ii)) + 1) < stop.cond} where \eqn{h(ii)} is the value of the objective function at iteration \eqn{ii}. We recommend to choose \code{stop.cond} at most equal to \eqn{10^(- number of digits of h - 2)}, in order to ensure that when the algorithm stops, the increase in posterior probability is less than 1\% of the current posterior probability. Default is \code{10^-8}. This threshold is good enough for most applications.}

\item{mode_reg_A}{Binary. Indicates which regularization term is used for \eqn{A_k}:
\itemize{
\item \code{0}: This is the regularization term used in Ref. 1 and 2. Please refer to Eq. (4) in the tutorial for the definition of the term. It approximately enforces the power-law form \eqn{A_k = k^\alpha}. This is the default value.
\item \code{1}: Unlike the default, this regularization term exactly enforces the functional form \eqn{A_k = k^\alpha}. Please refer to Eq. (6) in the tutorial for the definition of the term. Its main drawback is it is significantly slower to converge, while its gain over the default one is marginal in most cases.
}
}
\item{MLE}{Logical. If \code{TRUE}, then not perform cross-validation and estimate the PA function with \code{r = 0}, i.e., maximum likelihood estimation. Default is \code{FALSE}. One might want to set this option to \code{TRUE} when one believes that there are sufficient data to get a reasonable MLE result, or when one wants to compare the default, regularized result with the MLE result.}
  \item{\dots}{
    %%     ~~Describe \code{\dots} here~~
  }
}

\value{
   Outputs a \code{Full_PAFit_result} object, which is a list containing the following fields:
  \itemize{
  \item \code{cv_data}: a \code{CV_Data} object which contains the cross-validation data. This is the final  Normally the user does not need to pay attention to this data. \code{NULL} if \code{MLE = TRUE}.

 \item \code{cv_result}: a \code{CV_Result} object which contains the cross-validation result. Normally the user does not need to pay attention to this data. \code{NULL} if \code{MLE = TRUE}.

 \item \code{estimate_result}: this is a \code{PAFit_result} object which contains the estimated PA function and its confidence interval. It also includes the estimated attachment exponenent \eqn{\alpha} (assuming the model \eqn{A_k = k^\alpha}) in the field \code{alpha}, and the confidence interval of \eqn{\alpha} (in the field \code{ci}) when possible. In particular, the important fields are:
     \itemize{
     \item \code{ratio}: this is the selected value for the hyper-parameter \eqn{r}.
    \item \code{k} and \code{A}: a degree vector and the estimated PA function.
    \item \code{var_A}: the estimated variance of \eqn{A}.
    \item \code{var_logA}: the estimated variance of \eqn{log A}.
    \item \code{upper_A}: the upper value of the interval of two standard deviations around \eqn{A}.
    \item \code{lower_A}: the lower value of the interval of two standard deviations around \eqn{A}.

    \item \code{center_k} and \code{theta}: when we perform binning, these are the centers of the bins and the estimated PA values for those bins. \code{theta} is similar to \code{A} but with duplicated values removed.
     \item \code{var_bin}: the variance of \code{theta}. Same as \code{var_A} but with duplicated values removed.
    \item \code{upper_bin}: the upper value of the interval of two standard deviations around \code{theta}. Same as \code{upper_A} but with duplicated values removed.
    \item \code{lower_lower}: the lower value of the interval of two standard deviations around \code{theta}. Same as \code{lower_A} but with duplicated values removed.
    \item \code{g}: the number of bins used.
    \item \code{alpha} and \code{ci}: \code{alpha} is the estimated attachment exponenet \eqn{\alpha} (when assume \eqn{A_k = k^\alpha}), while \code{ci} is the confidence interval.
    \item \code{loglinear_fit}: this is the fitting result when we estimate \eqn{\alpha}.
    \item \code{objective_value}: values of the objective function over iterations in the final run with the full data.
    \item \code{diverge_zero}: logical value indicates whether the algorithm diverged in the final run with the full data.
}
}
}
\author{
  Thong Pham \email{thongpham@thongpham.net}
}
\references{
  1. Pham, T., Sheridan, P. & Shimodaira, H. (2015). PAFit: A Statistical Method for Measuring Preferential Attachment in Temporal Complex Networks. PLoS ONE 10(9): e0137796. doi:10.1371/journal.pone.0137796 (\url{http://dx.doi.org/10.1371/journal.pone.0137796}).

  2. Pham, T., Sheridan, P. & Shimodaira, H. (2016). Joint Estimation of Preferential Attachment and Node Fitness in Growing Complex Networks. Scientific Reports 6, Article number: 32558. doi:10.1038/srep32558   (\url{http://www.nature.com/articles/srep32558}).
}
\seealso{
  See \code{\link{get_statistics}} for how to create summerized statistics needed in this function.

  See \code{\link{Newman}} and \code{\link{Jeong}} for other methods to estimate the attachment function \eqn{A_k} in isolation.

}

\examples{
\dontrun{
  library("PAFit")
  set.seed(1)
  #### Example 1: Linear preferential attachment  #########
  # a network from BA model
  net        <- generate_net(N = 1000 , m = 50 , mode = 1, alpha = 1, s = 0)

  net_stats  <- get_statistics(net, only_PA = TRUE)
  result     <- only_A_estimate(net, net_stats)

  # plot the estimated attachment function
  plot(result, net_stats)

  # true function
  true_A     <- result$estimate_result$center_k
  lines(result$estimate_result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")

  #### Example 2: a non-log-linear preferential attachment  #########
  # A_k = alpha* log (max(k,1))^beta + 1, with alpha = 2, and beta = 2
  set.seed(1)
  net        <- generate_net(N = 1000 , m = 50 , mode = 3, alpha = 2, beta = 2, s = 0)

  net_stats  <- get_statistics(net,only_PA = TRUE)
  result     <- only_A_estimate(net, net_stats)

  # plot the estimated attachment function
  plot(result, net_stats)

  # true function
  true_A     <- 2 * log(pmax(result$estimate_result$center_k,1))^2 + 1 # true function
  lines(result$estimate_result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")

  #############################################################################
  #### Example 3: another non-log-linear preferential attachment kernel ############
  set.seed(1)
  # A_k = min(max(k,1),sat_at)^alpha, with alpha = 1, and sat_at = 200
  # inverse variance of the distribution of node fitnesse = 10
  net        <- generate_net(N = 1000 , m = 50 , mode = 2, alpha = 1, sat_at = 200, s = 0)
  net_stats  <- get_statistics(net, only_PA = TRUE)

  result     <- only_A_estimate(net, net_stats)

  # plot the estimated attachment function
  true_A     <- pmin(pmax(result$estimate_result$center_k,1),200)^1 # true function
  plot(result , net_stats, max_A = max(true_A,result$estimate_result$theta))
  lines(result$estimate_result$center_k, true_A, col = "red") # true line
  legend("topleft" , legend = "True function" , col = "red" , lty = 1 , bty = "n")
  }
}

\concept{preferential attachment}
\concept{attachment function}


### This code was written by Patrick Walker and Charlie for the LMIC global report
### Edited by Ettie for USA States

### functions needed to calculate final sizes###
### outputs the 'error' relative to true final size
output_set<-function(inf_pops,rates,mixing,demog,inits){
  return(sapply(seq_along(inf_pops),function(x){
    ((demog[x]-inits[x])/inf_pops[x]*(1-exp(-sum(rates[x]*mixing[x,]*(inf_pops-inits)/demog)))-1)
  }))
}

### homogeneous solution
single_set<-function(inf_pop, rate, pop, init){
  diff=(pop-init)/inf_pop*(1-exp(-rate*(inf_pop-init)/pop))-1
  return(diff*diff)
}

### outputs the sum of squares
sum_output_set<-function(inf_pops,rates,mixing,demog,inits){
  if(min(inf_pops<=0)){return(rep(1000,length(inf_pops)))}
  outset=output_set(inf_pops,rates,mixing,demog,inits)
  return(sum(outset*outset))
}

### get the final size for a set contact matrix and R0
get_AR <- function(R, rmod, c_mat, demog, init, guess_hom, guess_modifiers,
                   iterates, reiterates, restarts, tol){
  ## modifier for next generation matrix to get required R0,1,0.6,5,100000,10,0.00000001
  tot_pop <- sum(demog)
  single_init = init
  ## distribute initial infection across demographics
  init_demog = single_init*demog/tot_pop
  ## get homogenous solution
  fit_err = 1
  guess_inf = guess_hom*tot_pop
  ## store final homogenous attack rata
  fit_single <- optim(guess_inf, single_set, rate=R, pop=tot_pop, init=single_init,
                      method="Brent", lower=0, upper=tot_pop,
                      control=list(abstol=tol, maxit=iterates))
  while(fit_err>0.0000001){
    ###use homogeouns solution as first  guess
    fit<-nmkb(fit_single$par*demog/sum(demog)*guess_modifiers, sum_output_set, lower=0,
              upper=demog, rates=rmod, mixing=c_mat, demog=demog, inits=init_demog,
              control=list(maxfeval=iterates,tol=tol,restarts.max=restarts))
    for(f in 1:reiterates){
      ## reiterate to make sure it finds the solution
      fit<-nmkb(fit$par, sum_output_set, lower=0, upper=demog, rates=rmod,
                mixing=c_mat, demog=demog, inits=init_demog,
                control=list(maxfeval=iterates,tol=tol,restarts.max=restarts))
    }
    fit_err=fit$value
    guess_modifiers <- guess_modifiers+0.05
  }
  return(fit)
}


state_prob <- c(7,5,3,2,1.2,0.5,0.3,0.4)
risk_grade_prob <- 0.5*(1/2)^(0:19)
N = 2e6

gen_lvr <- function(N) {
  x = -rgamma(N,9,0.5)
  x = x - min(x)
  x = x/max(x)
  pmax(0.01, x)
}

gen_datatable_synthetic <- function(N=2e6) {
  data.table(
    month = rep(201711,N),
    account_id = sprintf("id%010d",1:N), # id
    curr_bal =  rgamma(N,2,0.5)*125000, # numeric e.g. 23.5749
    curr_lvr = gen_lvr(N),
    int_rate = rep(0.05, N),
    risk_grade = sample(1:20, N, replace = T, prob = risk_grade_prob),
    state = sample(c("NSW","VIC","QLD","WA","SA","TAS","NT","ACT"), N, replace = T, prob = state_prob/sum(state_prob)),
    default = sample(0:1, N, replace = T, prob = c(0.97, 0.03))
  )[,risk_grade_pd := c(0.0001*(1.575)^(1:20))[risk_grade]][, value := curr_bal/curr_lvr]
}

set.seed(1)
system.time(indata <- gen_datatable_synthetic())
indata[,lvr_band := cut(curr_lvr,c(-Inf, 0.4 ,0.6,0.8,0.9,0.95, Inf))]
system.time(WA_only <- indata[state == "WA",])
fst::write.fst(WA_only,"indata/WA_only.fst")
k = log(90/100/100)/log(indata[,mean(risk_grade_pd)])

indata[,risk_grade_pd := exp(k*log(risk_grade_pd))]

orig_normal <- indata[sample(1:.N,.N/5),]
write.fst(orig_normal,"orig/orig_normal.fst", 100)
orig_80lvr <- indata[curr_lvr <= 0.8,][sample(1:.N,.N/5),]
write.fst(orig_80lvr,"orig/orig_80lvr.fst", 100)

transition_table <- data.table(expand.grid(1:20,1:20))
setnames(transition_table, names(transition_table), c("risk_grade","risk_grade_to"))
transition_table[,tran_prob := {
  toto = risk_grade - risk_grade_to
  ifelse(risk_grade == risk_grade_to, 1,
         ifelse(toto > 0, (0.04*(21-risk_grade))^toto, (0.02*risk_grade)^(-toto)))
}]

transition_table[,tran_prob := tran_prob/sum(tran_prob), risk_grade]
transition_table[order(risk_grade)]
transition_table[,sum(tran_prob), risk_grade] # checks passed

# save the data
system.time(fst::write.fst(indata, "indata/normal.fst", 100))
system.time(fst::write.fst(transition_table, "tran_tbl/normal.fst", 100))

# generate stressed transition table
transition_table <- data.table(expand.grid(1:20,1:20))
setnames(transition_table, names(transition_table), c("risk_grade","risk_grade_to"))
transition_table[,tran_prob := {
  toto = risk_grade - risk_grade_to
  ifelse(risk_grade == risk_grade_to, 1,
         ifelse(toto > 0, (0.02*(21-risk_grade))^toto, (0.04*risk_grade)^(-toto)))
}]

transition_table[,tran_prob := tran_prob/sum(tran_prob), risk_grade]
transition_table[order(risk_grade)]
transition_table[,sum(tran_prob), risk_grade] # checks passed

system.time(fst::write.fst(transition_table, "tran_tbl/stress.fst", 100))


############ Computes a decision tree on a single dataset

source("featureLibrary.r")
suppressMessages(library(jsonlite))
suppressMessages(library(party))
closeAllConnections()

## Input block
con <- file("sample_full.csv")
events <- fromJSON(readLines(con,n=1))
f.full <- read.csv(con,skip=1)

#phase1 <- function(panel,events) {
## Feature creation
f.features.list <- features(f.full)
f.features <- as.data.frame(listToMatrix(f.features.list))

# Label creation & shrinking
events.full <- createLabel(f.full,events)
events.shrunk <- as.factor(labelShrink(f.features,events.full))

## Tree estimation
tree <- ctree(events.shrunk ~ ., data=f.features) #TODO: change to cforest
#forest <- cforest(events.shrunk ~ .)

## Output block
save(tree, file="sample_tree.rda")
#}


library(dplyr)

w <- c(3.579174, 0.1751151, 0.9455746)
w <- w / sum(w)

containment <- tibble(
	"conquest" = w,
	"high" = c(0.9, 0.09, 0.01),
	"medium" = c(0.6, 0.3, 0.1),
	"low" = c(0.34, 0.33, 0.33),
	"scs1" = c(0.38, 0.47, 0.15),
	"scs2" = c(0.43, 0.24, 0.32)
)

save(containment, file="../data/containment.rdata")


# prueba de concepto distribucion grado y otras metricas.
# dada una estructura de nodos.
#

library(here)
source(here:::here("funcs","imports.r"),encoding = "UTF-8") # asi toma la ultima version
testthat::test_that(
    "prueba concepto componentes R",{

        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)
        # cota_anio <- c("1996")
        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)

        degree_distrib <- degree_distribution(g_aut) %>%
            as_tibble() %>%
            rename(degree_distribution=value) %>%
            tibble::rownames_to_column("degree") %>%
            mutate(degree=as.integer(degree)) %>%
            arrange(degree)

        plot_dist_grado <- degree_distrib %>%
            ggplot(aes(x=degree,y=degree_distribution)) +
            geom_col() +
            labs(title="Distribución de Grado",
                 x="grado",
                 y="probabilidad de grado")+
            theme_light()
        ggplotly(plot_dist_grado)

        degree_distrib %>%  filter(degree_distribution == 0 )

        plot_dist_grado_log_log <- degree_distrib %>%
            ggplot(aes(x=degree,y=degree_distribution+1)) +
            geom_point() +
            scale_x_log10()+
            scale_y_log10()+
            labs(title="Distribución de Grado ( log / log )",
                 subtitle="distribución+1 para arreglo de infinito",
                 x="grado",
                 y="probabilidad de grado")+
            theme_light()
        ggplotly(plot_dist_grado_log_log)

        # y que tal distribucion de otras metricas ?

        metricas_nodos <- metricas_nodos_grafo(g_aut)
        # colnames(metricas_nodos)
        metricas_nodos_long <- metricas_nodos %>%  tidyr::gather(metrica,valor,-autor) %>%  as_tibble()

        metrica_seleccionada <- "degree"
        metrica_seleccionada <- "fuerza_colaboracion"
        metrica_seleccionada <- "closeness"
        metrica_seleccionada <- "count_triangles"

        metricas_nodos_long %>%
            filter(metrica==metrica_seleccionada) %>%
            ggplot(aes(valor)) +
            geom_histogram() +
            labs(title=paste0("Histograma de ",metrica_seleccionada),
                 x= metrica_seleccionada,
                 y= "cantidad nodos")+
            theme_light()

        metricas_nodos_long %>%
            filter(metrica==metrica_seleccionada) %>%
            ggplot(aes(valor)) +
            geom_density_line() +
            labs(title=paste0("Densidad de ",metrica_seleccionada),
                 x= metrica_seleccionada,
                 y= "densidad")+
            theme_light()

        # para terminar ver todas las metricas tipo el ggridges
        # problema: no manejan misma escala => no se pueden mostrat todos a la vez.
        # descartado
        metricas_nodos %>% skimr::skim()
        metricas_nodos_long %>%

            # filter(metrica==metrica_seleccionada) %>%
            ggplot(aes(y=metrica,x=valor,color=metrica)) +
            ggridges::geom_density_ridges(alpha = 0.2)+
            labs(title=paste0("Densidades de metricas"),
                 x= "valores",
                 y= "cantidad nodos")

        metricas_plots <- metricas_nodos_long %>%
            nest(-metrica) %>%
            mutate(plot_densidad=map2(data,metrica,function(x,metrica){
                x %>% ggplot(aes(x=valor)) +
                    geom_density_line(alpha = 0.2)+
                    labs(title=metrica,
                         x="valor",
                         y="densidad")
                })) %>%
            mutate(plot_histograma=map2(data,metrica,function(x,metrica){
                x %>% ggplot(aes(x=valor)) +
                    geom_histogram(alpha = 0.2)+
                    labs(title=metrica,
                         x="valor",
                         y="cantidad nodos")
            }))

        metricas_plots$plot_densidad[[1]] + labs(title="Fuerza de Colaboración")
        metricas_plots$plot_histograma
            # filter(metrica==metrica_seleccionada) %>%

})


#
# Plot MLDS perceptual scales
#
# Input: <mydata.txt> under each subject's folder
# Output:
#   1) 'bx.png': individual perceptual scale in each subject's folder
#   2) 'all.eps": average perceptual scale
#
#
#!/usr/bin/env Rscript
# 26/08/2017 Wenyan Bi <wb1918a@american.edu> wrote this

###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ######
# [wb]: Check library
libs <- c("reshape", "dplyr", "tibble", "MLDS", "rstudioapi", "ggplot2", "tidyr")

for (n in 1:length(libs)){
  if(libs[n] %in% rownames(installed.packages()) == FALSE){
    install.packages(libs[n])
  }

  library(libs[n], character.only = TRUE)
}

###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ######
# [wb]: Define subjects
subs <- c('wb', 'pj', 'bx')
expName <- 'Bending_Silk'
nStim <- 8

# [wb]: Other parameters
vid <- seq(1, nStim, length.out=nStim)
mydata <- list()
# [wb]: stores the mlds results
x <- list()
# [wb]: save all mlds results to the .csv file
myCSVdata <- list()

###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ######
# [wb]: Set path
curDir <- getActiveDocumentContext()$path
setwd(dirname(curDir))
print(getwd())

curDir <- getwd()
setwd("..")
rootDir <- getwd()
setwd(curDir)
# [wb]: output is in the same folder as the input
inputRootDir <- paste(dirname(curDir), '/', expName, '/resultsFolder', sep = '')

###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ######
# [wb]: Plot individual perceptual scale
for (n in 1:length(subs)){
  thisDir <- paste(inputRootDir, '/', subs[n], sep = '')
  thisDataFile <- paste(thisDir,'/mydata.txt', sep = '')
  mydata[[n]] <- read.table(thisDataFile, sep = "\t")

  x[[n]] <- mlds(mydata[[n]])
  summary(x[[n]])

  outputFileName <- paste (thisDir, '/', subs[n], '.png', sep = '')
  png(filename = outputFileName);
  plot(x[[n]], type = "b", main="MLDS Perceptual Scale",
       xlab="Ground Truth Stiffness Values",
       ylab="Perceived Stiffness",
       standard.scale =TRUE, cex = 1.7, pch = 16, col = "red")
  lines(x[[n]], standard.scale =TRUE, col='red')
  dev.off()

  ## un-normalize
  # myCSVdata[[n]] <- x[[n]]$pscale
  # normalize
  myCSVdata[[n]] <- (x[[n]]$pscale- min(x[[n]]$pscale))/(max(x[[n]]$pscale) - min(x[[n]]$pscale))
}

###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ######
# [wb]: output .csv file
df <- data.frame(matrix(unlist(myCSVdata), ncol=length(myCSVdata)))
outputFileName <- paste(curDir, "/mydata.csv", sep = '')
write.table(df, file = outputFileName,
            row.names=FALSE, na="",
            col.names=subs, sep=",")

###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ###### ######
# [wb]: Plot average perceptual scale
mydata <-read.csv(outputFileName)
average <- rowMeans(x=mydata, na.rm=TRUE)  #calculate the mean
mydata <- cbind(mydata, average)

mydata <- gather(mydata, c(subs, 'average'), key = 'subject',value = perc)
mydata_vids <- rep(vid, length(subs)+1)
mydata <- cbind(mydata, mydata_vids)

p <- ggplot(data = mydata, aes(x=mydata_vids,y=perc, color=subject)) +
  geom_line() + geom_point()
p <- p+scale_color_manual(values=c("#fe3d66","#e1e9fa","#c2d4f4", "#a8c5ef","#a4beef"))
p <- p+labs(title = "MLDS results",x="Physical Bending Stiffness Parameters",y="Perceptual Scale")+theme(plot.title = element_text(hjust = 0.5))
p <- p + scale_x_continuous(breaks=1:nStim, labels=vid)

file_name = 'All_PerceptualScale'
postscript(file = paste(file_name, '.eps', sep=""), width = 6, height = 4)
print(p)
dev.off()


#对单个内容进行画图分析，尝试记录单个内容的pdf图片格式
#文件名：voltage_ov , onset voltge 启动电压与三种液体之间随流量、极间距离、针头直径变化的影响

######################读取文件模块###################
#setwd("D:/data")
library(xlsx)

#读取v~Q的数据
de_q<-read.xlsx("voltage.xls",sheetName="ethanol_q",header=TRUE)
da_q<-read.xlsx("voltage.xls",sheetName="acetone_q",header=TRUE)
di_q<-read.xlsx("voltage.xls",sheetName="iso_q",header=TRUE)

#保存pdf
pdf("voltage_3liquids_ov.pdf")
#画图-乙醇

plot(de_q$flowrate, de_q$OV,  col=0, xaxs="i", xlim=c(-0.002, 0.032), ylim=c(1, 3),
xlab="Q (ml/min)",mgp=c(1, 0, 0),tck=0.02,cex.lab=1.1,
ylab=expression(V["os"](kv)))

title(main="Onset Voltage changes with Flowrate",cex.main=1.1,line=0.5)

model_qov <- loess(de_q$OV ~ de_q$flowrate)
fit <- fitted(model_qov)
ord <- order(de_q$flowrate)

lines(de_q$flowrate[ord], fit[ord], type="b", col="red", lwd=2.5, lty=2) # 乙醇的拟合曲线

#画图-丙酮
#points(da_q$flowrate, da_q$OV,  pch=23, col="blue")

model_aov <- loess(da_q$OV ~ da_q$flowrate)
fit <- fitted(model_aov)
ord <- order(da_q$flowrate)

lines(da_q$flowrate[ord], fit[ord], type="b", col="blue", pch=23, lwd=2.5, lty=2) # 丙酮的拟合曲线

#画图-异丙醇
#points(di_q$flowrate, di_q$OV,  pch=23, col="green")

model_iov <- loess(di_q$OV ~ di_q$flowrate)
fit <- fitted(model_iov)
ord <- order(di_q$flowrate)

lines(di_q$flowrate[ord], fit[ord], type="b", col="darkgreen", pch=24, lwd=2.5, lty=2) # 异丙醇的拟合曲线

#图例标注
legend("topright", c("Ethanol", "Acetone", "Isoproply"), inset=.1, bty="n", pch=c(6, 23, 24), col=c("red", "blue", "darkgreen"), lty=2,
       lwd=2.5, cex=1)

dev.off()


#Comparing R2 density between Tedersoo out-of-sample (OOS) forecast to NEON and NEON cross-validation (CV).
rm(list=ls())
source('paths.r')
source('NEFI_functions/zero_truncated_density.r')
source('NEFI_functions/rsq_1.1.r')

#set figure out put path.----
output.path <- 'test.png'

#Load calibration and validation predictions and data for OOS and CV.----
#Out of sample Tedersoo calibration, and out of sample predictions for NEON.
oos.cal <- readRDS(ted_ITS.prior_dmulti.ddirch_fg_JAGSfit)
oos.val <- readRDS(NEON_dmulti.ddirch_fcast_fg.path)

#NEON out of sample observations across scale.
oos.dat <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path)

#Cross validation forecasts
cv.val.core <- readRDS(core.CV_NEON_fcast.path)
cv.val.plot <- readRDS(plot.CV_NEON_fcast.path)

#Cross validation predictions
cv.cal.core <- readRDS(core.CV_NEON_dmulti.ddirch_all.path)
cv.cal.plot <- readRDS(plot.CV_NEON_dmulti.ddirch_all.path)

#Cross validation data (calibration and validation)
 cv.dat.core <- readRDS(core.CV_NEON_cal.val_data.path)
 cv.dat.plot <- readRDS(plot.CV_NEON_cal.val_data.path)
 cv.dat.core <- cv.dat.core$val$y.val
 cv.dat.plot <- cv.dat.plot$val$y.val

#Generate Tedersoo out of sample fit statistics.----
oos.stats <- list()
for(i in 1:length(oos.val)){
  lev   <- oos.val[[i]]
  lev.y <- oos.dat[[i]]
  x <- list(lev$core.fit$mean, lev$plot.fit$mean, lev$site.fit$mean)
  y <- list(lev.y$core.fit, lev.y$plot.fit$mean, lev.y$site.fit$mean)
  cps.list <- list()
  for(k in 1:length(y)){
    yy <- y[[k]]
    xx <- x[[k]]
    #deal with trailing -GEN
    rownames(yy) <- gsub('-GEN','', rownames(yy))
    rownames(xx) <- gsub('-GEN','', rownames(xx))
    #match row and column names.
    yy <- yy[,order(match(colnames(yy), colnames(xx)))]
    xx <- xx[rownames(xx) %in% rownames(yy),]
    yy <- yy[order(match(rownames(yy), rownames(xx))),]
    #Get R2 for each column.
    lev.stats <- list()
    for(j in 1:ncol(yy)){
      #r square best fit.
      fit <- lm(yy[,j] ~ xx[,j])
      rsq <- summary(fit)$r.squared
      #r square 1:1.
      rss <- sum((xx[,j] -      yy[,j])  ^ 2)  ## residual sum of squares
      tss <- sum((yy[,j] - mean(yy[,j])) ^ 2)  ## total sum of squares
      rsq1 <- 1 - rss/tss
      if(rsq1 < 0){rsq1 <- 0}
      #RMSE.
      rmse <- sqrt(mean(fit$residuals^2))
      return <- c(rsq,rsq1,rmse)
      lev.stats[[j]] <- return
    }
    lev.stats <- do.call(rbind, lev.stats)
    colnames(lev.stats) <- c('rsq','rsq1','rmse')
    rownames(lev.stats) <- colnames(yy)
    cps.list[[k]] <- lev.stats
  }
  names(cps.list) <- c('core','plot','site')
  oos.stats[[i]] <- cps.list
}
names(oos.stats) <- names(oos.val)

#reformat tedersoo out of sample forecasts to match cross validation.----
oos.core.list <- list()
oos.plot.list <- list()
for(i in 1:length(oos.stats)){
  oos.core.list[[i]] <- oos.stats[[i]]$core
  oos.plot.list[[i]] <- oos.stats[[i]]$plot
}
names(oos.core.list) <- names(oos.stats)
names(oos.plot.list) <- names(oos.stats)

#Get NEON Cross-validated stats at core and plot level.-----
#core level.
core.list <- list()
for(i in 1:length(cv.val.core)){
  x <- cv.val.core[[i]]$core.fit$mean
  y <- cv.dat.core[[i]]$rel.abundances
  #deal with trailing -GEN
  rownames(y) <- gsub('-GEN','', rownames(y))
  rownames(x) <- gsub('-GEN','', rownames(x))
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(xx)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[rownames(y) %in% rownames(x),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ##    total sum of squares
    rsq1 <- 1 - rss/tss
    rsq1 <- rsq_1.1(y[,j], x[,j])          ## new rsq_1.1 function.
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  lev.stats <- lev.stats[-(rownames(lev.stats) %in% 'other'),]
  core.list[[i]] <- lev.stats
}
names(core.list) <- names(cv.dat.core)

#plot level.
plot.list <- list()
for(i in 1:length(cv.val.plot)){
  x <- cv.val.plot[[i]]$plot.fit$mean
  y <- cv.dat.plot[[i]]$mean
  #deal with trailing -GEN
  rownames(y) <- gsub('-GEN','', rownames(y))
  rownames(x) <- gsub('-GEN','', rownames(x))
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(x)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[rownames(y) %in% rownames(x),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ## total sum of squares
    rsq1 <- 1 - rss/tss
    rsq1 <- rsq_1.1(y[,j], x[,j])          ## new rsq_1.1 function.
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  lev.stats <- lev.stats[-(rownames(lev.stats) %in% 'other'),]
  plot.list[[i]] <- lev.stats
}
names(plot.list) <- names(cv.val.plot)

#Get means by level.----
#core scale.
core.lev.mu <- list()
for(i in 1:length(core.list)){
  z <- data.frame(core.list[[i]])
  core.lev.mu[[i]] <- mean(z$rsq, na.rm = T)
}
core.lev.mu <- unlist(core.lev.mu)
names(core.lev.mu) <- names(core.list)
names(core.lev.mu)[length(core.lev.mu)] <- 'functional'
ref.order <- c(length(core.lev.mu), 1:(length(core.lev.mu) - 1))
core.lev.mu <- core.lev.mu[ref.order]

#plot scale.
plot.lev.mu <- list()
for(i in 1:length(plot.list)){
  z <- data.frame(plot.list[[i   ]])
  plot.lev.mu[[i]] <- mean(z$rsq, na.rm = T)
}
plot.lev.mu <- unlist(plot.lev.mu)
names(plot.lev.mu) <- names(plot.list)
names(plot.lev.mu)[length(plot.lev.mu)] <- 'functional'
ref.order <- c(length(plot.lev.mu), 1:(length(plot.lev.mu) - 1))
plot.lev.mu <- plot.lev.mu[ref.order]

#Collapse to 6x2 data frames.----
cv.core.r2   <- list()
cv.plot.r2   <- list()
cv.core.r2.1 <- list()
cv.plot.r2.1 <- list()
cv.core.rmse <- list()
cv.plot.rmse <- list()
for(i in 1:length(core.list)){
  cv.core.r2  [[i]] <- core.list[[i]][,1]
  cv.plot.r2  [[i]] <- plot.list[[i]][,1]
  cv.core.r2.1[[i]] <- core.list[[i]][,2]
  cv.plot.r2.1[[i]] <- plot.list[[i]][,2]
  cv.core.rmse[[i]] <- core.list[[i]][,3]
  cv.plot.rmse[[i]] <- plot.list[[i]][,3]
}
cv.core.r2 <- unlist(cv.core.r2)
cv.plot.r2 <- unlist(cv.plot.r2)
cv.core.r2.1 <- unlist(cv.core.r2.1)
cv.plot.r2.1 <- unlist(cv.plot.r2.1)
cv.core.rmse <- unlist(cv.core.rmse)
cv.plot.rmse <- unlist(cv.plot.rmse)

#Same for Tedersoo forecast.
oos.core.r2   <- list()
oos.plot.r2   <- list()
oos.core.r2.1 <- list()
oos.plot.r2.1 <- list()
oos.core.rmse <- list()
oos.plot.rmse <- list()
for(i in 1:length(oos.core.list)){
  oos.core.r2  [[i]] <- oos.core.list[[i]][,1]
  oos.plot.r2  [[i]] <- oos.plot.list[[i]][,1]
  oos.core.r2.1[[i]] <- oos.core.list[[i]][,2]
  oos.plot.r2.1[[i]] <- oos.plot.list[[i]][,2]
  oos.core.rmse[[i]] <- oos.core.list[[i]][,3]
  oos.plot.rmse[[i]] <- oos.plot.list[[i]][,3]
}
oos.core.r2   <- unlist(oos.core.r2)
oos.plot.r2   <- unlist(oos.plot.r2)
oos.core.r2.1 <- unlist(oos.core.r2.1)
oos.plot.r2.1 <- unlist(oos.plot.r2.1)
oos.core.rmse <- unlist(oos.core.rmse)
oos.plot.rmse <- unlist(oos.plot.rmse)

#plot R2, R2-1 and RMSE stats by scale.-----
#png save line.
png(filename=output.path,width=10,height=8,units='in',res=300)

#Global plot settings.
par(mfrow = c(2,2),
    mar = c(4,4,2,2))
limx <- c(0,1)
limy <- c(0, 25)
trans <- 0.2 #shading transparency.
o.cex <- 1.3 #outer label size.
cols <- c('purple','cyan','yellow')
labs <- c('Global Forecast','NEON Cross-Validation')
labs <- c('Global Forecast (a)','NEON Cross-Validation (b)','Global Forecast (c)','NEON Cross-Validation (d)')

#Forecast OOS R2----
a <- oos.core.r2[!is.na(oos.core.r2)]
b <- oos.plot.r2[!is.na(oos.plot.r2)]
main.lab <- labs[1]
limx <- c(0,max(c(a, b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
plot(cv.core.r2,ylim = limy, xlim = limx, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext(expression(paste("Validation R"^"2")), side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

##Plot legend
legend(x = 0.4, y = 25, legend = c('core','plot'), col ='black', pt.bg=adjustcolor(cols,trans), bty = 'n', pch = 22, pt.cex = 1.5, cex = 1.5)

#NEON CV R2----
a <- cv.core.r2[!is.na(cv.core.r2)]
b <- cv.plot.r2[!is.na(cv.plot.r2)]
limx <- c(0,max(c(a, b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
main.lab <- labs[2]
plot(cv.core.r2,ylim = limy, xlim = limx, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext(expression(paste("Validation R"^"2")), side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

#Forecast OOS RMSE----
a <- oos.core.rmse
b <- oos.plot.rmse
limx <- c(0,max(c(a,b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
main.lab <- labs[3]
plot(cv.core.rmse,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext('RMSE', side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

#NEON CV RMSE----
a <- cv.core.rmse
b <- cv.plot.rmse
limx <- c(0,max(c(a,b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
main.lab <- labs[4]
plot(cv.core.rmse,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext('RMSE', side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

#end plot.----
dev.off()


#' Function for computing the posterior mode cluster assignment of subjects in test and training data sets.
#'
#' This function takes the \code{cluster_inds} - which is a posterior matrix of cluster assignments output by \code{NDPMix()}, \code{PDPMix()}, and \code{ZDPMix()} and computes the posterior mode cluster assignment while implementing a deterministic re-labeling of subjects.
#'
#' Please see \url{https://stablemarkets.github.io/ChiRPsite/index.html} for examples and detailed model and parameter descriptions.
#'
#' Please see \url{https://arxiv.org/abs/1810.09494}, section on hyperparameters and label switching for more information.
#'
#' @import stats
#'
#' @param c_shell set this to \code{cluster_inds} (for either training or testing sets). \code{cluster_inds} is output by \code{NDPMix()}, \code{PDPMix()}, and \code{ZDPMix()}.
#' @return This function returns a list of two objects: \code{adjmat} and \code{class_mem}. For \code{n} subjects, the former is an \code{n} by \code{n} adjacency matrix with i-j th element giving the posterior probability of subject i and j being clustered together. This can be visualized using a network diagram (see examples on website linked in Details). \code{class_mem} is a vector of length \code{n} giving posterior mode clsuter membership for each of the \code{n} subjects. This can be used for cluster-specific analysis, for example.
#' @examples
#' # simulate data
#'
#' set.seed(1)
#' n<-200 ## generate from clustered, skewed, data distribution
#' X11 <- rnorm(n = n, mean = 10, sd = 3)
#' X12 <- rnorm(n = n, mean = 0, sd = 2)
#' X13 <- rnorm(n = n, mean = -10, sd = 4)
#'
#' Y1 <- rnorm(n = n, mean = 100 + .5*X11, 20)*(1-rbinom(n, 1, prob = pnorm( -10 + 1*X11 ) ))
#' Y2 <- rnorm(n = n, mean = 200 + 1*X12, 30)*(1-rbinom(n, 1, prob = pnorm( 1 + .05*X12 ) ))
#' Y3 <- rnorm(n = n, mean = 300 + 2*X13, 40)*(1-rbinom(n, 1, prob = pnorm( -3 -.2*X13 ) ))
#'
#' d <- data.frame(X1=c(X11, X12, X13), Y = c(Y1, Y2, Y3))
#'
#' # split into training and testing
#' ids <- sample(1:600, size = 500, replace = FALSE )
#'
#' d$X1 <- scale(d$X1)
#'
#' d_train <- d[ids,]
#' d_test <- d[-ids, ]
#'
#' # run zero-inflated model #'
#' res <- ChiRP::ZDPMix(d_train = d_train, d_test = d_test, formula = Y ~ X1,
#'                      burnin=100, iter=200, init_k = 5, phi_y = c(10, 10000))
#'
#' # compute the posterior model cluster assignment for training subjects
#' train_clus <- ChiRP::cluster_assign_mode(res$cluster_inds$train)
#' @export
cluster_assign_mode <- function(c_shell){
  c_shell <- c_shell
  iter<-ncol(c_shell)
  n <- nrow(c_shell)

  adjmat<-matrix(0, nrow=n, ncol=n)

  ## compute frequency matrix
  for(i in 1:iter){
    adjmat_i <- matrix(0, nrow=n, ncol=n)
    class <- c_shell[,i]

    for(j in 1:n){
      adjmat_i[j,] <- class==class[j]
    }
    adjmat <- adjmat + adjmat_i
  }

  ## choose best cluster assignment
  err_vec <- numeric(length = ncol(c_shell))
  for(i in 1:iter){
    adjmat_i <- matrix(0, nrow=n, ncol=n)
    class <- c_shell[,i]
    for(j in 1:n){
      adjmat_i[j,] <- class==class[j]
    } # compute L2 norm.
    err_vec[i] <- sum((adjmat_i - adjmat)^2)
  }

  class_mem <- c_shell[, c(1:ncol(c_shell))[ err_vec==min(err_vec) ] ]
  if(is.matrix(class_mem)) class_mem <- class_mem[,1]

  adjmat <- adjmat/iter
  return(list(adjmat=adjmat, class_mem=class_mem))
}


dfs <- function(start, target) {
  #' Implementation of DFS (depth-first search) algorithm to find the shortest path from a start to a target node..
  #' Given a start node, this returns the node in the tree below the start node with the target value (or null if it doesn't exist)
  #' Runs in O(n), where n is the number of nodes in the tree, or O(b^d), where b is the branching factor and d is the depth.
  #' @param start  the node to start the search from
  #' @param target the value to search for
  #' @return The node containing the target value or null if it doesn't exist.

  cat("Visiting Node ", start$value, "\n")
  if(start$value == target){
    # We have found the goal node we we're searching for
    print("Found the node we're looking for!")
    return (start)
  }

  # Recurse with all children
  for(i in seq_along(start$children)) {
    result = dfs(start$children[[i]], target)
    if (!is.null(result)) {
      # We've found the goal node while going down that child
      return (result)
    }
  }

  # We've gone through all children and not found the goal node
  cat("Went through all children of ", start$value, ", returning to it's parent.", "\n")
  return (NULL)
}


require( "stats", quietly = TRUE )

user_func <- function( times ) {
	rep( "I am made of sugar", times )
}

fib <- function( n ) {
	if( n < 2 )
		return( 1 )
	return( fib( n - 1 ) + fib( n - 2 ) )
}


##
## Analyse varying intercepts/slopes models of gift giving
##
## run 'multilevel models - fit.r' first if you need to fit the models (warning: will take a LOOOOOooooOOOONG time)
## and run 'multilevel models - compare.r' to calculate information criteria etc. (takes about a day)
##
## install development version of loo for model_weights()
## > devtools::install_github("stan-dev/loo")
##
library(rstanarm)
library(loo)
library(bayesplot)
library(tidyverse)
library(xlsx)
library(RColorBrewer)

# load models and comparisons
if (file.exists(gift_models_file)) {
  load(gift_models_file)  # run `multilevel models - fit.r` if this doesn't exist
} else {
  stop("You need to fit the multilevel models before analysing them")
}

if (file.exists(comparison_data_file)) {
  load(comparison_data_file)  # run `multilevel models - compare.r` if this doesn't exist
} else {
  stop("You need to compare the multilevel models before analysing them")
}

# some useful lists
mlms = list(mlm.null.nested, mlm.r.re, mlm.siida.re, mlm.r_siida.fe, mlm.r_siida.re, mlm.full.fe, mlm.full)
models_list = c("mlm.null.nested" = "Null - nested",
                "mlm.r.re" = "r",
                "mlm.siida.re" = "siida",
                "mlm.r_siida.fe" = "r + siida",
                "mlm.r_siida.re" = "r + siida - slopes",
                "mlm.full.fe" = "r * siida",
                "mlm.full" = "r * siida - slopes")

#######################################################################
## Check model selection table
##
loo_comp
round(mlm_weights, 2)
##--> mlm.full is the best-fitting model and has all the weight

##
## some other model checking/diagnostics
##
# visualise r-hat scores
rhats = rhat(mlm.full)
color_scheme_set("brightblue")
mcmc_rhat(rhats)  # these all look pretty good

# visualise effect sample size ratios
ratios = neff_ratio(mlm.full)
mcmc_neff(ratios)

# check that none of the n_eff / N ratios are < 0.5
ratios[ ratios < 0.5 ]

## all looks good

#######################################################################
## Plot model coefficients - site-specific intercepts and slopes
##
draws = as.array(mlm.full)
draws = draws[,, grep( "Pop:Ego", dimnames(draws)$parameters, invert = T )]  # drop intercepts for egos nested in sites

# for each population, calculate its intercept and slopes
pops = unique(as.character(d.long$Pop))

# add intercepts for each site to population-average intercept
draws.int        = draws[, grep(paste( paste0("Intercept.*",    pops), collapse="|"), dimnames(draws)$parameters)] + draws[, "(Intercept)"]
# add slopes for each site to average slopes
draws.slope.r    = draws[, grep(paste( paste0("b\\[r Pop\\:",   pops), collapse="|"), dimnames(draws)$parameters)] + draws[, "r"]
draws.slope.hg   = draws[, grep(paste( paste0("b\\[Same.*",     pops), collapse="|"), dimnames(draws)$parameters)] + draws[, "SameHerdingGroup"]
draws.slope.r_hg = draws[, grep(paste( paste0("b\\[r\\:Same.*", pops), collapse="|"), dimnames(draws)$parameters)] + draws[, "r:SameHerdingGroup"]

# prettify names and calculate quantiles for plotting
dimnames(draws.int)$parameters        = paste0("Intercepts_",pops)
dimnames(draws.slope.r)$parameters    = paste0("Relatedness_",pops)
dimnames(draws.slope.hg)$parameters   = paste0("Herding group_",pops)
dimnames(draws.slope.r_hg)$parameters = paste0("Interaction_",pops)

draws.site = cbind(draws.int, draws.slope.r, draws.slope.hg, draws.slope.r_hg)

quants = apply(draws.site, 2, quantile, probs = c(0.025, 0.1, 0.5, 0.9, 0.975))  # quantiles of posterior

# convert to data frame, rename the columns, turn the rownames into a 'parameter' column, add a grouping variable for intercepts/slopes
quants = as.data.frame(t(quants))
names(quants) = c("lwr.95", "lwr.80", "med", "upr.80", "upr.95")
quants = cbind(Parameter=rownames(quants), quants)  # convert row names into a 'Parameter' variable
rownames(quants) = NULL  # remove row names
quants = quants %>%
  separate(Parameter, c("Type", "Site"), sep="_")

quants$Type = factor(quants$Type, levels=c("Intercepts", "Relatedness", "Herding group", "Interaction"))
quants$Site = factor( convert_pop(quants$Site) )

# min(quants$med)
# max(quants$med)

# plot estimates
# (use forcats::fct_rev() to get the site labels in alphabetical order from top to bottom)
ggplot(quants, aes(x=forcats::fct_rev(Site), y=med)) +
  geom_hline(yintercept=0, colour = "grey80", linetype=2) +  # line of no effect
  geom_linerange(aes(ymin=lwr.80, ymax=upr.80, colour=Site), size=1.5) +
  geom_linerange(aes(ymin=lwr.95, ymax=upr.95, colour=Site)) +
  geom_point(aes(colour=Site), fill="white", size=2, stroke=1.5, shape = 21) +

  facet_wrap(~Type, strip.position = "left", ncol=1) +  # add grouping label (source: http://stackoverflow.com/a/36337286)
  coord_flip() +

  scale_color_brewer(type="qual", palette="Dark2") +

  xlab("") +
  ylab("Log-odds") +

  theme_bw() +
  theme(panel.spacing = unit(0, "lines")
        ,strip.background = element_blank()
        ,strip.placement = "outside"
        ,plot.background = element_blank()
        ,panel.grid.major = element_blank()
        ,panel.grid.minor = element_blank()
        ,panel.background = element_blank()
        ) +
  theme(legend.position="none")

ggsave(filename=file.path(plots.dir, "gifts - site-specific coefficients.png"), width=150, height=200, units="mm")
ggsave(filename=file.path(plots.dir, "gifts - site-specific coefficients.pdf"), width=150, height=200, units="mm")

##
## make a table of all coefficients
##
quants_table = quants %>%
  select(Site, Parameter=Type, med, lwr.95, upr.95) %>%
  mutate(Parameter = str_replace(Parameter, "slopes", ""), Site = as.character(Site)) %>%
  arrange(Site)

write_csv(quants_table, file.path(results.dir, "gifts - param estimates.csv"))

#######################################################################
## Variance and correlation components
## compare in intercept-only (clustering only) model to best model
##
VPCs = function(m) {
  # get variances for varying intercepts and slopes, and add on the population-average intercept variance
  vc = VarCorr(m) %>%
    dplyr::as_data_frame() %>%
    filter(is.na(var2)) %>%      # get rid of covariances
    select(-var2) %>%            #... and unneeded columns
    add_row(grp="Avg", var1="(Intercept)",  # add population-average intercept variance to the beginning of this dataframe
            vcov=m$covmat["(Intercept)", "(Intercept)"], .before=1)

  # calculation variance partition coefficients and report back
  vc %>%
    mutate(vpc = vcov / sum(vcov))
}

# calculate VPCs for all models
vpc_list = lapply(mlms, function(m) VPCs(m))
names(vpc_list) = models_list

##
## model summaries
##
# delta LOO information criteria
IC.list <- abs( unlist( sapply(loos, function(x) x[ grep("^elpd", names(x)) ]) ) )
dIC <- IC.list - min( IC.list )
names(dIC) = sapply(loos, function(x) attr(x, "model"))

# numbers of groups and observations in each model
model_summaries = sapply(mlms, function(x) c(ngrps(x), N=nobs(x)))
model_summaries = rbind(model_summaries, dIC, mlm_weights)  # tag on delta ICs

##
## save everything to a single Excel workbook - one sheet for VPC table and one sheet containing model summaries
##
wb = createWorkbook()

sheet_vpc = createSheet(wb, "VPCs")
start_col = 1
for (v in vpc_list) {
  addDataFrame(as.data.frame(v), sheet=sheet_vpc, startColumn=start_col, row.names=F)
  start_col = start_col + ncol(v)
}

sheet_sum = createSheet(wb, "Summaries")
addDataFrame(model_summaries, sheet=sheet_sum, startColumn=1, row.names=F)

saveWorkbook(wb, file.path(results.dir, "Model summaries.xlsx"))

rm(dIC, IC.list, model_summaries)
rm(wb, sheet_vpc, start_col, v, sheet_sum)
rm(mlms)

#######################################################################
## Plot predicted probabilities of gifts
##
new.data = expand.grid(
  r = seq(from=0, to=0.5, length.out=30),
  SameHerdingGroup = 0:1,
  Pop = unique(as.character(d.long$Pop)),
  Ego.ID = 0, GiftGiven = 0
)

# ~ (... | Pop) ==> average over egos in sites
post = posterior_predict(mlm.full, new.data, re.form = ~ (r * SameHerdingGroup | Pop))
pred = posterior_linpred(mlm.full, new.data, re.form = ~ (r * SameHerdingGroup | Pop), transform=T)

quants = apply(post, 2, quantile, probs = c(0.025, 0.5, 0.975))  # quantiles over mcmc samples
quants2 = apply(pred, 2, quantile, probs = c(0.025, 0.5, 0.975))  # quantiles over mcmc samples
row.names(quants) = c("sim.lwr", "sim.med", "sim.upr")
row.names(quants2) = c("lwr", "GiftGiven.pred", "upr")

new.data = cbind(new.data, t(quants), t(quants2))

# rename and re-order study sites
new.data$PopName = factor( convert_pop(new.data$Pop) )

# dummy data to give Finnmark the same y limits and Tibet the same y limits
# plots points at r = 1 (which will be hidden by the x limits in scale_x_log10)
ylims = data.frame(GiftGiven.pred=c(0.9, 0.9, 0.3, 0.3, 0.3, 0.3), PopName=levels(new.data$PopName),
                   r=1, SameHerdingGroup=0)

ggplot(new.data, aes(x=r, y=GiftGiven.pred)) +
  geom_line(aes(colour=factor(SameHerdingGroup))) +
  geom_ribbon(aes(ymin=lwr, ymax=upr, fill=factor(SameHerdingGroup)), alpha=0.2) +

  geom_blank(data=ylims) +  # plot dummy data to give facets the same y limits by country

  scale_colour_manual(values = cols) +
  scale_fill_manual(values = cols) +

  xlab("Coefficient of relatedness") +
  ylab("Probability of gift giving") +

  # plot relatedness on log scale with breaks at familiar points
  scale_x_log10(breaks=c(0.0001, 0.0039, 0.0078, 0.015, 0.031, 0.063, 0.125, 0.25, 0.5), limits=c(0.0115, 0.5)) +

  facet_wrap(~PopName, scales="free_y", ncol=2) +
  common_theme +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1)  # rotate x-axis labels
  )

ggsave(filename=file.path(plots.dir, "Gifts - predicted - multilevel models.png"), width=175, height=200, units="mm")
ggsave(filename=file.path(plots.dir, "Gifts - predicted - multilevel models.pdf"), width=175, height=200, units="mm")


##
## social network analyses of gifts
##
library(futile.logger)
library(igraph)
library(tidyverse)

source("init if necessary.r")

####################################################################
## Prepare data
##
flog.info("SNA: preparing data")

# make a list of herder nodes
nodes = dyads %>%
  select(starts_with("Ego"), Pop, PopName) %>%
  distinct()

names(nodes) = gsub("Ego\\.", "", names(nodes))  # get rid of "Ego." at the start of column names

# sort out column types
#nodes$Sex = factor(nodes$Sex)
#nodes$HG = factor(nodes$HG)

# make an edge list of gifts
gifts = dyads %>%
  filter(GiftGiven==1) %>%
  select(Ego.ID, Alter.ID, Amount)
gifts$weight = gifts$Amount

g.gifts = graph.data.frame(gifts, vertices=nodes, directed=T)

study_sites = unique(nodes$Pop)

# no. gifts received
deg.in  = degree(g.gifts, mode="in")
nodes$NumGifts = deg.in[ as.character(nodes$ID) ]

####################################################################
## For each site, calculate various social network stats for observed and random nets
##
flog.info("SNA: simulating networks and calculating statistics...")

# set up data.frame for observed network stats
net.stats = data.frame(Site=rep("", length(study_sites)), n.obs=0,
                       clusters=0, reciprocity=0, density=0, transitivity=0, modularity=0,
                       assortativity.degree=0, assortativity.hg=0, assortativity.sex=0,
                       stringsAsFactors=F)

# set up data.frame for random nets
n.sims = 1000

net.stats.rnd = data.frame(Site=rep("", n.sims), sim=0, n.obs=0,
                           clusters=0, reciprocity=0, density=0, transitivity=0, modularity=0,
                           assortativity.degree=0, assortativity.hg=0, assortativity.sex=0,
                           stringsAsFactors=F)

i=1  # track which row of net.stats to write to
j=1  # track which row of net.stats.rnd to write to

for (pop in study_sites)
{
  #pop = unique(nodes$Pop)[1]

  # subset graph for this site only
  g.gifts.sub = induced_subgraph(graph=g.gifts, which(V(g.gifts)$Pop==pop))
  # get individuals in this sub-graph
  nodes.sub = subset(nodes, ID %in% V(g.gifts.sub)$name)

  # calc stats for this network
  net.stats[i,] = c(as.character(pop),
                    length(E(g.gifts.sub)),
                    no.clusters(g.gifts.sub),
                    reciprocity(g.gifts.sub),
                    graph.density(g.gifts.sub),
                    transitivity(g.gifts.sub),
                    modularity(cluster_edge_betweenness(g.gifts.sub)),
                    assortativity(g.gifts.sub, types1 = nodes.sub$NumGifts),  # assorting on gifts?
                    0, #assortativity.nominal(g.gifts.sub, types=herding_groups, directed=T),  # problems with Tibet networks, so calculate separately below
                    #assortativity(g.gifts.sub, types1 = nodes.sub$cattle, types2 = nodes.sub$cattle),  # assorting on herd sizes? -- too many NAs
                    assortativity.nominal(g.gifts.sub, types=nodes.sub$Sex, directed=T)  # assorting on sex?
                    )

  ##
  ## we don't know herding group membership for some people in some of the Tibetan gift networks
  ## this causes problems (R crashes) when trying to calculated assortativity on herding group membership
  ## so, as a way to get around this, drop these people from the networks, just for calculating assortativity.nominal
  ##
  #which(!is.na(V(g.gifts.sub)$HG))
  g.gifts.sub.sub = induced_subgraph(graph=g.gifts.sub, which( !is.na(V(g.gifts.sub)$HG) ))
  nodes.sub.sub = subset(nodes, ID %in% V(g.gifts.sub.sub)$name)
  herding_groups = as.integer( factor( V(g.gifts.sub.sub)$HG ) )

  net.stats[i,]$assortativity.hg = assortativity.nominal(g.gifts.sub.sub, types=herding_groups, directed=T)

  ##
  ## calculate network stats for random networks with the same number of nodes and edges as in this site
  ##
  for (sim in 1:n.sims)
  {
    # make a random network
    g.rnd = sample_gnm(n=nrow(nodes.sub), m=length(E(g.gifts.sub)), directed=T)
    herding_groups = sample(1:length(unique(V(g.gifts.sub)$HG)), size = nrow(nodes.sub), replace=T)  # assign herding group membership randomly
    # sexes = sample(1:2, size = nrow(nodes.sub), replace=T)  # assign sex randomly
    # herding_groups[ floor(runif(20, 1, nrow(nodes.sub))) ] = NA

    net.stats.rnd[j,] = c(as.character(pop), sim,
                          length(E(g.rnd)),   # no. observations
                          no.clusters(g.rnd),
                          reciprocity(g.rnd),
                          graph.density(g.rnd),
                          transitivity(g.rnd),
                          modularity(cluster_edge_betweenness(g.rnd)),
                          assortativity.degree(g.rnd, directed=T),  # assorting on gifts?
                          assortativity.nominal(g.rnd, types=herding_groups, directed=T),  # assorting on herding groups?
                          assortativity.nominal(g.rnd, types=nodes.sub$Sex, directed=T))  # assorting on sex?
    j=j+1
  }

  i=i+1
  flog.info(paste0("Finished ", pop))
}

rm(g.gifts.sub, g.gifts.sub.sub, nodes.sub, nodes.sub.sub, i, herding_groups)
rm(g.rnd, j)

# clean up and save obseved stats
net.stats$n.obs = as.integer(net.stats$n.obs)
net.stats$clusters = as.integer(net.stats$clusters)
net.stats$reciprocity = as.numeric(net.stats$reciprocity)
net.stats$density = as.numeric(net.stats$density)
net.stats$transitivity = as.numeric(net.stats$transitivity)
net.stats$assortativity.degree = as.numeric(net.stats$assortativity.degree)
net.stats$assortativity.hg = as.numeric(net.stats$assortativity.hg)
net.stats$assortativity.sex = as.numeric(net.stats$assortativity.sex)
net.stats$modularity = as.numeric(net.stats$modularity)
# str(net.stats)

write.csv(net.stats, file=file.path(results.dir, "gift network statistics - observed.csv"), row.names=F)

# clean up random stats
net.stats.rnd$sim = as.integer(net.stats.rnd$sim)
net.stats.rnd$n.obs = as.integer(net.stats.rnd$n.obs)
net.stats.rnd$clusters = as.integer(net.stats.rnd$clusters)
net.stats.rnd$reciprocity = as.numeric(net.stats.rnd$reciprocity)
net.stats.rnd$density = as.numeric(net.stats.rnd$density)
net.stats.rnd$transitivity = as.numeric(net.stats.rnd$transitivity)
net.stats.rnd$assortativity.degree = as.numeric(net.stats.rnd$assortativity.degree)
net.stats.rnd$assortativity.hg = as.numeric(net.stats.rnd$assortativity.hg)
net.stats.rnd$assortativity.sex = as.numeric(net.stats.rnd$assortativity.sex)
net.stats.rnd$modularity = as.numeric(net.stats.rnd$modularity)
# str(net.stats.rnd)

write.csv(net.stats.rnd, file=file.path(results.dir, "gift network statistics - random networks.csv"), row.names=F)

####################################################################
## Plot observed and randomised network stats
##
flog.info("SNA: plotting network stats")

#' Function to plot network statistics (observed and simulated)
#'
#' @param net.stats.melt
#' @param net.stats.rnd.melt
#' @param cols, Number of columns of facets in the plot (default = 3)
#'
#' @return
#'
plot_net_stats = function(net.stats.melt, net.stats.rnd.melt, cols=3) {
  # format site/country names
  net.stats.melt$Site = stringr::str_to_title(net.stats.melt$Site)
  net.stats.melt$Country = ifelse( stringr::str_sub(net.stats.melt$Site, 1, 1) == "K", "Finnmark", "Tibet")

  net.stats.rnd.melt$Site = stringr::str_to_title(net.stats.rnd.melt$Site)
  net.stats.rnd.melt$Country = ifelse( stringr::str_sub(net.stats.rnd.melt$Site, 1, 1) == "K", "Finnmark", "Tibet")

  net.stats.melt$Site = paste0(net.stats.melt$Country, ": ", net.stats.melt$Site)
  net.stats.rnd.melt$Site = paste0(net.stats.rnd.melt$Country, ": ", net.stats.rnd.melt$Site)

  # plot them
  p = ggplot(net.stats.rnd.melt, aes(x=factor(Site), y=Value)) +
    facet_wrap(~Measure, scales="free_y", ncol=cols) +
    geom_boxplot() +
    geom_point(data=net.stats.melt, aes(x=factor(Site), y=Value), fill="red", shape=23, size=2) +

    geom_blank(data=net.stats.melt) +

    ylab("Simulated/observed network statistics") +
    xlab("") +

    theme_bw() +
    #eliminates baground, gridlines, and chart border
    theme(
      plot.background = element_blank()
      ,panel.grid.major = element_blank()
      ,panel.grid.minor = element_blank()
      ,panel.background = element_blank()
      ,axis.text=element_text(size=12)
      ,axis.title=element_text(size=12)
      ,axis.text.x = element_text(angle = 45, hjust = 1)  # rotate x-axis labels
    )
  p
}

##
## plot all measures
##
# prepare observed stats
net.stats.melt = net.stats %>%
  select(Site, reciprocity, modularity, assortativity.hg, assortativity.sex) %>%
  gather(Measure, Value, reciprocity:assortativity.sex, factor_key=T)

levels(net.stats.melt$Measure) = c("Reciprocity", "Modularity", "Herding group assortment", "Sex assortment")
net.stats.melt$Value = as.numeric(net.stats.melt$Value)

# prepare random stats
net.stats.rnd.melt = net.stats.rnd %>%
  select(Site, reciprocity, modularity, assortativity.hg, assortativity.sex) %>%
  gather(Measure, Value, reciprocity:assortativity.sex, factor_key=T)

levels(net.stats.rnd.melt$Measure) = c("Reciprocity", "Modularity", "Herding group assortment", "Sex assortment")

plot_net_stats(net.stats.melt, net.stats.rnd.melt, cols = 2)
ggsave(filename=file.path("plots", "network stats - observed and simulated - all.png"), width=250, height=200, units="mm")
ggsave(filename=file.path("plots", "network stats - observed and simulated - all.pdf"), width=250, height=200, units="mm")

##
## plot reciprociate and assorment on sex/herding groups only
##
# net.stats.melt = net.stats %>%
#   select(Site, reciprocity, assortativity.hg:assortativity.sex) %>%
#   gather(Measure, Value, reciprocity:assortativity.sex, factor_key=T)
#
# levels(net.stats.melt$Measure) = c("Reciprocity", "Herding group assortment", "Sex assortment")
# #net.stats.melt$Value = as.numeric(net.stats.melt$Value)
#
# # prepare random stats
# net.stats.rnd.melt = net.stats.rnd %>%
#   select(Site, reciprocity, assortativity.hg:assortativity.sex) %>%
#   gather(Measure, Value, reciprocity:assortativity.sex, factor_key=T)
#
# levels(net.stats.rnd.melt$Measure) = c("Reciprocity", "Herding group assortment", "Sex assortment")
#
# plot_net_stats(net.stats.melt, net.stats.rnd.melt)
# ggsave(filename=file.path("plots", "network stats - observed and simulated - reciprocity and assortment.png"), width=300, height=100, units="mm")

##
flog.info("SNA: finished")


a = as.integer(readline(prompt= "Enter a value"))

b = as.integer(readline(prompt= "Enter b value"))

c = as.integer(readline(prompt= "Enter c value"))

n = switch(c, a+b, a-b, a*b, a/b)

print(n)


# tune BRT code to find the optimal parameter values (i.e, lowest mean deviance with n.trees > 1000).
# Zack Oyafuso & Erik Franklin.

##############################
## Tune BRT settings
## Create all combination of
## (1) learning rate (lrt)
## (2) tree complexity (tc)
## (3) bagging rate (bag_rate)
##############################
tune_settings = expand.grid(lrt = c(0.001, 0.005, 0.01), tc = 1:3, bag_rate = c(0.50, 0.75))

###########################################
## Run BRT model under each setting in the tune_settings df
###########################################

############################################
## Register Cores for Parallel Processing
#############################################
cl = makeCluster(detectCores())
registerDoParallel(cl, cores = detectCores())
clusterExport(cl = cl, varlist = 'fishCompDF')

############################################
## Partition BRT work to workers
############################################
x = foreach(i = 1:nrow(tune_settings), .combine = rbind) %dopar% {
  library(dismo); library(gbm)
  test = gbm.step(data = fishCompDF,
                  gbm.x = predictorVars,
                  gbm.y = responseVar, #response
                  family = "gaussian",
                  tree.complexity = tune_settings$tc[i],
                  learning.rate = tune_settings$lrt[i],
                  bag.fraction = tune_settings$bag_rate[i])

  print( c(test$n.trees, test$cv.statistics$deviance.mean) )
}
stopCluster(cl)

#Append number of trees and mean deviance to tune_settings df
tune_settings[,c('n_trees', 'dev_mean')] = x

##############################################
## The "optimal" settings is the combination
## of bagging rate, tree complexity, and learning rate
## that (1) produces > 1000 trees (as reccommended by Elith et al. 2008)
## and (2) has the lowest mean deviance
##############################################

accept_mods = subset(tune_settings, n_trees > 1000)
best_settings = accept_mods[which.min(accept_mods$dev_mean),]

##############################################
## Fit BRT model with the "optimal" settings
##############################################
brt_opt =  gbm.step(data = fishCompDF,
                    gbm.x = predictorVars, #covariates
                    gbm.y = responseVar,
                    family = "gaussian",
                    tree.complexity = best_settings$tc,
                    learning.rate = best_settings$lrt,
                    bag.fraction = best_settings$bag_rate)


#' Diffuse Probability P1 from a starting node.
#'
#' Recursively diffuse probability from a starting node based on the connectivity of the background knowledge graph, representing the likelihood that a variable will be
#'         most influenced by a perturbation in the starting node.
#' @param p1 - The probability being dispersed from the starting node, startNode.
#' @param startNode - The first variable drawn in the node ranking, from which p1 gets dispersed.
#' @param G - A list of probabilities, with names of the list being the node names in the background knowledge graph.
#' @param visitedNodes - The history of previous draws in the node ranking sequence.
#' @param graphNumber - If testing against multiple background knowledge graphs, this is the index associated with the adjacency matrix that codes for G. Default value is 1.
#' @param verbose - If debugging or tracking a diffusion event, verbose=TRUE will activate print statements. Default is FALSE.
#' @return G - A list of returned probabilities after the diffusion of probability has truncated, with names of the list being the node names in the background knowledge graph.
#' @export graph.diffuseP1
#' @keywords generative methods
#' @keywords diffusion event
#' @keywords network walker
#' @examples
#' # Read in any network via its adjacency matrix
#' tmp=matrix(1, nrow=100, ncol=100)
#' for (i in 1:100) {
#'   for (j in 1:100) {
#'     tmp[i, j]=rnorm(1, mean=0, sd=1)
#'   }
#' }
#' colnames(tmp)=sprintf("MolPheno%d", 1:100)
#' ig=graph.adjacency(tmp, mode="undirected", weighted=TRUE, add.colnames="name")
#' V(ig)$name=tolower(V(ig)$name)
#' adjacency_matrix=list(as.matrix(get.adjacency(ig, attr="weight")))  # Must have this declared as a GLOBAL variable!!!!!
#' # Set other tuning parameters
#' p0=0.1  # 10% of probability distributed uniformly
#' p1=0.9  # 90% of probability diffused based on edge weights in networks
#' thresholdDiff=0.01
#' G=vector(mode="list", length=length(V(ig)$name))
#' names(G)=V(ig)$name
#' G=lapply(G, function(i) i[[1]]=0)
#' startNode=names(G)[1]
#' visitedNodes=G[1]
#' probs_afterCurrDraw=graph.diffuseP1(p1, startNode, G, visitedNodes, 1, TRUE)
graph.diffuseP1=function (p1, startNode, G, visitedNodes, graphNumber=1, verbose=FALSE) {
  if (verbose==TRUE) {
    print(sprintf("%sprob. to diffuse:%f startNode: %s, visitedNodes: %s",
                  paste(rep("   ", length(visitedNodes) - 1), collapse=""),
                  p1, startNode, toString(visitedNodes)))
  }
  adj_mat=adjacency_matrix[[graphNumber]]
  startNodeNeighbors=names(which(abs(adj_mat[, startNode])> 0))
  startNodeUnvisitedNeighbors=startNodeNeighbors[!(startNodeNeighbors %in% visitedNodes)]
  vN=visitedNodes[which(visitedNodes != startNode)]
  extendedConnections=NULL
  if (length(vN)>0 && length(startNodeUnvisitedNeighbors)==0) {
    adj_matAfter=adj_mat[-which(rownames(adj_mat) %in% vN), -which(colnames(adj_mat) %in% vN)]
    connections=adj_mat[startNode, ]
    connectionsYes=connections[which(abs(connections)>0)]
    connectionsNo=connections[intersect(which(connections==0), which(!(names(connections) %in% c(startNode, vN))))]
    if (length(connectionsNo)>0) {
      for (n1 in 1:length(connectionsNo)) {
        if (length(connectionsYes)>0) {
          for (n2 in 1:length(connectionsYes)) {
            if (abs(adj_mat[names(connectionsYes[n2]), names(connectionsNo[n1])])>0) {
              connectionsNo[n1]=adj_mat[names(connectionsYes[n2]), names(connectionsNo[n1])]
              extendedConnections=c(extendedConnections, connectionsNo[n1])
            }
          }
        }
      }
    }
    if (length(extendedConnections)>0) {
      adj_matAfter[startNode, names(extendedConnections)]=extendedConnections
      adj_matAfter[names(extendedConnections), startNode]=extendedConnections
    }
    adj_mat=adj_matAfter
  }
  startNodeNeighbors=names(which(abs(adj_mat[, startNode])>0))
  startNodeUnvisitedNeighbors=startNodeNeighbors[!(startNodeNeighbors %in% visitedNodes)]
  if (length(startNodeUnvisitedNeighbors)>0 || length(extendedConnections)>0) {
    weighted_edges.sum=sum(abs(adj_mat[which(rownames(adj_mat) %in% startNodeUnvisitedNeighbors), startNode]))
    if (verbose==TRUE) {print(sprintf("%sWeighted_edges.sum=%f", paste(rep("   ", length(visitedNodes) - 1), collapse=""), weighted_edges.sum))}
    z=1
    while (z<=length(startNodeUnvisitedNeighbors)) {
      inherited.probability=p1*abs(adj_mat[startNodeUnvisitedNeighbors[z], startNode])/weighted_edges.sum
      G[[startNodeUnvisitedNeighbors[z]]]=G[[startNodeUnvisitedNeighbors[z]]]+inherited.probability
      if (verbose==TRUE) {
        print(sprintf("%sadded diffused  probability %f to child #%d: %s", paste(rep("   ", length(visitedNodes) - 1), collapse=""), inherited.probability, z, startNodeUnvisitedNeighbors[z]))
      }
      nNeighbors=G[names(which(abs(adj_mat[, startNodeUnvisitedNeighbors[z]])> 0))]
      if (length(nNeighbors)>0 && inherited.probability/2>thresholdDiff && ((length(visitedNodes) + 1) < length(G))) {
        G[[startNodeUnvisitedNeighbors[z]]]=G[[startNodeUnvisitedNeighbors[z]]]-inherited.probability/2
        if (verbose==TRUE) {
          print(sprintf("%ssubtracted %f from startNode's neighbor #%d: %s and sent to its own neighbors.",
                        paste(rep("   ", length(visitedNodes) - 1), collapse=""), inherited.probability/2,
                        z, startNodeUnvisitedNeighbors[z]))
        }
        G=graph.diffuseP1(inherited.probability/2,
                            startNodeUnvisitedNeighbors[z], G, c(visitedNodes, startNodeUnvisitedNeighbors[z]), graphNumber,
                            verbose=FALSE)
      }
      z=z + 1
    }
  } else {
    if (verbose==TRUE) {print("startNode is stranded with its visited neighbors, or is a singleton. Diffuse p1 uniformly amongst all unvisited nodes")}
    G[!(names(G) %in% visitedNodes)]=unlist(G[!(names(G) %in% visitedNodes)]) + p1/(length(G) - length(visitedNodes))
  }
  return(G)
}


PATH <- '00_data/GELD.CSV'

GELD <- read.csv(PATH)
head(GELD)
str(GELD)

plot(GELD[1:6], col = as.numeric(GELD$ECHT) + 1)
with(GELD, plot(RIGHT, DIAGONAL, col = as.numeric(ECHT) + 1))
with(GELD, plot(TOP, DIAGONAL, col = as.numeric(ECHT) + 1))

IS_ECHT <- ifelse(GELD$ECHT == "WAHR", 1, 0)

GELD_FORMULA = IS_ECHT ~ GELD$DIAGONAL
GELD_MODEL = glm(GELD_FORMULA, data = GELD, family = binomial)

B0 <- GELD_MODEL$coefficients[1]
B1 <- GELD_MODEL$coefficients[2]
plot(GELD_FORMULA)
curve(1 / (1 + exp( - B0 - B1 * x)), add = TRUE)


library(ggplot2) # Import library
sal = read.csv("/Salaries.csv", header = TRUE) # Open CSV

#Parse in Data from CSV

## Scatter Plot with Gradient##
ggplot(sal, aes(x = Position, y = Salary))+
  geom_point(aes(color = Salary), size = 3) +
  scale_color_gradientn(colors = c("#00AFBB", "#E7B800", "#FC4E07")) +
  theme(legend.position = "right")

## Scatter Plot with with Legend + Colors##
ggplot(sal, aes(x = Position, y = Salary))+
  geom_point(aes(color = Position), alpha = 0.25) +
  scale_color_manual(values = c("#00AFBB", "#E7B800", "#FC4E07")) +
  scale_size(range = c(0.5, 12))  # Adjust the range of points size

## Scatter Plot with with Legend + Colors + Size Legend##
ggplot(sal, aes(x = Position, y = Salary))+
  geom_point(aes(color = Position, size = Yrs.service), alpha = 0.25) +
  scale_color_manual(values = c("#00AFBB", "#E7B800", "#FC4E07")) +
  scale_size(range = c(0.5, 12))  # Adjust the range of points size


# Fit SSD to Silver dataset

# Copyright 2017 Province of British Columbia
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and limitations under the License.

# We compare fits for the distributions with AIC
# Refer to https://cran.r-project.org/web/packages/fitdistrplus/vignettes/FAQ.html
# for information on the fitdistrplus package.
# Refer to AICcmodavg package for details on creating the AIC tables and
# how to do model averaging.

# Load the necessary libraries
library(AICcmodavg)
library(actuar) # for the burr distribution
library(FAdist) # for log-logistic
library(fitdistrplus)
library(ggplot2)
library(grid)
library(gridGraphics)
library(plyr)   # for doing a separate analysi by chemical
library(VGAM) # for the gompertz, pareto, gumbel distributions

options(width=200)

source("mygofstat.r")  # corrects and error in the code in the fistdistr package (groan)

#load test data
endpoints<-read.csv("SSDsilver.csv",header=TRUE,as.is=TRUE, strip.white=TRUE)

head(endpoints)

xtabs(~Chemical, data=endpoints, exclude=NULL, na.action=na.pass)

# create a directory for plots
dir.create(file.path("Plots"))

#use descdist function from fitdistrplus package to identify candidate distributions - create a Cullen Frey graph
sumstats <- plyr::ddply(endpoints, "Chemical", function(x, boot){
    # create the individual plots
    png(file.path("Plots",paste(x$Chemical,".png",sep="")), h=6, w=6, units="in", res=300)
       res <- descdist(x$Conc,discrete=FALSE, boot=boot)
    dev.off()
    # return the summary statistics as a dataframe, rather than a list
    attr(res, "class") <- NULL # remove class attribute from results
    data.frame(res)
}, boot=100)

# summary statistics
sumstats

# create list of possible distributions
fit.list <- list( lnorm  = list(data=NULL, distr="lnorm",  method="mle"),
                  llog   = list(data=NULL, distr="llog",   method="mle"), # log logistic
                  gomp   = list(data=NULL, distr="gompertz",method="mle"),
                  lgumbel= list(data=NULL, distr="lgumbel",method="mle"), # log gumbel
                  gamma  = list(data=NULL, distr="gamma",  method="mle"),
#                  pareto = list(data=NULL, distr="pareto", method="mle"),
                  weibull= list(data=NULL, distr="weibull",method="mle")
#                  burr   = list(data=NULL, distr="burr",   method="mle")
                 )

# define log-gumbel distribution
# These functions are needed because this is a non-standard distribution
dlgumbel <- function(x, location=0, scale=0, log=FALSE){
            fx <- dgumbel(log(x), location=location, scale=scale, log=FALSE)/x
            if(log) fx <- log(fx)
            fx}
qlgumbel <- function(p, location=0, scale=0, lower.tail=TRUE, log.p=FALSE){
            if(log.p) p<- exp(p)
            if(!lower.tail) p <- 1-p
            exp( qgumbel(p, location=location, scale=scale))}
plgumbel <- function(q, location=0, scale=0, lower.tail=TRUE, log.p=FALSE){
             Fq <- pgumbel(log(q), location=location, scale=scale)
             if(!lower.tail) Fq <- 1-Fq
             if(log.p) Fq <- log(Fq)
             Fq}
rlgumbel <- function(n, location=0, scale=0){ exp(rgumbel(n, location=location, scale=scale))}

#endpoints <- endpoints[ endpoints$Chemical=="Boron_CCME",]  # for testing to fit only one chemical

# Fit each distribution from the list to each chemical
fit.all <- plyr::dlply(endpoints, "Chemical", function(x, probs=c(.05,.10), nboot=1000){
      cat("Analyzing ", x[1,"Chemical"],"\n")
      # fit all of the distributions in the list to this data. If
      # a distribution fitting does not converge, then it returns NULL
      dist.fits <- plyr::tryapply(fit.list, function(distr, x){
           distr$data <- x$Conc
           if(distr$distr=="burr"){
              distr$start <-list(shape1=4, shape2=1, rate=1)
              distr$method<- "mme"
              distr$order <- 1:3
              distr$memp  <- function (x, order){sum(x^order)}
           }
           if(distr$distr=='gamma'){
             distr$start <- list(scale=var(x$Conc)/mean(x$Conc),
                                    shape=mean(x$Conc)^2/var(x$Conc)^2)
           }
           if(distr$distr == 'gompertz'){
              # use the vgam to get the parameters of the fit
              fit <- vglm(Conc~1, gompertz, data=x)
              distr$start <- list(shape=exp(unname(coef(fit)[2])), scale=exp(unname(coef(fit)[1])) )
            }
           if(distr$distr=='lgumbel'){
             distr$start <- list(location=mean(log(x$Conc)), scale=pi*sd(log(x$Conc))/sqrt(6))
           }
           if(distr$distr=='pareto'){ #use the vgam package to estimate the starting values
             fit<- vglm(Conc~1, paretoff, data=x)
             distr$start  <- list(shape=exp(unname(coef(fit))))
             distr$fix.arg<- list(scale=fit@extra$scale)
           }
           if(distr$distr=="llog" ){ # log=logistic
              distr$start <- list(shape=mean(log(x$Conc)), scale=pi*sd(log(x$Conc))/sqrt(3))
           }
           cat("   Fitting ", distr$distr,"\n")
           res <- do.call("fitdist", distr)
           print(res)
           res
      },x=x)

      # Get the aic table by hand.
      aic.table <- plyr::ldply(dist.fits, function(x){
        # extract the distribution name and AIC value
        aic <- x$aic
        distname <- x$distname
        aicc <- AICcmodavg::AICc(x) # conflict with VGAM package
        nparm <- length(x$estimate)
        data.frame(distname=distname, aic=aic, k=nparm, aicc=aicc)
      })
      aic.table <- aic.table[order(aic.table$aicc),]
      aic.table$delta.aicc <- aic.table$aicc - min(aic.table$aicc)
      aic.table$weight     <- round(exp(-aic.table$delta.aicc/2)/sum(exp(-aic.table$delta.aicc/2)),3)

      # make predictions for HC5 based on all of the distributions
      # Include a bootstrap approximation to the se of the estimates
      pred.table <- plyr::ldply(dist.fits, function(x, probs=.05, nboot=1000){
        distname <- x$distname
        pred     <- quantile(x, probs)
        fit.boot <- bootdist(x, niter=nboot)
        #browser()
        se       <- apply(quantile(fit.boot, probs=probs)$bootquant, 2, sd, na.rm=TRUE)
        lcl      <- quantile(fit.boot, probs=probs)$quantCI[1,]
        ucl      <- quantile(fit.boot, probs=probs)$quantCI[2,]
        #cat("pred.table", distname, pred, se, lcl, ucl, "\n")
        data.frame(distname=distname, quantile=probs, pred=unlist(pred$quantiles), se=se, lcl=unlist(lcl), ucl=unlist(ucl) )
      }, probs=probs, nboot=nboot)

      pred.table <- merge(pred.table, aic.table[,c("distname","weight")])

      # compute the model averaged quantiles, the model averaged lcl and ucl, and unconditional se
      q.modavg <- plyr::ddply(pred.table, "quantile", function(x){
        avg.pred <- sum(x$pred * x$weight)
        avg.lcl  <- sum(x$lcl  * x$weight)
        avg.ucl  <- sum(x$ucl  * x$weight)
        # get the unconditional se
        avg.u.se <- sqrt(sum(x$weight * (x$se^2 + (x$pred-avg.pred)^2)))
        data.frame(avg.pred=avg.pred, avg.u.se=avg.u.se, avg.lcl=avg.lcl, avg.ucl=avg.ucl)
      })
      q.modavg

      # make the cdf plot comparing all of the fits
      # capture the plot and save it
      # get the list of distributions that were fit
      dist.names <- plyr::laply(dist.fits, function(x) x$distname)
      cdfcomp(dist.fits, xlogscale=TRUE, legendtext=dist.names,
              main=paste("Empirical and theoretical CDF's - ",x[1,"Chemical"],sep=""))
      gridGraphics::grid.echo()
      cdf.comp.plot <- grid::grid.grab()

      #compute the goodmess of fit statistics - NOTE this does not work for burr distribution, not sure why...
      # must check to see if more than one distribution was fit - groan.
      # Also had to fix an error in compute p-value for chi2 test when df=0
      if(length(dist.fits) ==1) {gof.stat <- mygofstat(dist.fits[[1]], fitnames=dist.names)}
      if(length(dist.fits) >1 ) {gof.stat <- mygofstat(dist.fits,fitnames =dist.names)}

      # return the entire fitting stuff for this distibution
      list(Chemical=x[1,"Chemical"], dist.fits=dist.fits, aic.table=aic.table, pred.table=pred.table,
           q.modavg=q.modavg,
           cdf.comp.plot =cdf.comp.plot,
           gof.stat =gof.stat)
})

display.results <- function(x){
   # display the results from the fitting functions
   cat("\n\n\n\n\n\n\n\n\n *******************************************************************\n")
   cat("\n\nResults when applied to ", x$Chemical, "\n")
   cat("\n\nAICc table \n")
   print(x$aic.table)

   cat("\n\nPredictions of endpoints \n")
   print(x$pred.table)

   cat("\n\nModel averaged endpoint \n")
   print(x$q.modavg)

   cat("\n\nCDF comparative plot\n")
   grid.newpage()
   grid.draw(x$cdf.comp.plot)

   cat("\n\nGoodness of fit statistics\n")
   print(x$gof.stat)

}

# display all of the results from all of the Chemicals
plyr::l_ply(fit.all, display.results)

# save the comparative plot
plyr::l_ply(fit.all, function(x){
   file.name=file.path("Plots",paste(x$Chemical,"-comparative-plot.png",sep=""))
   png(file.name, h=6, w=6, units="in", res=300)
      grid.newpage()
      grid.draw(x$cdf.comp.plot)
   dev.off()
})