library('ineq')
library('ggplot2')
args <- commandArgs(trailingOnly = TRUE)

if (length(args) != 2) {
    print('Usage: Rscript plot_lorenz_curve_for_defect_densities.r <path/to/data_dir> <project_name>')
    print('E.g. : Rscript plot_lorenz_curve_for_defect_densities.r data/ bitcoin')
} else if (length(args) == 2) {
    data_dir <- args[1]
    project_name <- args[2]

    instance_data_dir <- paste(data_dir, 'ast_node_instances', sep='/')
    if (!dir.exists(instance_data_dir)) {
        print(paste('Error! Instance data for project `', project_name, '` not found. Aborting!', sep=''))
        break
    }

    csv_file_path = paste(instance_data_dir, '/', project_name, '.loops.bugdata.csv', sep='')
    csv_data = read.csv(csv_file_path)

    node_types = c('do', 'while', 'for')
    for (nt in node_types) {

        plots_dir <- paste('plots', 'rq3', project_name, sep='/')
        if (!dir.exists(plots_dir)) {
            dir.create(plots_dir, recursive=TRUE)
        }

        csv_data_nt_only = csv_data[which(csv_data$node_type==nt & csv_data$num_overall_bugs>0, ), c('avg_loc', 'num_overall_bugs')]

        png_file_name = paste(plots_dir, '/', nt, '.png', sep='')

        lc = Lc(x=csv_data_nt_only$num_overall_bugs, n=csv_data_nt_only$avg_loc)
        diagonal = data.frame(x=seq(0, 1.0, length.out=length(lc$p)), y=seq(0, 1.0, length.out=length(lc$p)))

        ggplot(data.frame(lines_covered=1-lc$p, bugs_encountered=1-lc$L), aes(x=lines_covered, y=bugs_encountered)) + geom_line(color='darkred') + geom_line(aes(x=diagonal$x, y=diagonal$y))
        ggsave(png_file_name)

        # gini = ineq(dds$dd, type='Gini')
    }
}


# load packages needed to run this code
library(ggplot2)
library(dplyr)
library(tidyr)
library(cowplot)
library(gganimate)

# code used from this page on stackoverflow:
# https://stackoverflow.com/questions/8082429/plot-a-heart-in-r
# I cleaned it up

# make a data frame for background colors
df_background <- data.frame(
  xmin = -20, ymin = -20, xmax = 20, ymax = 20, x = 0, y = 0,
  fill = c("#ffaaaa", "#e37070", "#c7004c", "#8f1537"),
  state = c(1, 2, 3, 4)
)

# generate coordinates for a heart
df <- data.frame(t = seq(0, 2 * pi, by = 0.01))

heart <-
  df %>%
  mutate(
    x = 16 * sin(t)^3,
    y = 13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t)
  )

p_heart <-
  ggplot() +
  geom_rect(
     data = df_background,
     ggplot2::aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = fill, group = 1, x = 1, y = 1),
     color = NA
  ) +
  geom_polygon(
    data = heart,
    ggplot2::aes(
      x = x,
      y = y,
    ),
    fill = "white",
    alpha = 0.5
  ) +
  transition_states(state, transition_length = 5, state_length = 0) +
  scale_fill_identity() +
  scale_y_continuous(limits = c(-20, 20)) +
  scale_x_continuous(limits = c(-20, 20)) +
  coord_fixed(expand = FALSE) +
#  annotate("text", label = "Dearest Eric,\nHappy Valentine's Day!\nYou fill my life with so much joy, laughter,\nkindness, adventures, and love!\nI love you from the bottom of my heart, and\nI'm very happy to have you.\nYour beet,\nDariya", x = 0, y = -2, color = "white", size = 6) +
  theme_void()

# animate
animate(p_heart,
        device = "png",
        width = 600,
        height = 600)

# save as gif
anim_save("heart.gif")


library('tidyverse')
library('ggplot2')
library('Rmisc')

read_in_and_preprocessor <- function(file_loc) {
    df <- read.csv(file_loc) # read as CSV

    df$Replicate <- as.factor(df$Replicate) # make sure that replicate isn't treated as numbers
    df$Treatment <- as.factor(df$Treatment) # factorize everything else
    df$Treatment <- relevel(df$Treatment, "siLuc") #siLuc is always the first factor
    df$Substrate <- as.factor(df$Substrate)

    # Normalize all columns to 100% abundance
    df$X120 <- df$X120/df$X0
    df$X240 <- df$X240/df$X0
    df$X360 <- df$X360/df$X0
    df$X0 <- df$X0/df$X0

    # Pivot to a version that's more amenable to ggplot
    df <- pivot_longer(df, cols=c("X0", "X120", "X240", "X360"), names_to="Time", values_to="Abundance")

    # Remove the X added to Time column and convert to an integer
    df$Time <- sub(".", "", df$Time)
    df$Time <- as.integer(df$Time)

    return(df)
}

find_half_life <- function(df){ # returns half life in minutes
    df_model = lm(log(Abundance) ~ Time, data=df)
    return(log(0.5)/coef(df_model)[2])
}

find_se <- function(df){
    df_summary <- summarySE(df,
                            measurevar="Abundance",
                            groupvars=c("Time", "Substrate", "Treatment"),
                            na.rm=T)
    return(df_summary)
}

find_R2 <- function(df){
    return(cor(df$Time, df$Abundance)^2)
}

plot_overview <- function(df) { # plots all data in df as facet wrapped table
    ggplot(df, aes(x=Time, y=log(Abundance), color=Treatment)) +
        geom_point() +
        facet_wrap(~ Substrate + Replicate) +
        geom_smooth(method="lm", formula=(y~x), se=F)
}

plot_paper_curve_by_treatment <- function(df, tim_colors=c( "#A4A4A5", "#000000", "#00BFFF", "#F08080")) { # plot curve formatted for paper
    df_summary <- summarySE(df,
                            measurevar="Abundance",
                            groupvars=c("Time", "Substrate", "Treatment"),
                            na.rm=T)
    plt<-ggplot(df_summary, aes(x=Time, y=log(Abundance), color=Treatment)) +
        geom_point(size=3) +
        geom_smooth(method="lm", formula=(y~x), size=1.3, se=F) +
        geom_errorbar(aes(ymin=log(Abundance-se), ymax=log(Abundance+se), width=5)) +
        theme_minimal() +
        theme(panel.grid.major.y=element_blank(),
                panel.grid.minor.x=element_blank(),
                panel.grid.major.x=element_blank(),
                panel.grid.minor.y=element_blank(),
                axis.ticks=element_line(),
                panel.border=element_rect(size=1, fill=NA, color='lightgrey'),
                text=element_text(size=10),
                legend.title=element_blank()) +
        scale_y_continuous(breaks=c(0.000001,-0.105360516, -0.223143551, -0.356674944, -0.510825624, -0.693147181, -0.916290732, -1.203972804, -1.609437912, -2.302585093),
                            label=c(100,90,80,70,60,50,40,30,20,10), limits=c(-1.62, 0.1) ) +
        scale_x_continuous(breaks=c(0,120,240,360)) +
        scale_color_manual(values=tim_colors) +
        ylab("mRNA Abundance (%)") +
        xlab("Time (min)")

        return(plt)

}

plot_paper_curve_by_substrate <- function(df, tim_colors=c( "#A4A4A5", "#000000", "#00BFFF", "#F08080")) { # plot curve formatted for paper
    df_summary <- summarySE(df,
                            measurevar="Abundance",
                            groupvars=c("Time", "Substrate", "Treatment"),
                            na.rm=T)
    plt<-ggplot(df_summary, aes(x=Time, y=log(Abundance), color=Substrate)) +
        geom_point(size=3) +
        geom_smooth(method="lm", formula=(y~x), size=1.3, se=F) +
        geom_errorbar(aes(ymin=log(Abundance-se), ymax=log(Abundance+se), width=5)) +
        theme_minimal() +
        theme(panel.grid.major.y=element_blank(),
                panel.grid.minor.x=element_blank(),
                panel.grid.major.x=element_blank(),
                panel.grid.minor.y=element_blank(),
                axis.ticks=element_line(),
                panel.border=element_rect(size=1, fill=NA, color='lightgrey'),
                text=element_text(size=10)) +
        scale_y_continuous(breaks=c(0.000001,-0.105360516, -0.223143551, -0.356674944, -0.510825624, -0.693147181, -0.916290732, -1.203972804, -1.609437912, -2.302585093),
                            label=c(100,90,80,70,60,50,40,30,20,10), limits=c(-1.9, 0.1) ) +
        scale_x_continuous(breaks=c(0,120,240,360)) +
        scale_color_manual(values=tim_colors) +
        ylab("mRNA Abundance (%)") +
        xlab("Time (min)") +

        return(plt)

}


#' viscosity
#'
#' Calculates  the viscosity of air [kg/(m s)] given air temperature in Kelvin degrees.
#'
#' @param tk numeric Air temperature in degK.
#' @return air viscosity
#'
#'
#' @author  Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  viscosity
#' @references Oke T R, Boundary Layer Climate,Routledge Atmosphere, Weather and Climate, 2th edition, p.373.
#' @export
#'
#'
#'
#'

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


devtools::load_all()
library(ggplot2)
library(stringr)
library(dplyr)
library(fixedincome)

df <- futures_get(
  first_date = "2021-01-01",
  last_date = Sys.Date(),
  by = 5,
  cache_folder = cache_folder
)

di1_futures <- df |>
  filter(commodity == "DI1") |>
  mutate(
    maturity_date = maturity2date(maturity_code),
    fixing = following(maturity_date, "Brazil/ANBIMA"),
    business_days = bizdays(refdate, maturity_date, "Brazil/ANBIMA"),
    adjusted_tax = rates("discrete", business_days / 252, 100000 / price)
  ) |>
  filter(business_days > 0)

di1_futures |>
  filter(symbol %in% c("DI1F23", "DI1F33")) |>
  ggplot(aes(x = refdate, y = adjusted_tax, color = symbol, group = symbol)) +
  geom_line() +
  geom_point() +
  labs(
    title = "DI1 Future Rates - Nominal Interest Rates",
    caption = str_glue("Data imported using rb3 at {Sys.Date()}"),
    x = "Date",
    y = "Interest Rates",
    color = "Symbol"
  ) +
  scale_y_continuous(labels = scales::percent)

dap_futures <- df |>
  filter(commodity == "DAP") |>
  mutate(
    maturity_date = maturity2date(maturity_code, "15th day"),
    fixing = following(maturity_date, "Brazil/ANBIMA"),
    business_days = bizdays(refdate, maturity_date, "Brazil/ANBIMA"),
    adjusted_tax = rates("discrete", business_days / 252, 100000 / price)
  ) |>
  filter(business_days > 0)

dap_futures |>
  filter(symbol %in% c("DAPF23", "DAPK35")) |>
  ggplot(aes(x = refdate, y = adjusted_tax, group = symbol, color = symbol)) +
  geom_line() +
  geom_point() +
  labs(
    title = "DAP Future Rates - Real Interest Rates",
    caption = str_glue("Data imported using rb3 at {Sys.Date()}"),
    x = "Date",
    y = "Interest Rates",
    color = "Symbol"
  ) +
  scale_y_continuous(labels = scales::percent)

# ----

forward_factor <- di1_futures |>
  filter(symbol %in% c("DI1F23", "DI1F33")) |>
  select(symbol, price, refdate) |>
  tidyr::spread(symbol, price) |>
  mutate(forward_factor = DI1F23 / DI1F33)

business_days <- di1_futures |>
  filter(symbol %in% c("DI1F23", "DI1F33")) |>
  select(symbol, business_days, refdate) |>
  tidyr::spread(symbol, business_days) |>
  mutate(business_days = DI1F33 - DI1F23)

forward_factor[["business_days"]] <- business_days[["business_days"]]

forward_rates <- forward_factor |>
  mutate(
    fwd_rate = rates("discrete", business_days / 252, forward_factor)
  )

# ----

infl_futures <- df |>
  filter(symbol %in% c("DI1F35", "DAPK35")) |>
  mutate(
    maturity_date = if_else(commodity == "DI1",
      maturity2date(maturity_code), maturity2date(maturity_code, "15th day")
    ),
    fixing = following(maturity_date, "Brazil/ANBIMA"),
    business_days = bizdays(refdate, maturity_date, "Brazil/ANBIMA"),
    adjusted_tax = rates("discrete", business_days / 252, 100000 / price)
  ) |>
  arrange(refdate)

infl_expec <- infl_futures |>
  select(symbol, price, refdate) |>
  tidyr::spread(symbol, price) |>
  mutate(inflation = DAPK35 / DI1F35 - 1)

infl_expec |>
  ggplot(aes(x = refdate, y = inflation)) +
  geom_line() +
  geom_point()


example <- matrix(c(1,2,3,4,5,6,7,8), nrow=4, ncol=2)


#
# Secure Digitalisation Monte Carlo Simulation Script
#
# This script runs a Monto Carlo simulation using breach likelihood and cost
# figures derived from the Cyber Security Breaches Survey 2020 (CSBS).
#	This script is an unfinished prototype, and has since been superseded by
# `montecarlo.py`.
#
# Acknowledgements: Dr Dan Prince & Dr Chris Sherlock
#

masses = c(0.54, 0.1058, 0.1012, 0.0966, 0.069, 0.0368, 0.0414)
boundaries = c(1, 2, 8, 18, 80, 400, 8000)

Fs = cumsum(masses)
plot(log(boundaries), log(1 - Fs))

xs = log(boundaries)
ys = log(1 - Fs)
fit = lm(ys ~ xs)
summary(fit)

alogb = fit$coeff[1]
a = -fit$coeff[2]
b = exp(alogb/a)
print(a)
print(b)

n = 10000

us = runif(n)
xs = b / (1 - us)^(1 / a)
print()
p0 = mean(xs < boundaries[1])
p1 = mean(xs < boundaries[2]) - p0
p2 = mean(xs < boundaries[3]) - p0 - p1
p3 = mean(xs < boundaries[4]) - p0 - p1 - p2
p4 = mean(xs < boundaries[5]) - p0 - p1 - p2 - p3
p5 = mean(xs < boundaries[6]) - p0 - p1 - p2 - p3 - p4
ps = c(p0, p1, p2, p3, p4, p5, 1 - (p0 + p1 + p2 + p3 + p4 + p5))

print(ps)
print(masses)

nattacks = floor(xs)
hist(log10(nattacks),
     main = "Histogram of Number of Attacks/Breaches Over 12 Months",
     xlab = expression("Number of Attacks (log"[10]*")"),
     ylab = "Frequency",
     breaks = 0:12)

# Plots the distribution for the average cost of breach(es) over 12 months

mean = 3230
median = 274

logstd = sqrt(2 * (log(mean) - if (median == 0) 0 else log(median)))
std = exp(1)^logstd

curve(dlnorm(x, log(mean), log(std)), from=1, to=5000,
      main = "Average annual breach cost distribution",
      xlab = 'Cost (£)',
      ylab = 'Density',
      lwd = 2)

# Runs the MonteCarlo simulation

simulateCosts <- function(n) {
  return(if (n >= 1) sum(rlnorm(n, loc, shape)) else 0)
}

n = 10000

loc <- log(mean^2 / sqrt(std^2 + mean^2))
shape <- sqrt(log(1 + (std^2 / mean^2)))

numAttacks <- sample(log10(nattacks), n)
results <- sapply(numAttacks, simulateCosts)

hist(results,
     main = "Histogram of Total Costs Over 12 Months (Monte Carlo sim)",
     xlab = "Total cost (£)")

d <- density(results)
plot(d,
     main="Density of Total Costs Over 12 Months (Monte Carlo sim)",
     xlab=expression("Total Cost (£)"),
     ylab="Density")

# Get loss exceedance
# TODO: needs to be prettier, but `evaluate::loss_exceedance_curve()` is broken

maxValue = 2500
numOver <- length(results[results > maxValue])
risk = numOver/n

plot(d,
     main="Loss Exceedance (Monte Carlo sim)",
     xlab=expression("Total Cost (£)"),
     ylab="Density")

abline(v = maxValue, col="red", lwd=3, lty=2)
text(3000, 4e-04, labels=paste(floor(risk*100), "% chance of ≥£", maxValue, " losses"), adj=c(0, 0.5))


#generate data
x <- runif(400); y <- 4*x + 5;
noise <- rnorm(400, 0, 3*x + 0.5)
y <- y + noise

library(mgcv)
fitgam <- mgcv::gam(y~s(x))
#what scam::scam supposed to do
try(mgcv::gam(y~s(x), start = coef(fitgam)))

require(scam)
fitscam <- scam::scam(y ~ s(x))
# error occurs
try(scam::scam(y ~ s(x,bs="mpi"), start = coef(fitscam)))
# take weird starting values
scam(y ~ s(x,bs="mpi"), start = 1:400)


library(ggplot2)
data <- data.frame(V1 <- rnorm(700), V2=sample(LETTERS[1:3], 700, replace=TRUE))
ggplot(data, aes(x=V1)) +
stat_bin(aes(y=..density..)) +
stat_function(fun=dnorm) +
facet_grid(V2~.)


# load packages
suppressMessages({
  library(CHNOSZ)
  library(dplyr)
  library(comprehenr)
  library(stringr)
})

# print messages if 'verbose' setting >= vlevel of message.
vmessage <- function(m, vlevel, verbose){
  if(verbose >= vlevel){
    print(m)
  }
}

# function to round up the last digit of a four-digit number
# e.g., 52.6112 becomes 52.6113.
# This function is useful for reporting rounded PSAT pressures that keeps water in the liquid phase
roundup <- function(x, n){
  return(round(x, n) + 10^-n)
}

check_TP_grid <- function(grid_temps, grid_press, P1, water_model="SUPCRT92", check_for_errors=TRUE, verbose=1){

  grid_temps <- as.numeric(grid_temps)

  # set water model
  suppressMessages(water(water_model))

  # round grid temperatures to four decimal places
  grid_temps <- round(grid_temps, 4)

  # calculate PSAT pressure if specified by user or if pressure grid
  # has a number of values that does not equal temperature grid length.
  if(tolower(grid_press) == "psat"){
      vmessage("Calculating pressure grid along liquid-vapor saturation curve...", 2, verbose)
      grid_press <- water("Psat", T=grid_temps+273.15, P1=P1)[[1]]
  }else{
    grid_press <- as.numeric(grid_press)
  }

  # check TP polynomial
  if(length(grid_temps) == 8){
    # third order polynomial for the first T-P range
    poly_coeffs_1 <- lm(grid_press[1:4] ~ poly(grid_temps[1:4], 3, raw=T))$coefficients

    # fourth order polynomial for the second T-P range
    poly_coeffs_2 <- lm(grid_press[4:8] ~ poly(grid_temps[4:8], 4, raw=T))$coefficients

    for(T in grid_temps[1:4]){
      if(is.na(poly_coeffs_1[1] + poly_coeffs_1[2]*T + poly_coeffs_1[3]*T^2 + poly_coeffs_1[4]*T^3)){
        stop(paste0("Error: Could not compute the coefficients of an interpolating polynomial
                     for the first four values of the temperature grid: [", paste(grid_temps[1:4], collapse=", "), "]."))
      }
    }
    for(T in grid_temps[4:8]){
      if(is.na(poly_coeffs_2[1] + poly_coeffs_2[2]*T + poly_coeffs_2[3]*T^2 + poly_coeffs_2[4]*T^3)){
        stop(paste0("Error: Could not compute the coefficients of an interpolating polynomial
                     for the last five values of the temperature grid: [", paste(grid_temps[4:8], collapse=", "), "]."))
      }
    }
  }else{
    poly_coeffs_1 <- 'None'
    poly_coeffs_2 <- 'None'
  }

  if(check_for_errors){
    # check that water is a liquid at each T-P point
    if(length(grid_press) > 1){
      TP_grid_errors <- c()
      for(i in 1:length(grid_temps)){

        tryCatch({
          psat_press <<- suppressMessages(water("Psat", T=grid_temps[i]+273.15, P1=P1)[[1]])
        }, error=function(e){
          psat_press <<- NA
        })
        if(is.na(psat_press)){
          tryCatch({
              rho_val <<- suppressMessages(water("rho", T=grid_temps[i]+273.15, P=grid_press[i], P1=P1)[[1]])
          }, error=function(e){
              rho_val <<- NA
          })
          if(is.na(rho_val)){
            TP_grid_errors <- c(TP_grid_errors,
                                paste("\nWater density could not be calculated at",
                                      grid_temps[i], "degrees C and",
                                      grid_press[i], "bar with the water model", water_model))
          }else if(rho_val <= 310){
            TP_grid_errors <- c(TP_grid_errors,
                                paste("\nWater density is", roundup(rho_val, 3), "kg m^3 at",
                                      grid_temps[i], "degrees C and",
                                      grid_press[i], "bar. This is too low (< 310 kg m^3)",
                                      "for this calculation. Increase pressure or decrease temperature."))
          }
        }else if(grid_press[i] < psat_press){

          TP_grid_errors <- c(TP_grid_errors,
                              paste("\n", grid_press[i], "bar is below liquid-vapor",
                                    "saturation pressure", roundup(psat_press, 4),
                                    "bar at", grid_temps[i], "degrees C."))
        }
      }
      if(length(TP_grid_errors) > 0){
        stop(paste(paste(TP_grid_errors, collapse="\n"),
                   "\n\nIncrease the pressure at these temperature points in 'grid_press'",
                   "to keep water in a liquid state."))
      }

    }
  }

  return(list("grid_temps"=grid_temps, "grid_press"=grid_press,
              "poly_coeffs_1"=poly_coeffs_1, "poly_coeffs_2"=poly_coeffs_2))
}


##### Chapter 8: Association Rules -------------------
# 장바구니 분석의 결과는 연관 규칙의 모음이다.
  # 연관 규칙 : 아이템 집합 사이에 관계에 존재하는 패턴
    # LHS : 규칙을 실행하기 위해 만족돼야 하는 조건
    # RHS : 그 조건을 만족했을 때 기대하는 결과
# 연관 규칙은 예측이 아니라, 대규모 DB에서 자율적인 지식의 발견을 위해 사용된다.
# 연관 구칙 학습자는 자율적이기 때문에, 알고리즘이 훈련될 필요가 없다.
  # 즉 데이터가 사전에 레이블될 필요가 없다.
  # 하지만 학습자에 대해 사용자가 직접 확인하는 것 외에는 규칙 학습자의 성능을 측정할 방법이 없다.

# 연관 규칙 학습을 위한 a priori 알고리즘 (아 프리오리, 선험적인)
  # 쇼핑몰에 물건 100개만 있어도 2^100개의 아이템 집합을 평가해야 함
  # 좀 더 똑똑한 학습 알고리즘은 아이템 집합을 전부 평가하지 않는다.
    # 대신 잠재적인 아이템 조합이 실제로 드물게 발견된다는 사실을 이용한다.
  # 아프리오리 알고리즘은 빈번한 아이템집합의 속성에 대해 단순한 사전적 믿음을 이용한다.리
    # 통계 척도인, 아이템 집합의 흥미도를 이용한다.
      # 이는 어떻게 측정할까? 또 학습될 규칙의 수를 줄이기 위해 아프리오리 속성과 어떻게 결합되는가?
# 장단점
  # 장점
    # 대규모 거래 데이터에 대해 작업 가능
    # 이해하기 쉬운 규칙 생성
    # 데이터 마이닝과 DB에서 예상치 못한 지식 발굴 가능
  # 단점
    # 작은 데이터셋에서는 유용하지 않음
    # 진정한 통찰과 상식을 분리하기 위한 노력이 필요
    # 랜덤 패턴에서 비논리적인 결론을 도출하기 쉽다.
# 규칙 흥미 측정 : 지지도와 신뢰도
  # 지지도와 신뢰도를 사용해, 보고되는 규칙의 갯수를 제한할 수 있다.
    # 확실하거나 상식적인 규칙만 식별될 떄까지 제한하는 것도 가능하다.
  # support(X) = count(X) / N  <- (아이템 집합 X 를 포함하는 거래 건수 / 데이터베이스의 거래 건수)
  # confidence(X -> Y) = support(X,Y)/support(X) (X와 Y를 모두 포함하는 아이템집합의 지지도/X만포함지지도)
    # 신뢰도는 아이템 또는 아이템집합 X의 존재가, 아이템 또는 아이템집합 Y의 존재를 유발하는 거래의 비율
    # confidence(X -> Y) != confidence(Y -> X)
# a priori 원칙을 이용한 규칙 집합의 구축
  # 빈번한 아이템집합의 모든 부분집합 또한 빈번해야 한다.
  # a priori algorithm은 이 논리를 사용해, 실제 평가하기 전에 잠재적인 연관 규칙을 제외시킨다.
  # 규칙을 생성하는 절차
    # 1. 최소 지지도 임계치를 만족하는 모든 아이템 집합을 식별한다.
    # 2. 이 아이템 집합에서 최소 신리도 임계치를 만족하는 아이템 집합으로 규칙을 생성한다.

## Example: Identifying Frequently-Purchased Groceries ----
## Step 2: Exploring and preparing the data ----

# load the grocery data into a sparse matrix
# 거래 데이터는 좀 더 자유로운 형태로 저장되어 있다.
  # 각 레코드는 고정된 개수의 특징 대신, 한 개부터 여러 개까지 쉼표로 분리된 임의의 개수의 아이템목록으로 이루어짐.
install.packages("arules")
library(arules)
getwd()
setwd("D:/R_LAB/MlwR/Chapter 08")
# 그냥 read.csv로 읽으면 나중에 문제가 생긴다
  # 첫 번째 줄이 네 개의 값을 가졌기 때문에 R은 생성해야 할 네 변수를 생성했다. -> 더 많이 사면 잘린다
  # 거래를 특정 아이템으로 채우는 위치 집합이 아닌,
  # 각 특정 아이템을 포함하거나 포함하지 않는 장바구니로 취급하는 데이터셋이 필요하다.
# 거래 데이터를 위한 희소 행렬(sparse matrix)생성
  # 희소 행렬은 의미있는 셀에 비해 0이 너무 많기 떄문에, 전체 행렬을 통째로 저장하는 것은 비효율적이다.(170만개)
  # 희소 행렬 구조를 만들기 위해 arules 패키지를 사용하자.
groceries <- read.transactions("groceries.csv", sep = ",")
summary(groceries)# 0이 아닌 값 2.6%
# look at the first five transactions
  # 희소 행렬의 내용을 보려면 inspect 함수를 벡터 연산과 결합해 사용.
inspect(groceries[1:5])

# examine the frequency of items
itemFrequency(groceries[, 1:3])

# plot the frequency of items(아이템 빈도 그래프)
itemFrequencyPlot(groceries, support = 0.1) # 최소 10% 지지도 갖는 8개 아이템
itemFrequencyPlot(groceries, topN = 20) # 지지도 가장 높은 20개

# a visualization of the sparse matrix for the first five transactions
  # 5행 169열의 행렬. 5건의 거래와 169개의 가능한 아이템을 나타낸다.
image(groceries[1:5])

# visualization of a random sample of 100 transactions
image(sample(groceries, 100)) # 거래 100건에 대한 희소 행렬 시각화

## Step 3: Training a model on the data ----
library(arules)

# default settings result in zero rules learned
# 실행하는 것 자체는 간단하지만, 합리적인 개수와 연관 규칙을 생성하는 지지도, 신뢰도 찾기는 시행착오 필요
  # 파라미터의 수준이 너무 높은 경우
    # 규칙을 찾지 못하거나 너무 포괄적인 규칙만을 찾음(숟가락 옆에 젓가락 놓아봐야 다 안다)
  # 파라미터의 수준이 너무 낮은 경우
    # 규칙이 너무 많아져서 통제 힘듦, 혹은 메모리 부족
arules::apriori(groceries, parameter = # minlen은 요구되는 최소 규칙 아이템
                  list(support = 0.1, confidence = 0.8, minlen = 1))우 # default setting -> nothing learned

# set better support and confidence levels to learn more rules
# 최소 지지도 임계치를 다루는 방법
  # ex)한달 동안 하루 2번 구입되면 60회, 9835회 중 60회는 0.006
# 최소 신뢰도 임계치를 다루는 방법(일단 0.25로 시작)
  # 너무 낮으면 규칙 너무 많아짐, 너무 높으면 뻔한 규칙
groceryrules <- apriori(groceries, parameter = list(support =
                          0.006, confidence = 0.25, minlen = 2))
groceryrules # 규칙 463

## Step 4: Evaluating model performance ----
# summary of grocery association rules
summary(groceryrules)
# 대부분 또는 모든 규칙이 최소 임계치 바로 근처에서 지지도와 신뢰도를 갖는다면
  # 기준을 너무 높게 설정했다는 것을 의미 -> 재조정 필요
  # lift(X -> Y) = confidence(X ->Y)/support(Y)
    # 향상도는 어떤 아이템(집합) X가 구매됐다는 것을 안다면, 다른 아이템(집합)Y가 어떤 확률로 구매될 것인가를
    # Y의 일반적인 구매 확률과 비교해 측정한다.
    # 아이템 순서가 중요한 신뢰도와는 달리, 향상도는 순서가 달라도 동일하다.

# look at the first three rules
inspect(groceryrules[1:3])
# 논리적으로 potted plant -> whole milk는 말이 안되지만, 데이터는 이 규칙이 믿을만 하다고 말하고 있다.
# 일반적인 방법은, 연관 규칙을 받아 다음 세 가지 범주로 규칙을 나누는 것이다.
  # 실행 가능한
  # 사소한(기저귀 -> 분유)
  # 설명하기 어려운(연관성 불명확. 단순히 데이터에 있는 랜덤 패턴일 수도 있다.)
# 충분한 시간이 있다면 숨겨진 보석 규칙을 위해 모든 규칙을 평가할 수 있다.
  # 하지만 분석가는 규칙이 어떤지까지는 잘 모를 수도 있다.
  # 가장 흥미로운 결과가 상단에 표시되도록, 학습된 규칙을 정렬하고 공유하자.

## Step 5: Improving model performance ----

# sorting grocery rules by lift
  # sort()함수로 by 파라미터에 lift를 넣어서, lift가 가장 높은 순서대로 5개를 출력시켰다.
inspect(sort(groceryrules, by = "lift")[1:5])

# finding subsets of rules containing any berry items
# subset()함수는 거래, 아이템, 규칙의 부분집합을 찾는 방법을 제공한다.
berryrules <- subset(groceryrules, items %in% "berries") # 베리가 들어간 규칙만 부분집합으로 뽑음
inspect(berryrules) # 규칙 출력. lift 높은 두 규칙은 실행 가능해 보인다.
# subset() 사용법
  # items %in% 쓰면 좌측, 우측 모두 포함되기만 하면 뽑는다.
    # 좌측에만 해당되게 하려면 item 대신 lhs, 우측은 rhs
  # 연산자 %in%은 아이템 중 최소 하나가 정의된 목록에서 발견돼야만 한다.
    # 두 개 하고 싶으면 %in% c("berries", "yogurt")로 넣자.
  # %ain%으로 완전 매칭(베리, 요거트 둘 다 있는 규칙만 찾기)
  # %pin%으로 부분 매칭(%pin% fruit로 그냥 과일이랑 열대 과일 같이 찾기)
  # 부분집합은 support, confidence, lift로 제약 가능
  # 매칭 조건은 %, |, !같은 표준 R 논리 연산자와 결합 가능

# writing the rules to a CSV file
write(groceryrules, file = "groceryrules.csv",
      sep = ",", quote = TRUE, row.names = FALSE)

# converting the rule set to a data frame
groceryrules_df <- as(groceryrules, "data.frame")
str(groceryrules_df)


 DPBSVX Example Program Results

 Solution(s)
             1          2
 1      5.0000    -2.0000
 2     -2.0000     6.0000
 3     -3.0000    -1.0000
 4      1.0000     4.0000

 Backward errors (machine-dependent)
       8.6E-17    1.1E-16

 Estimated forward error bounds (machine-dependent)
       2.0E-14    2.8E-14

 Estimate of reciprocal condition number
       1.3E-02

 A has not been equilibrated


# An introduction to R programming
# NDSU Analysis of Ecosystems
# Devan Allen McGranahan (devan.mcgranahan@ndsu.edu)

# Lesson 3: Introduction to graphing in R.
  # Basic plotting with plot() + an introduction to ggplot

##
## S T A R T  H E R E

# Install and load packages used in this session

  install.packages("ggplot2","plyr","ggthemes")
  library(plyr)

# You will need our customized mtcars2 file.
    # If you had problems loading it on Tuesday,
    # you should re-load the file from Google Drive
    # to ensure you have all the correct columns.

    # ~Remember!~ Different functions for different file types:
    #   use read.csv() for .csv files
    #   use load() for .Rdata files

      # To import mtcars2.csv:
        # Step 1: Save mtcars.csv to your local folder (E:/R/data)

        # Step 2: Set your working directory:
          setwd("E:/R/")

        # Step 3: Load file:
          mtcars2 <- read.csv(file="./data/mtcars2.csv")
          # or
          mtcars2 <- read.csv(file.choose())

      # To load an existing R object called mtcars2:

          # Step 1: Set your working directory:
          setwd("E:/R/")

          # Step 2: Load R object:
          load(file="./data/mtcars2.Rdata")
          # or
          load(file.choose())

##
## B A S I C  P L O T T I N G  W/ plot()  F U N C T I O N S
##

# Do your data have categorical predictors, continuous response?
# Box plots are a great option.

class(mtcars2$hp)
class(mtcars2$cyl)

# boxplot() takes arguments in the formula format (y ~ x, data)

# Default settings don't look bad for simple plots:
boxplot(hp ~ origin, mtcars2)
boxplot(hp ~ cyl, mtcars2)

# But even just adding one variable gets messy:

boxplot(hp ~ cyl + origin, mtcars2)
x11() # You can always use this to pop up a new graphics window
      # Pretty old-school; rarely will you do this with Rstudio?
boxplot(hp ~ cyl + origin, mtcars2, xaxt="n",
        xlab="Number of cylinders", ylab="Horsespower",
        cex.lab=1.3, cex.axis=1.3, las=1, lwd=2, col=c("blue","orange"))
axis(side=1, at=c(1.5,3.5, 5.5), labels=c("4", "6", "8"), cex.lab=1.3)
legend("topleft", title="Origin", c("Foreign","Domestic"),
       fill=c("blue", "orange"), cex=1.2, bty="n")

# xlab and ylab assign axis labels
# cex.axis and cex.lab change font size of axis and axis labels
# lwd changes the width (weight) of lines
# las=1 makes Y axis labels read parallel
# ?par gives you *tons* more

# Add means to the boxplot:
hp.box <- boxplot(hp ~ cyl + origin, mtcars2)
points(seq(hp.box$n), agg.example$hp.mean, pch=24, col="white", bg="blue", cex=3)
agg.example

agg.example2 <- rbind(data.frame(origin="domestic", cyl="4",
                                 hp.mean=0, hp.sd=0), agg.example)
points(seq(hp.box$n), agg.example2$hp.mean, pch=24, col="white", bg="grey30", cex=2)

# Scatterplots are often used when both variables are continuous:

  class(mtcars2$hp)
  class(mtcars2$mpg)

# plot() function takes formula format:

  plot(mpg ~ hp, mtcars2)

  # Think carefully when setting up your formula:
  # Which variable is independent? (it goes in for X)
  # Which variable depends on the other? (it goes in for Y)

  x11(width=8, height=4) ; split.screen(c(1,2))
  screen(1) ; plot(mpg ~ hp, mtcars2, las=1)
  screen(2) ; plot(hp ~ mpg, mtcars2, las=1)
  close.screen(all=TRUE)

  dev.off() # Kill pop-up graphics device, return to Rstudio

# Fitting trend lines

  # Linear relationships beg to have a line drawn through them.
  # R includes functions to automatically fit and plot lines.
  # e.g., abline() and lm() are seperate functions, but abline()
  # "knows" how to read lm() (linear model) results for line info:

  abline(lm(mpg ~ hp, mtcars2))

  # Different pars can be added - to abline - to customize:

  abline(lm(mpg ~ hp, mtcars2), lwd=2)
  abline(lm(mpg ~ hp, mtcars2), lwd=5, lty=2)

  # Note the overplotting.
  # To get a new line, must start from scratch:

  plot(mpg ~ hp, mtcars2, las=1)
  abline(lm(mpg ~ hp, mtcars2), lwd=2, lty=2)

# Combining continuous and categorical variables

  # Perhaps cars with different origins have unique
    # mpg ~ hp relationships?
    # Adventures with subset():

  plot(mpg ~ hp, mtcars2, las=1, type="n") # Make a blank plot
    points(mpg ~ hp, subset(mtcars2,origin=="foreign"),pch=1)
    points(mpg ~ hp, subset(mtcars2,origin=="domestic"),pch=19)

    abline(lm(mpg~hp, subset(mtcars2,origin=="foreign")),lty=1)
    abline(lm(mpg~hp, subset(mtcars2,origin=="domestic")),lty=2)

  # Customize the graph:
    # Improve aesthetics, provide more info about the data:

    plot(mpg ~ hp, mtcars2, las=1, type="n",
         cex.axis=1.4, cex.lab=1.4,
         xlab="Engine power (hp)", xlim=c(50,350),
         ylab="Fuel economy (mpg)", ylim=c(10,35))

    points(mpg ~ hp, subset(mtcars2, origin=="foreign"),
           pch=19, cex=1.4, col="orange")
    points(mpg ~ hp, subset(mtcars2, origin=="domestic"),
           pch=17, cex=1.4, col="blue")

    abline(lm(mpg~hp, subset(mtcars2, origin=="foreign")),
           lwd=2, col="orange", lty=1)
    abline(lm(mpg~hp, subset(mtcars2, origin=="domestic")),
           lwd=2, col="blue", lty=2)

    legend("topright", title="Car origin", c("Foreign","USA"),
           lty = c(1,2), col=c("orange","blue"),
           pch=c(19, 17), cex=1.4, lwd=2, bty="n" )

##
## I N T R O D U C I N G  ggplot
##
    library(ggplot2)

    # Two main functions:
      # qplot() or "quick plot" - takes aesthetics and geometry in-line
      # ggplot() builds plot as aesthetics and geometries are added
        # Some aesthetics (aes) include: x, y, color, shape, line type...
        # Some geometries (geoms) include: point, boxplot, line, text...

    # Neither qplot nor ggplot read formula format.
    # Arguments must be specified.
    # qplot assumes order is x, y:
      qplot(cyl, mpg, data = mtcars2)  # Incorrect geometry assumption
      qplot(cyl, mpg, data = mtcars2, geom="boxplot")
      qplot(hp, mpg, data = mtcars2)  # Correct geometry assumption

    # The power of ggplot lies in *aesthetics mapping*
    # Instead of subsetting and specifying colors, sizes, etc,
    # You tell ggplot which variables you want to plot by, and ggplot
    # finds them in your data and applies default (but customizeable)
    # parameters like color (often "colour" since the author is Kiwi):

      qplot(cyl, mpg, data = mtcars2, colour=origin, geom="boxplot")
      qplot(hp, mpg, data = mtcars2, colour=origin)
      qplot(hp, mpg, data = mtcars2, colour=origin, shape=am)
      qplot(hp, mpg, data = mtcars2, facets=~origin, colour=am)
      qplot(hp, mpg, data = mtcars2, facets=am~origin, colour=cyl)

    # Adding regression lines are beyond qplot. Need to jump to ggplot:

      ggplot(data=mtcars2, aes(x=hp, y=mpg)) # Empty! No geometry
      ggplot(data=mtcars2, aes(x=hp, y=mpg)) +
        geom_point()

    # ggplot can be object-oriented, helps build plots:
      ggp <- ggplot(data=mtcars2, aes(x=hp, y=mpg)) +
                geom_point()
      ggp
      (ggp <- ggp + stat_smooth(method="lm", se=FALSE) )

      ggp + facet_wrap(~am)
      ggp + facet_grid(origin~am)

    # Themes

      # Several defaults:
        ggp + theme_bw() # No background, major + minor gridlines
        ggp + theme_linedraw() # No background, no minor gridlines

      # Many options developed:
        library(ggthemes)
        ggp + theme_wsj()   # Print like a Wall Street Journal graph
        ggp + theme_economist()  # Or one from the Economist
        ggp + theme_tufte()
        # Themes based on retro stat software:
          ggp + theme_stata()
          ggp + theme_excel()
          ggp + theme_base() # Recognize this one??

Analysis of Ecosystems/02 - Rstudio + plotting/2-2_intro_plotting.r


#Integer constants are suffixed with L.
rectangle_side_a = 10L
rectangle_side_b = 5L
rectangle_area = rectangle_side_a * rectangle_side_b
rectangle_perimeter = 2*(rectangle_side_a + rectangle_side_b)
#The command cat like print can also be used to print the output
#to the command line.
cat("Let there be a rectangle with the sides of lengths:",
    rectangle_side_a, "and", rectangle_side_b, "cm.\n")
cat("Then the area of the rectangle is", rectangle_area, "cm squared.\n")
cat("The perimeter of the rectangle is", rectangle_perimeter, "cm.\n")


library(Ecdat)
library(dygraphs)
library(rvest)
library(magrittr)
library(dplyr)
library(zoo)
data("CRANpackages")
str(CRANpackages)

CRANpackages$Version <- as.character(CRANpackages$Version)
CRANpackages <- rbind(CRANpackages,
                      data.frame(Version = "3.2",
                                 Date = as.Date("2016-04-27"),
                                 Packages = 8329,
                                 Source = "Andrie de Vries"))

url <- "https://cran.r-project.org/web/packages/available_packages_by_date.html"

page <- read_html(url)
pkgs <- page %>%
  html_node("table") %>%
  html_table() %>%
  mutate(count = rev(1:nrow(.))) %>%
  mutate(Date = as.Date(Date)) %>%
  mutate(Month = format(Date, format="%Y-%m")) %>%
  group_by(Month) %>%
  summarise(published = min(count)) %>%
  mutate(Date = as.Date(as.yearmon(Month)))

pkgs %>%
  filter(Date > as.Date("2012-12-01")) %>%
  mutate(publishedGrowth = c(tail(.$published, -1), NA) / published) %>%
  mutate(counter = 1:nrow(.)) -> new_pkgs

tail(new_pkgs)

write.csv(pkgs,"Arichivos_01Intro/paquetesTS.csv",row.names = F)

pkgs_old <- CRANpackages[1:8,c(3,2)]
names(pkgs_old) <- names(pkgs[,c(2,3)])
n_pkgs <- rbind(pkgs_old,pkgs[,c(3,2)])
#cumsum(n_pkgs$published)

#diff(n_pkgs$published)

#data_pkgs <- CRANpackages[,2:3]
#pkgs <- data.frame(pkgs[,c(1,2)])
row.names(new_pkgs) <- as.Date(new_pkgs$Date)
dygraph(new_pkgs) %>% dyRangeSelector()


\name{generate_simulated_data_from_estimated_model}
\alias{generate_simulated_data_from_estimated_model}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
 Generating simulated data from a fitted model
}
\description{
  This function generates simulated networks from a fitted model and performs estimations on these simulated networks with the same setting used in the original estimation. Each simulated network is generated using parameters of the fitted model, while keeping other aspects of the growth process as faithfully as possible to the original observed network.
}
\usage{
generate_simulated_data_from_estimated_model(net_object, net_stat, result, M = 5)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{net_object}{
    an object of class \code{PAFit_net} that contains the original network.
  }
  \item{net_stat}{
    An object of class \code{PAFit_data} which contains summarized statistics of the original network. This object is created by the function \code{\link{get_statistics}}.
  }
   \item{result}{
    An object of class \code{Full_PAFit_result} which contains the fitted model obtained by applying the function \code{\link{joint_estimate}}.
  }
\item{M}{integer. The number of simulated networks. Default value is \code{5}.}
}

\value{
  Outputs a \code{Simulated_Data_From_Fitted_Model} object, which is a list containing the following fields:
  \itemize{
    \item \code{graph_list}: a list containing \code{M} simulated graphs.

    \item \code{stats_list}: a list containing \code{M} objects of class \code{PAFit_data}, which are the results of applying \code{\link{get_statistics}} on the simulated graphs.
    \item \code{result_list}: a list containing \code{M} objects of class \code{Full_PAFit_result}, which are the results of applying \code{\link{joint_estimate}} on the simulated graphs.
}
}

\author{
  Thong Pham \email{thongphamthe@gmail.com}
}
\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}).

  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}).

 3. Pham, T., Sheridan, P. & Shimodaira, H. (2020). PAFit: An R Package for the Non-Parametric Estimation of Preferential Attachment and Node Fitness in Temporal Complex Networks. Journal of Statistical Software 92 (3). (\doi{10.18637/jss.v092.i03}).

4. Inoue, M., Pham, T. & Shimodaira, H. (2020). Joint Estimation of Non-parametric Transitivity and Preferential Attachment Functions in Scientific Co-authorship Networks. Journal of Informetrics 14(3). (\doi{10.1016/j.joi.2020.101042}).
}
\seealso{
 \code{\link{get_statistics}}, \code{\link{joint_estimate}}, \code{\link{plot_contribution}}
}

\examples{
\dontrun{

  library("PAFit")
  net_object     <- generate_net(N = 500, m = 10, s = 10, alpha = 0.5)
  net_stat       <- get_statistics(net_object)
  result         <- joint_estimate(net_object, net_stat)
  simulated_data <- generate_simulated_data_from_estimated_model(net_object, net_stat, result)
  plot_contribution(simulated_data, result, which_plot = "PA")
  plot_contribution(simulated_data, result, which_plot = "fit")
  }
}

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


require(dplyr)

source('fmm_generative.r')
source('fmm_utils.r')

conditional_mixing_model = function(y, k, z, a) {
  labelled = data.frame(value = y, L1 = z)
  counts   = summarise(group_by(labelled, L1), count = n())

  concentration = sapply(
      seq(k)
    , function(cluster) {
        idx = which(counts$L1 == cluster)
        if (length(idx) != 0) {
          counts$count[idx] + a / k
        } else {
          a / k
        }
      })

  drop(rdirichlet(1, concentration))
}

conditional_label_model = function(y, p, m, s) {
  scorer     = function(mix, mu, prec) {
    exp(log(mix) + dnorm(y, mu, sqrt(1 / prec), log = T))
  }
  unweighted = mapply(scorer, p, m, s)
  weights    = 1 / apply(unweighted, MARGIN = 1, sum)
  weighted   = weights * unweighted

  probabilize = function(row) {
    rs = sum(row)
    if (rs == 0 || is.na(rs) || is.nan(rs)) {
      drop(rdirichlet(1, rep(1, length(m))))
    } else {
      row
    }
  }

  probs = t(apply(weighted, MARGIN = 1, probabilize))
  apply(
      probs
    , MARGIN = 1
    , function(row) { sample(seq_along(m), size = 1, prob = row) }
    )
}

conditional_location_model = function(y, z, s, l, r) {
  clustered = group_by(data.frame(value = y, L1 = z), L1)
  lengths   = summarise(clustered, value = n())
  sums      = summarise(clustered, value = sum(value))

  n = sapply(seq_along(s),
    function(cluster) {
      idx = which(lengths$L1 == cluster)
      if (length(idx) != 0) {
        lengths$value[idx]
      } else {
        0
      }
    })

  yt = sapply(seq_along(s),
    function(cluster) {
      idx = which(sums$L1 == cluster)
      if (length(idx) != 0) {
        sums$value[idx]
      } else {
        0
      }
    })

  m  = (yt * s + l * r) / (n * s + r)
  v  = 1 / (n * s + r)

  mapply(rnorm, 1, m, sqrt(v))
}

conditional_precision_model = function(y, z, m, b, w) {
  labelled  = data.frame(value = y, L1 = z)
  clustered = group_by(labelled, L1)

  acc = list()
  for (j in seq_along(m)) {
    acc[[j]] = labelled[which(labelled$L1 == j), 'value']
    }

  centered = mapply("-", acc, m)
  squared  = lapply(centered, function(x) x ^ 2)
  ss       = unlist(lapply(squared, sum))

  n = sapply(seq_along(m),
    function(cluster) {
      lengths = summarise(clustered, value = n())
      idx     = which(lengths$L1 == cluster)
      if (length(idx) != 0) {
        lengths$value[idx]
        } else {
        0
        }
      })

  a   = b + n
  bet = (w * b + ss) / a

  mapply(function(a, b) rgamma(1, a, b), a, bet)
}

inverse_model = function(n, k, y, a, l, r, b, w) {
  gibbs = function(p0, m0, s0) {
    z  = conditional_label_model(y, p0, m0, s0)
    p1 = conditional_mixing_model(y, k, z, a)
    m1 = conditional_location_model(y, z, s0, l, r)
    s1 = conditional_precision_model(y, z, m1, b, w)
    l  = lmodel(y, p1, m1, s1)
    list(p = p1, m = m1, s = s1, z = z, l = l)
    }

  p0     = mixing_model(k, a)
  m0     = location_model(k, l, r)
  s0     = precision_model(k, b, w)
  params = list(p = p0, m = m0, s = s0)

  acc = params
  for (j in seq(n - 1)) {
      params = gibbs(params$p, params$m, params$s)
      acc$p  = rbind(acc$p, params$p)
      acc$m  = rbind(acc$m, params$m)
      acc$s  = rbind(acc$s, params$s)
      acc$z  = rbind(acc$z, params$z)
      acc$l  = c(acc$l, params$l)
    }
  acc
}


compute.gen.cpp <-
function (x, path, rep = 1, float.type = "double", namespace = TRUE)
{
    fd = file( path, open = "wt" );

    nn <- x
    linear.output <- nn$linear.output
    weights <- nn$weights[[rep]]
    nrow.weights <- sapply( weights, nrow )
    ncol.weights <- sapply( weights, ncol )
    length.weights <- length( weights )
    num.covariates <- nrow.weights[1] - 1

    act.fct.type <- attributes( nn$act.fct )$type
    if ( act.fct.type == "logistic" || act.fct.type == "tanh" )
    {
        cat( "#include <math.h>\n", file = fd )
        cat( "\n", file = fd )
    }

    if ( namespace )
    {
        cat( "namespace neuralnet\n", file = fd )
        cat( "{\n", file = fd )
        cat( "\n", file = fd )
    }

    act.fct.cpp <- act.fct.type
    if ( act.fct.type == "logistic" )
    {
        act.fct.cpp <- "act_fct"
        cat( "static ", float.type, " act_fct(", float.type, " x)\n", sep = "", file = fd )
        cat( "{\n", file = fd )
        cat( "    return 1 / ( 1 + exp(-x) );\n", file = fd )
        cat( "}\n", file = fd )
        cat( "\n", file = fd )
    }

    cat( "void compute(const ", float.type, " *covariates, ", float.type, " *results)\n", sep = "", file = fd )
    cat( "{\n", file = fd )

    if ( num.covariates > 1 )
    {
        for ( i in 0:(num.covariates - 2) )
        {
            cat( "    const ", float.type, " n0_", i, " = *(covariates++);\n", sep = "", file = fd )
        }
    }
    cat( "    const ", float.type, " n0_", (num.covariates - 1), " = *(covariates);\n", sep = "", file = fd )
    cat( "\n", file = fd )

    for ( l in 1:length.weights )
    {
        layer.weights <- weights[[l]]
        layer.intercepts <- layer.weights[1,]

        act.fct.use = act.fct.cpp
        if ( l == length.weights && linear.output )
        {
            act.fct.use <- ""
        }

        for ( n in 1:(ncol.weights[l]) )
        {
            intercept <- layer.intercepts[n]
            multsum <- paste( "(", layer.weights[2, n], ") * n", (l - 1), "_0", sep = "" )
            if ( nrow.weights[l] > 2 )
            {
                for ( i in 3:(nrow.weights[l]) )
                {
                    multsum <- paste( multsum, " + (", layer.weights[i, n], ") * n", (l - 1), "_", (i - 2), sep = "" )
                }
            }
            if ( l == length.weights )
            {
                if ( n == ncol.weights[l] )
                {
                    cat( "    *results = ", act.fct.use, "( ", intercept, " + ", multsum, " );", sep = "", file = fd )
                }
                else
                {
                    cat( "    *(results++) = ", act.fct.use, "( ", intercept, " + ", multsum, " );\n", sep = "", file = fd )
                }
            }
            else
            {
                cat( "    const ", float.type, " n", l, "_", (n - 1), " = ", act.fct.use, "( ", intercept, " + ", multsum, " );\n", sep = "", file = fd )
            }
        }
        cat( "\n", file = fd )
    }

    cat( "}\n", file = fd )
    cat( "\n", file = fd )

    if ( namespace )
    {
        cat( "} // namespace neuralnet\n", file = fd )
    }

    close( fd )
}


context("iproduct iterator")

test_that("iproduct constructs the Cartesian product of two unnamed numeric vectors", {
  it <- iproduct(1:3, 4:6)
  expect_equal(nextElem(it), list(1, 4))
  expect_equal(nextElem(it), list(1, 5))
  expect_equal(nextElem(it), list(1, 6))
  expect_equal(nextElem(it), list(2, 4))
  expect_equal(nextElem(it), list(2, 5))
  expect_equal(nextElem(it), list(2, 6))
  expect_equal(nextElem(it), list(3, 4))
  expect_equal(nextElem(it), list(3, 5))
  expect_equal(nextElem(it), list(3, 6))

  expect_error(nextElem(it), "StopIteration")
})

test_that("iproduct constructs the Cartesian product of three unnamed numeric vectors", {
  it <- iproduct(1:2, 3:4, 5:6)
  expect_equal(nextElem(it), list(1, 3, 5))
  expect_equal(nextElem(it), list(1, 3, 6))
  expect_equal(nextElem(it), list(1, 4, 5))
  expect_equal(nextElem(it), list(1, 4, 6))
  expect_equal(nextElem(it), list(2, 3, 5))
  expect_equal(nextElem(it), list(2, 3, 6))
  expect_equal(nextElem(it), list(2, 4, 5))
  expect_equal(nextElem(it), list(2, 4, 6))

  expect_error(nextElem(it), "StopIteration")
})

test_that("iproduct constructs the Cartesian product of two named numeric vectors", {
  it <- iproduct(a=1:3, b=4:6)
  expect_equal(nextElem(it), list(a=1, b=4))
  expect_equal(nextElem(it), list(a=1, b=5))
  expect_equal(nextElem(it), list(a=1, b=6))
  expect_equal(nextElem(it), list(a=2, b=4))
  expect_equal(nextElem(it), list(a=2, b=5))
  expect_equal(nextElem(it), list(a=2, b=6))
  expect_equal(nextElem(it), list(a=3, b=4))
  expect_equal(nextElem(it), list(a=3, b=5))
  expect_equal(nextElem(it), list(a=3, b=6))

  expect_error(nextElem(it), "StopIteration")
})

test_that("iproduct constructs the Cartesian product of three named numeric vectors", {
  it <- iproduct(a=1:2, b=3:4, c=5:6)
  expect_equal(nextElem(it), list(a=1, b=3, c=5))
  expect_equal(nextElem(it), list(a=1, b=3, c=6))
  expect_equal(nextElem(it), list(a=1, b=4, c=5))
  expect_equal(nextElem(it), list(a=1, b=4, c=6))
  expect_equal(nextElem(it), list(a=2, b=3, c=5))
  expect_equal(nextElem(it), list(a=2, b=3, c=6))
  expect_equal(nextElem(it), list(a=2, b=4, c=5))
  expect_equal(nextElem(it), list(a=2, b=4, c=6))

  expect_error(nextElem(it), "StopIteration")
})

test_that("iproduct constructs the Cartesian product twice of two unnamed numeric vectors", {
  it <- iproduct(1:3, 4:6, times=2)

  # First Cartesian product
  expect_equal(nextElem(it), list(1, 4))
  expect_equal(nextElem(it), list(1, 5))
  expect_equal(nextElem(it), list(1, 6))
  expect_equal(nextElem(it), list(2, 4))
  expect_equal(nextElem(it), list(2, 5))
  expect_equal(nextElem(it), list(2, 6))
  expect_equal(nextElem(it), list(3, 4))
  expect_equal(nextElem(it), list(3, 5))
  expect_equal(nextElem(it), list(3, 6))

  # Second Cartesian product
  expect_equal(nextElem(it), list(1, 4))
  expect_equal(nextElem(it), list(1, 5))
  expect_equal(nextElem(it), list(1, 6))
  expect_equal(nextElem(it), list(2, 4))
  expect_equal(nextElem(it), list(2, 5))
  expect_equal(nextElem(it), list(2, 6))
  expect_equal(nextElem(it), list(3, 4))
  expect_equal(nextElem(it), list(3, 5))
  expect_equal(nextElem(it), list(3, 6))

  expect_error(nextElem(it), "StopIteration")
})

test_that("iproduct constructs the Cartesian product twice of three unnamed numeric vectors", {
  it <- iproduct(1:2, 3:4, 5:6, times=2)

  # First Cartesian product
  expect_equal(nextElem(it), list(1, 3, 5))
  expect_equal(nextElem(it), list(1, 3, 6))
  expect_equal(nextElem(it), list(1, 4, 5))
  expect_equal(nextElem(it), list(1, 4, 6))
  expect_equal(nextElem(it), list(2, 3, 5))
  expect_equal(nextElem(it), list(2, 3, 6))
  expect_equal(nextElem(it), list(2, 4, 5))
  expect_equal(nextElem(it), list(2, 4, 6))

  # Second Cartesian product
  expect_equal(nextElem(it), list(1, 3, 5))
  expect_equal(nextElem(it), list(1, 3, 6))
  expect_equal(nextElem(it), list(1, 4, 5))
  expect_equal(nextElem(it), list(1, 4, 6))
  expect_equal(nextElem(it), list(2, 3, 5))
  expect_equal(nextElem(it), list(2, 3, 6))
  expect_equal(nextElem(it), list(2, 4, 5))
  expect_equal(nextElem(it), list(2, 4, 6))

  expect_error(nextElem(it), "StopIteration")
})


## Function to do Wright-Fisher simulation with selection and a finite sample size
# using priors on Ne, s, and initial allele frequency
# Sample at two time points

# i is a dummy argument so that it can be used with sapply and parSapply
# f1min: the minimum for the initial allele frequency uniform prior
# f1max:
# smin: the minimum for the selection coefficient uniform prior
# smax:
# c1: the size of the first sample (in # chromosomes)
# c2: the size of the second sample (in # chromosomes)
# gen: the number of generations
# ne: a vector of possible Ne values. Simulation picks one to use.
# h: dominance effect

wfs <- function(i, f1min=0, f1max=1, smin=-1, smax=1, c1=58, c2=48, gen=20, ne=100, h=0.5){
	# choose parameters for this simulation
	f1 <- runif(1, min=f1min, max=f1max) # starting allele frequency
	s <- runif(1, min=smin, max=smax) # selection coefficient
	if(length(ne)>1) thisne <- round(sample(ne, 1)) # ne has to be integer for binomial sampling
	if(length(ne)==1) thisne <- round(ne)

#	print(paste(f1, s, thisne))

	p <- f1 # current allele frequency
	waa <- 1+s # relative fitness of genotype AA
	wab <- 1+s*h
	wbb <- 1
	for(i in 1:gen){
		x <- (waa*p^2 + wab*p*(1-p))/(waa*p^2 + wab*2*p*(1-p) + wbb*(1-p)^2) # probability of sampling allele A, given selection
		p <- rbinom(1,thisne,x)/thisne
#		print(paste(x,p))
	}
	f2 <- p

	f1samp <- rbinom(1,c1,f1)/c1 # first sample allele frequency
	f2samp <- rbinom(1,c2,f2)/c2 # second sample allele frequency

	# return values
	out <- c(ne=thisne, f1=f1, s=s, gen=gen, f2=f2, f1samp=f1samp, f2samp=f2samp)
	return(out)
}


gtbl  <-  gtbl %>%
  mutate(bench = meanByYear$lifeExp[match(year, meanByYear$year)]
         benchDif = lifeExp - bench
         belowBench = lifeExp < bench)


require(ggplot2)
require(gridExtra)
require(ggthemes)

useAIC = TRUE;

# 1. Calculate AIC, BIC, AIC weights, BIC weights
# Useful for model averaging and model selection.
ms=modelSelection(models=modelOutput, data=dat)
# simple plot to show differnces between models
par(mar=c(20,8,5,2))
if(useAIC){
  x = ms$AIC-ms$AIC[1]
}else
  x = ms$BIC-ms$BIC[1]

orderV = order(-x);
currentModels = rownames(ms);
myColor = rgb(red=69/255, green=139/255, blue=116/255,alpha=0.8)
modelId=rownames(ms);
letList = letters[1:length(modelId)];
letList[1:length(letList)] = "C"
letList[length(letList)] = "A"
letList[length(modelId)-1 - (4:0)] = "B"
I = x[x > 0];
letList[1:length(I)] = "D"
group.colors = c(A="#3E7655",B="#FD8D00",C="#615857",D="#903194");

AIC = x[orderV];
AIC[AIC > 300] = 300;
dataFrame = data.frame(AIC=AIC, modelId = as.factor(currentModels[orderV]),
                       categories=as.factor(letList));
dataFrame$modelId = factor(dataFrame$modelId,
                           levels = dataFrame$modelId[order(-dataFrame$AIC)])

# Plot nice ggplot
p1=ggplot(dataFrame, aes(modelId,AIC, fill=categories), stat="identity");
p1=p1 + geom_col(alpha=0.6) + geom_hline(yintercept=0, linetype="dashed")
p1=p1 + coord_flip() + theme_minimal()
p1=p1 + ggtitle(paste("All Models, ",subjnam));
p1=p1 + scale_fill_manual(values=group.colors)+ guides(fill=FALSE);
p1=p1 + theme(text = element_text(size=14));
p1=p1 + theme(aspect.ratio = 1);
p1=p1 + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());
p1=p1 + theme(axis.text.y = element_text(color=group.colors[dataFrame$categories]));
p1=p1 + theme(axis.line.x = element_line(colour="gray"),
              axis.ticks.x = element_line("gray", size=.25), axis.ticks.length = unit(.25,"cm"));
p1=p1 + labs(y="AIC", x="Models")

# A second example. Let's suppose we want to compare a subset of the models, not all of them;
# e.g., Cisek urgency vs Ditterich urgency vs. Ratcliff model, First, create a character vector of the models you
# want to compare. The names must exactly match the names as they appear in the modelOutput list.
# otherwise you will get odd errors

modelsToTest=currentModels[orderV[seq(length(orderV)-5, length(orderV))]]
# call the modelSelection function while subsetting from the modelOutput list
ms = modelSelection(models=modelOutput[modelsToTest], data=dat)
if(useAIC){
  x = ms$AICw;
}else
  x = ms$BICw;

orderV = order(x);

modelId=rownames(ms);
letList = letters[1:length(modelId)];
letList[1:length(letList)] = "B"
letList[length(letList)] = "A"
group.colors = c(A="#3E7655",B="#FD8D00",C="#615857",D="#903194");
dataFrame = data.frame(weights=x[orderV], modelId = as.factor(modelId[orderV]),
                       categories=as.factor(letList))
dataFrame$modelId = factor(dataFrame$modelId,
                           levels = dataFrame$modelId[order(dataFrame$weights)])
p2 = ggplot(dataFrame, aes(modelId,weights, fill=categories), stat="identity") +
  geom_col(alpha=0.6) + coord_flip(ylim=c(0, 1));
p2 = p2 + theme_minimal()+ ggtitle("Model weights");
p2 = p2 + theme(text = element_text(size=16),axis.text.y = element_text(hjust=1, angle=0,
                                                                        color=group.colors[dataFrame$categories[order(dataFrame$weights)]]));
p2 = p2 + scale_fill_manual(values=group.colors) + guides(fill=FALSE);
p2 = p2 + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank());
p2 = p2 + theme(aspect.ratio = 1)
p2 = p2 + labs(x="Posterior Model Probability", y="Models") + scale_y_continuous(expand = c(0, 0))

p2 = p2 + theme(axis.line.x = element_line(colour = "gray"),
                axis.ticks.x = element_line("gray", size=.25), axis.ticks.length = unit(.25,"cm"));

# Show the two plots side by side
grid.arrange(p1, p2, nrow=2, ncol=2)


.__Rcpuid_flops <- list(
  names = c("FLOPS", "KFLOPS", "MFLOPS", "GFLOPS", "TFLOPS", "PFLOPS", "EFLOPS", "ZFLOPS", "YFLOPS"),
  ordmag = c(0, 3, 6, 9, 12, 15, 18, 21, 24)
)

flops_units <- function()
{
  .__Rcpuid_flops$names
}

flops_ordmag <- function()
{
  .__Rcpuid_flops$ordmag
}

find_unit <- function(unit)
{
  unit <- match.arg(toupper(unit), .__Rcpuid_flops$names)

  unit
}

best_unit <- function(x)
{
  f <- 1e3
  fun <- function(x) log10(abs(x))
  dgts <- 3

  size <- x
  class(size) <- NULL

  if (size == 0)
    return( flops_units()[1L] )

  num.digits <-fun(size)

  for (i in seq.int(9))
  {
    if (num.digits < dgts*i)
    {
      unit <- flops_units()[i]
      break
    }
  }

  size <- size/(f^(i-1))

  class(size) <- "flops"
  attr(size, "unit") <- flops_units()[i]

  return( size )
}

swap_unit <- function(x, unit)
{
  inunit <- attr(x, "unit")
  index <- which(flops_units() == inunit)
  ordmag <- flops_ordmag()[index]

  flops <- as.numeric(x) * 10^ordmag

  index <- which(flops_units() == unit)
  ordmag <- flops_ordmag()[index]
  ret <- flops / 10^ordmag

  class(ret) <- "flops"
  attr(ret, "unit") <- unit

  return( ret )
}

#' Flops Constructor
#'
#' Function to build a flops object.
#'
#' This provides a simple way of representing flops, scaled by
#' some SI unit (e.g., mega, giga, ...).
#'
#' @param size
#' A number of flops, scaled by the input unit unit.
#' @param unit
#' An SI unit of flops (e.g., MFLOPS for MegaFLOPS, GFLOPS for
#' GigaFLOPS, etc.).
#'
#' @return
#' Returns a flops object.
#'
#' @examples
#' \dontrun{
#' library(okcpuid, quietly=TRUE)
#' flops(2000000) # 2 MFLOPS
#' }
#'
#' @export flops
flops <- function(size=0, unit)
{
  if (missing(unit))
  {
    size <- best_unit(size)
  }
  else
  {
    unit <- match.arg(tolower(unit), flops_units())
    attr(size, "unit") <- "FLOPS"
    class(size) <- "flops"
    size <- swap_unit(size, unit)
  }

  return( size )
}

#' unflop
#'
#' Convert a flops object into a numeric.
#'
#' This function differs from a simple \code{as.numeric()} call in
#' that flops objects store the unit flops.  So if you have a flops
#' object \code{x} that prints "10 MFLOPS", \code{as.numeric(x)}
#' would produce 10, while \code{unflop()} would produce 10000000.
#'
#' @param x
#' A flops object.
#'
#' @return
#' The number of flops represented by x.
#'
#' @rdname unflop
#' @export
unflop <- function(x)
{
  if (class(x) != "flops")
    stop("Argument 'x' must be a flops object")

  as.numeric(swap_unit(x, "FLOPS"))
}

#' print-flops
#'
#' @param x
#' A flops object.
#' @param ...
#' Ignored.
#' @param unit
#' The flops display unit to use.
#' @param digits
#' The number of decimal digits to display.
#'
#' @name print-flops
#' @rdname print-flops
#' @method print flops
#' @export
print.flops <- function(x, ..., unit="best", digits=3)
{
  if (unit == "best")
    x <- best_unit(unflop(x))
  else
  {
    unit <- match.arg(tolower(unit), flops_units())
    x <- swap_unit(x, unit)
  }

  size <- as.numeric(x)
  unit <- attr(x, "unit")

  if (x > 1e22)
    format <- "e"
  else
    format <- "f"

  cat(sprintf(paste("%.", digits, format, " ", unit, "\n", sep=""), size))
}


# R script to set up PreservationSimulation/shelf data
# RBLandau 20141214
# revised 20150619

# REQUIRES:
# - sInputFilename
# - sOutputFilemane
# - sTitle

# I N P U T
dat <- data.frame(read.table(sInputFilename, header=TRUE))
# Use dataset with only the interesting columns: docsize, lifem, shelfsize, copies, lost
# because we don't want to aggregate anything else.
datn = data.frame(dat$docsize,dat$lifem,dat$shelfsize,dat$copies,dat$lost)

#sink()
cat("Input data from ",sInputFilename,"\n")
cat("Output analysis into ",sOutputFilename,"\n\n")
cat(sTitle,"\n")
cat("\n")

# F U N C T I O N S

# W h a t e v e r
WhateverSampleSadisticsYouWant <- function(docsize,lifem,copies,shelfsize,vect)
{
    cat("=== ","docsize",docsize,"lifem",lifem,"copies",copies,"shelfsize",shelfsize,"N",length(vect),"\n")
    stem(vect)
    cat("docsize",docsize,"lifem",lifem,"copies",copies,"shelfsize",shelfsize,"N",length(vect),"\n")
    cat("median","\t\t",median(vect),"\n")
    cat("trimean","\t",trimean(vect),"\n")
    cat("midmean","\t",midmean(vect),"\n")
    stat_mean <- mean(vect)
    cat("mean","\t\t",stat_mean,"\n")
    cat("stddev","\t\t",sd(vect),"\n")
    cat("IQR","\t\t",IQR(vect),"\n")
    cat("mad","\t\t",mad(vect),"\n")
    stat_SEM <- (sd(vect)/sqrt(length(vect)))
    cat("SEM","\t\t",stat_SEM,"\n")
    stat_MeanOverSEM <- stat_mean / stat_SEM
    stat_LogMeanOverSEM <- log10(stat_mean / stat_SEM)
    cat("MeanOverSEM","\t",stat_MeanOverSEM,"\n")
    cat("LogMeanOverSEM","\t",stat_LogMeanOverSEM,"\n")
    cat("\n")
}

trimean <-  function(vect)  { foo = fivenum(vect); ans <- 0.5*foo[3] + 0.25*foo[2] + 0.25*foo[4]; ans }
midmean <-  function(vect)  { ans <- mean(vect,trim=0.25); ans }

# s u m m a r i z e
summarize <- function(myframe,mysummaryout,mysummaryfunction)
{
    colnames(summ) <- c("docsize","lifem","shelfsize","c1","c2","c3","c4","c5","c8","c10","c14","c16","c20")

    for (ss in levels(factor(myframe$dat.shelfsize)))
    {
        tmp1 <- data.frame(myframe[myframe$dat.shelfsize==ss,]);
        for (ds in levels(factor(tmp1$dat.docsize)))
        {
            tmp2 <- data.frame(tmp1[tmp1$dat.docsize==ds,]);
            for (lfm in levels(factor(tmp2$dat.lifem)))
            {
                tmp3 <- tmp2[tmp2$dat.lifem==lfm,]
                tmp4 = aggregate(tmp3, by=list(tmp3$dat.copies), FUN=mysummaryfunction)
                newrow <- c(ds,lfm,ss,round(tmp4$dat.lost,2))

                if (length(newrow) < length(colnames(mysummaryout)))
                {
                    filler <- rep(0,length(colnames(mysummaryout)) - length(newrow))
                    #print(c(length(filler),"=>",filler))
                    #print(c(length(newrow),"=>",newrow))
                    newrow <- c(newrow,filler)
                }
                #print(newrow)
                mysummaryout <- rbind(mysummaryout,as.numeric(newrow))
            }
        }
    }
    mysummaryout <- mysummaryout[-1,]
    rownames(mysummaryout) <- NULL
    rownames(mysummaryout, do.NULL = TRUE, prefix = "row")
    return(mysummaryout)
}

# T A B L E S
# Summary table with medians.
summ <- data.frame(rbind(numeric(13)))
colnames(summ) <- c("docsize","lifem","shelfsize","c1","c2","c3","c4","c5","c8","c10","c14","c16","c20")
datn = data.frame(dat$docsize,dat$lifem,dat$shelfsize,dat$copies,dat$lost)
summ <- summarize(datn,summ,median)

# Summary table with trimeans.
sumt <- data.frame(rbind(numeric(13)))
colnames(sumt) <- c("docsize","lifem","shelfsize","c1","c2","c3","c4","c5","c8","c10","c14","c16","c20")
datn = data.frame(dat$docsize,dat$lifem,dat$shelfsize,dat$copies,dat$lost)
sumt <- summarize(datn,sumt,trimean)

# Summary table with midmeans.
summid <- data.frame(rbind(numeric(13)))
colnames(summid) <- c("docsize","lifem","shelfsize","c1","c2","c3","c4","c5","c8","c10","c14","c16","c20")
datn = data.frame(dat$docsize,dat$lifem,dat$shelfsize,dat$copies,dat$lost)
summid <- summarize(datn,summid,midmean)

# O U T P U T
# Leave tracks for the console user.
#cat("Input data from ",sInputFilename,"\n")
#cat("Output analysis into ",sOutputFilename,"\n\n")
#cat(sTitle,"\n")
#cat("\n")
#cat("\n")

# Send output to a file so we can read it later.
sink(sOutputFilename)
cat(sTitle,"\n")
cat("Input data from ",sInputFilename,"\n")
cat("Output analysis into ",sOutputFilename,"\n\n")

# Show results.
cat("Question 3 Summary losses (medians)\n")
print(summ)
cat("\n")

if(TRUE){
cat("Question 3 Summary losses (trimeans)\n")
print(sumt)
cat("\n")
}#ENDIFFALSE

if(TRUE){
cat("Question 3 Summary losses (midmeans)\n")
print(summid)
cat("\n")
}#ENDIFFALSE
cat("\n")

cat("============================================\n")
# Let's look at the distributions of the samples.
# The order of nesting here makes some comparisons easier than others.
for (ds in levels(factor(datn$dat.docsize)))
{
    tmp1 <- data.frame(datn[datn$dat.docsize==ds,]);
    for (lfm in levels(factor(tmp1$dat.lifem)))
    {
        tmp2 <- tmp1[tmp1$dat.lifem==lfm,]
        for (cp in levels(factor(tmp2$dat.copies)))
        {
            tmp3 <- tmp2[tmp2$dat.copies==cp,]
            for (ss in levels(factor(tmp3$dat.shelfsize)))
            {
                tmp4 <- tmp3[tmp3$dat.shelfsize==ss,]
                WhateverSampleSadisticsYouWant(ds,lfm,cp,ss,tmp4$dat.lost)
            }
        }
    }
}

sink()

#END


# Get statistics about the reference products
library(hydroGOF)
library(reshape2)
source("utils/accuracy-statistics.r")
source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/crossvalidation.r")

InDir = "../data/pixel-based/reference-products"

Data.val = LoadValidationAndCovariates()
Data.val[is.na(Data.val)] = -9999
#Val.sp = Data.val
Data.val = st_set_geometry(Data.val, NULL)
Data.val = TidyData(Data.val, drop.cols=NULL)

StatTable = NULL

## GSW
ReferenceValues = merge(st_read(file.path(InDir, "gsw.gpkg")), Data.val)
ReferenceValues = ReferenceValues[,c(names(ReferenceValues)[4], "water")]
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]]))
# 10.22 RMSE, 1.94 MAE, -0.63 ME (slight underestimation)
# But better than ours (12 & 3)
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]], TRUE))
# 1.81 RRMSE, 0.34 RMAE, -0.11 RME
NSE(ReferenceValues[[1]], ReferenceValues[[2]]) # 0.78
cor(ReferenceValues[[1]], ReferenceValues[[2]])^2 # 0.78
PlotHex(ReferenceValues[[1]], ReferenceValues[[2]], "Global Surface Water, 2015")
PlotBox(ReferenceValues[[1]], ReferenceValues[[2]], main="Global Surface Water, 2015")

## MEASURES (GFCC) Treecover

ReferenceValues = merge(st_read(file.path(InDir, "treecover.gpkg")), Data.val)
ReferenceValues = ReferenceValues[,c(names(ReferenceValues)[4], "tree")]
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]]))
# 28.80 RMSE, 18.33 MAE, -12.57 ME (underestimation!)
# Much worse than ours (19 & 13)
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]], TRUE))
# 0.91 RRMSE, 0.58 RMAE, -0.40 ME
NSE(ReferenceValues[[1]], ReferenceValues[[2]]) # 0.48
cor(ReferenceValues[[1]], ReferenceValues[[2]])^2 # 0.61
PlotHex(ReferenceValues[[1]], ReferenceValues[[2]], "GFCC tree cover, 2015")
PlotBox(ReferenceValues[[1]], ReferenceValues[[2]], main="GFCC tree cover, 2015")

## GHSL urban

ReferenceValues = merge(st_read(file.path(InDir, "ghsl.gpkg")), Data.val)
ReferenceValues = ReferenceValues[,c(names(ReferenceValues)[4], "urban_built_up")]
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]]))
# 18.67 RMSE, 5.43 MAE, 4.80 ME (overestimation!)
# Much worse than ours (10 & 3)
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]], TRUE))
# 6.34 RRMSE, 1.84 RMAE, 1.63 RME
NSE(ReferenceValues[[1]], ReferenceValues[[2]]) # -1.23
cor(ReferenceValues[[1]], ReferenceValues[[2]])^2 # 0.52
summary(lm(urban_built_up~GHSLBuiltup2014, ReferenceValues)) # High intercept and only 0.36 slope
PlotHex(ReferenceValues[[1]], ReferenceValues[[2]], "Global human settlement built-up, 2014")
PlotBox(ReferenceValues[[1]], ReferenceValues[[2]], main="Global human settlement built-up, 2014")

## Qinghua FROM-GLC impervious year of change

ReferenceValues = merge(st_read(file.path(InDir, "impervious.gpkg")), Data.val)
ReferenceValues = ReferenceValues[,c(names(ReferenceValues)[4], "urban_built_up")]
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]]))
# 11.18 RMSE, 2.57 MAE, 0.93 ME (less overestimation)
# Matches ours (10 & 3)
StatTable = rbind(StatTable, AccuracyStats(ReferenceValues[[1]], ReferenceValues[[2]], TRUE))
# 3.79 RRMSE, 0.87 RMAE, 0.32 RME
NSE(ReferenceValues[[1]], ReferenceValues[[2]]) # 0.20
cor(ReferenceValues[[1]], ReferenceValues[[2]])^2 # 0.65
PlotHex(ReferenceValues[[1]], ReferenceValues[[2]], "FROM-GLC impervious surface, 2015")
PlotBox(ReferenceValues[[1]], ReferenceValues[[2]], main="FROM-GLC impervious surface, 2015")

StatTable = cbind(StatTable, product=factor(c(rep("GSWater",2), rep("GFCC-Forest",2), rep("GHSL-Urban",2), rep("FROM-GLC-Urban",2)), c("GFCC-Forest", "GHSL-Urban", "FROM-GLC-Urban", "GSWater")), relative=c(FALSE, TRUE))

## Plots
StatTableLong = melt(StatTable, variable.name = "statistic")

devEMF::emf("../output/2020-10-06-modelcomparison.emf", height = 3)
ggplot(StatTableLong, aes(x=statistic, y=value, fill=product)) + geom_bar(stat="identity", position = "dodge") + facet_grid(rows="relative", scales = "free_y")
dev.off()


#plotting effects of sampling effort NEON
rm(list=ls())
source('paths.r')
d <- readRDS(HARV_sampling_effort_analysis_16S.path)

#get aggregated data.----
out <- list()
for(i in 1:length(d)){
  out[[i]] <- aggregate(mu ~ n.samp, data = d[[i]], FUN = mean)
}
names(out) <- names(d)
#drop ORNL, only 3 observations.
out$ORNL <- NULL

#assign to ecosystem types.
# assuming this order: c("BART", "CPER", "DSNY", "HARV", "JERC", "OSBS", "SCBI", "STER", "TALL", "UNDE")
eco <- c('forest','forest','savannah','forest','forest','savannah','forest','grassland','forest','forest')
col <- c(rep('purple', length(eco)))
col <- ifelse(eco == 'savannah','orange',col)
col <- ifelse(eco == 'grassland','green',col)

#Get negative exponential fits + predicted values.----
fit <- list()
for(i in 1:length(out)){
  dat <- out[[i]]
  #mod <- nls(mu ~ a*exp(b*n.samp) + c, data = dat, start = list(a = 32, b = -0.6, c = 3))
  mod <- nls(mu ~ a*exp(b*n.samp) + c, data = dat, start = list(a = 150, b = -0.2, c = 90))
  range <- data.frame(seq(1, max(dat$n.samp), by = 0.1))
  colnames(range) <- c('n.samp')
  pred <- predict(mod, newdata = range)
  return <- list(mod, range$n.samp, pred)
  names(return) <- c('model','effort','pred')
  fit[[i]] <- return
}
names(fit) <- names(out)

#png save line.----
png('test.png', width = 5, height = 5, units = 'in', res = 300)

#plot them.----
#global plot settings.
par(mar = c(1,1,1,1), oma = c(3,3,1,1))
#get y-limit.
var.max <- list()
for(i in 1:length(out)){var.max[[i]] <- out[[i]]$mu}
var.max <- unlist(var.max)
limy <- c(0, max(var.max))
limx <- c(1, 30)

#plotting.
plot(mu ~ n.samp, data = dat, ylim = limy, xlim = limx, cex = 0)
#draw fits
for(i in 1:length(fit)){
  lines(smooth.spline(fit[[i]]$pred ~ fit[[i]]$effort), lty = 2, lwd = 1.5, col = col[i])
}
#draw legend.
legend(x = 17.5, y = 100,
       legend = c('forest','savannah','grassland'), lty = 2, lwd = 1.5,
       col = c('purple','orange','green'),
       bty = 'n', y.intersp = 1)
#labels
mtext('Variance', side = 2, line = 2.2, cex = 1.2)
mtext('Number of soil cores', side = 1, line = 2.2, cex = 1.2)

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


library('ForeCA')

args <- commandArgs(trailingOnly = TRUE)
arg_id <- args[1]
arg_dim <- as.numeric(args[2])
arg_cwd <- args[3]

X <- ts(read.csv(sprintf('%s/foreca_node_train_%s.csv', arg_cwd, arg_id), header=FALSE))
ff <- foreca(X, n.comp=arg_dim)
summary(ff)
print(ff$loadings)
W <- matrix(ff$loadings, ncol=arg_dim)

write.matrix(W, sprintf('%s/foreca_node_result_%s.csv', arg_cwd, arg_id))


#Analyses for Tutorial 05: Discrete PCMs

## 1: Read data, tree, and prune/match one to the other
library(geiger) #also loads ape
library(phytools)

#Here is a large time-dated molecular phylogeny (a chronogram):
tree<-read.tree("TutorialData/tree.64.tre",tree.names=T)
plot(tree, show.tip.label = FALSE)
mydata<-read.csv('TutorialData/DiscreteData.csv', row.names=1, header=TRUE)
mydata[1:10,]

#Match data with tree
data.pruned<-treedata(phy=tree,data = mydata, warnings=FALSE)
tree<-data.pruned$phy
mydata<-data.pruned$data

#Plot data on tree
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,1],sort(unique(mydata[,1]))),piecol=c("red", "black"),cex=.3, offset=0)
tiplabels(pie = to.matrix(mydata[,3],sort(unique(mydata[,1]))),piecol=c("green", "orange"),cex=.3, offset=.2)

#####1: Single trait analysis: transition rate comparison
library(corHMM)
   #Set up initial rate matrices
rmat.er<-rate.mat.maker(rate.cat=1, hrm=FALSE, ntraits=1, nstates=2, model="ER")  #equal transition rates
rmat.ard<-rate.mat.maker(rate.cat=1, hrm=FALSE, ntraits=1, nstates=2, model="ARD") #unequal transition rates
rmat.er   #all rates the same
rmat.ard  #all rates different
   #Set up data
trt1<-cbind(row.names(mydata),mydata[,1])
trt2<-cbind(row.names(mydata),mydata[,3])
trt3<-cbind(row.names(mydata),mydata[,5])

#Fit models: TRAIT 1
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,1],sort(unique(mydata[,1]))),piecol=c("red", "black"),cex=.3, offset=0)
res1.er<-corHMM(tree,trt1,rate.cat=1,rate.mat=rmat.er,node.states="marginal")
res1.er
res1.ard<-corHMM(tree,trt1,rate.cat=1,rate.mat=rmat.ard,node.states="marginal")
   #compare models: logL and AIC
res1.er$loglik
res1.ard$loglik  #identical in this case: no need for formal LRT
res1.er$AICc
res1.ard$AICc    #Choose simpler model (lower AICc b/c fewer parameters and same logL)
res1.er$solution  #rate transition parameters

#Fit models: TRAIT 2
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,3],sort(unique(mydata[,3]))),piecol=c("red", "black"),cex=.3, offset=0)
res2.er<-corHMM(tree,trt2,rate.cat=1,rate.mat=rmat.er,node.states="marginal")
res2.ard<-corHMM(tree,trt2,rate.cat=1,rate.mat=rmat.ard,node.states="marginal")
#compare models: logL and AIC
res2.er$loglik
res2.ard$loglik  #identical in this case: no need for formal LRT
res2.er$AICc
res2.ard$AICc    #Choose simpler model (lower AICc b/c fewer parameters and same logL)
res2.er$solution  #rate transition parameters

#Fit models: TRAIT 3
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,5],sort(unique(mydata[,5]))),piecol=c("red", "black"),cex=.3, offset=0)
res3.er<-corHMM(tree,trt3,rate.cat=1,rate.mat=rmat.er,node.states="marginal")
res3.ard<-corHMM(tree,trt3,rate.cat=1,rate.mat=rmat.ard,node.states="marginal")
#compare models: logL and AIC
res3.er$loglik
res3.ard$loglik
LRT<- -2*(res3.er$loglik - res3.ard$loglik)  #LRT test
LRT
1-pchisq( LRT,df = 1)  #probability of LRT
res3.er$AICc
res3.ard$AICc    #ARD preferred
res3.ard$solution  #rate transition parameters
   #transition from

#####2: Two trait analysis: Trait association
#Compare dependent (correlated) change model (ARD) with independent change model (ER)  #See Pagel 1994
trtset12<-cbind(row.names(mydata),mydata[,1:2])
trtset34<-cbind(row.names(mydata),mydata[,3:4])

#Traits 1&2
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,1],sort(unique(mydata[,1]))),piecol=c("red", "black"),cex=.3, offset=0)
tiplabels(pie = to.matrix(mydata[,2],sort(unique(mydata[,2]))),piecol=c("green", "orange"),cex=.3, offset=0.2)
disc.res12.er<-corDISC(tree,trtset12,ntraits=2,model="ER",node.states="marginal")
disc.res12.ard<-corDISC(tree,trtset12,ntraits=2,model="ARD",node.states="marginal")
disc.res12.er$loglik
disc.res12.ard$loglik
LRT<- -2*(disc.res12.er$loglik - disc.res12.ard$loglik)  #LRT test
1-pchisq( LRT,df = 4)  #probability of LRT
disc.res12.er$AIC
disc.res12.ard$AIC   #STRONG SUPPORT for correlated (dependent) evolution
   #Implemented in phytools
tr1<-mydata[,1]; names(tr1)<-row.names(mydata)
tr2<-mydata[,2]; names(tr2)<-row.names(mydata)
disc.res12.b<-fitPagel(tree,x=tr1,y=tr2)
disc.res12.b
  #NOTE: LOOK AT PHYLOGENY AND DATA HERE!  WE have strong support for correlated evolution, but both traits are co-distributed and clustered
    #essentially, 1 evolutionary shift could explain the pattern: the 'BiSSE' problem (need ancestral state estimation: next week)
 ##### ALWAYS PLOT YOUR DATA! DON'T JUST RUN STATISTICS (statistical anlaysis alone here leads to mis-interpretation)

#Traits 3&4
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,3],sort(unique(mydata[,3]))),piecol=c("red", "black"),cex=.3, offset=0)
tiplabels(pie = to.matrix(mydata[,4],sort(unique(mydata[,4]))),piecol=c("green", "orange"),cex=.3, offset=0.2)
disc.res34.er<-corDISC(tree,trtset34,ntraits=2,model="ER",node.states="marginal")
disc.res34.ard<-corDISC(tree,trtset34,ntraits=2,model="ARD",node.states="marginal")
disc.res34.er$loglik
disc.res34.ard$loglik
disc.res34.er$AIC
disc.res34.ard$AIC # VERY STRONG SUPPORT FOR CORRELATED EVOLUTION

#####3: Two trait analysis: Order to transitions matters (changes in trait 2 DEPEND on values of trait 1: Maddison 1990)
  #Must define the two models for comparison
plot.phylo(tree,show.tip.label = F)
tiplabels(pie = to.matrix(mydata[,3],sort(unique(mydata[,3]))),piecol=c("red", "black"),cex=.3, offset=0)
tiplabels(pie = to.matrix(mydata[,4],sort(unique(mydata[,4]))),piecol=c("green", "orange"),cex=.3, offset=0.2)
eq.rat<-rate.mat.maker(rate.cat=1, hrm=FALSE, ntraits=2, nstates=2, model="ER")
eq.rat
dir.rat<-eq.rat; dir.rat[1,2]<-2; dir.rat[3,4]<-3  #e.g., q12<>q34: see Table in Pagel 1994
dir.rat
  #NOTE: which values are allowed to differ dependently depends upon the directional hypothesis under investigation!

disc.res34.er<-corDISC(tree,trtset34,ntraits=2,model="ER",node.states="marginal")
disc.res34.dir<-corDISC(tree,trtset34,ntraits=2,model="ER",rate.mat=dir.rat,node.states="marginal") #run with directional hypothesis
disc.res34.er$loglik
disc.res34.dir$loglik
disc.res34.er$AIC
disc.res34.dir$AIC # # VERY STRONG SUPPORT FOR DIRECTIONAL DEPENDENT EVOLUTION


#' @title calchb
#'
#' @description Estimate the center of bulb area above keel line (\code{hb}) (m)
#' using the method in Rakke (2016).
#'
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#'
#' @return \code{hb} (vector of numericals, m)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship Emissions
#'Calculation from AIS." NTNU.}
#'
#' @examples
#' calchb(c(13.57,11.49))
#' calchb(13.57)
#'
#' @export

calchb <-function(maxDraft){

  hb<-0.4*maxDraft

  return(hb)
}


#' Norm Estimation
#'
#' Estimates the 1-norm of a power of a matrix.
#'
#' @param x
#' A numeric matrix.
#' @param pow
#' An integer power.
#'
#' @return
#' exp(x)
#'
#' @export
normest <- function(x, pow)
{
  if (!is.double(x))
    storage.mode(x) <- "double"

  .Call(R_libexpm_normest, x, as.integer(pow))
}


##Set Working Directory
setwd("C:/Users/GitHubRepository/scwrp-rsu-slr-model")

##Set Desired Output Directory
OutputDirectory="C:/Users/GitHubRepository/scwrp-rsu-slr-model/model output/"
  #This directory is set as a variable that will be used below to output the model data
  #Suggested output directory is a subdirectory of the working directory
  #Output directory path must end with a forward slash "/"

##############################################################################
#Part 1
##Import csv with input data for all sites in the region
input <- read.csv(file="SLR_Model_Inputs.csv", head=TRUE, sep=",")

##Create input variables for model
#Time points for baseline and SLR projections
t0 <- 2016
t1 <- 2050
t2 <- 2100

##Relative SLR (mm/yr)
SL2050 <-input$SLR_2050_mmyr*(t1-t0)
SL2100 <-input$SLR_2100_mmyr*(t2-t0)

##Accretion: inputs from Lit Review (mm/yr)
Acr2050 <- input$Accretion_mmyr*(t1-t0)
Acr2100 <- input$Accretion_mmyr*(t2-t0)

##Change in Elevation (m)
Elev2050 <- Acr2050*0.001 #convert accretion to m
Elev2100 <- Acr2100*0.001

##Change in Water level: inputs from rSLR and Mouth Dynamics Modeling
#Mouth Dynamics contribution (m)
MD2050 <- input$MD_WL_2050
MD2100 <- input$MD_WL_2100

#Change in Water level (m)
WL2050 <-(SL2050*0.001)+(MD2050) #SLR contribution (m)
WL2100 <-(SL2100*0.001)+(MD2100)

#Intermediate outputs for elevation and water level
output <-cbind(input, Elev2050, Elev2100, WL2050, WL2100)
  #Appends elevation and water level calculations per site to input data

##Hypsometric curves
Hyps <- read.csv(file="Hypsometry.csv", head=TRUE, sep=",")
  #Import long-format csv containing hypsometrtic curves (standardized to Z*) for all sites in the region

###Z breaks, by archetype
zbreaks <- read.csv(file="Zbreaks_Archetypes.csv", head=TRUE, sep=",")

##############################################################################
#Part 2
#Create list of sites from input/intermediate output
Sites=output$Site_Name
Sites = levels(Sites)

for (i in 1:length(Sites)){

  #SITE Inputs
  Site = subset(Hyps, Name==Sites[i]) #extracts site hypsometry data
  PC = subset(output, Site_Name==Sites[i], select=Perch.Correction) #site perch correction
  z.bin.max.pc = Site$z.bin.max - (PC[1,1]*1.25) #adjusts Z* (elevation) to correct for perched systems
  Site = cbind.data.frame(Site, z.bin.max.pc) #appends adjusted Z* (elevation)
  Site_archetype = subset(output, Site_Name==Sites[i], select=ArchetypeCode) #Site-specific archetype classification

  ##Archetype-specific Z* breaks
  z.subtidal=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="Subtidal")
  z.mudflat=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="Intertidal.Mudflat")
  z.low=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="Low.Marsh")
  z.mid=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="Mid.Marsh")
  z.high=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="High.Marsh")
  z.trans=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="Transition")
  z.stop=subset(zbreaks, Arch_Code==Site_archetype[1,1], select="Stop")

  #Calculate current area
  subtidal=with(Site, sum(Site[z.bin.max.pc<z.mudflat[1,1], "area.km2"]))
  shallowsubtidal=with(Site, sum(Site[z.bin.max.pc>=z.subtidal[1,1] & z.bin.max.pc<z.mudflat[1,1], "area.km2"]))
  mudflat=with(Site, sum(Site[z.bin.max.pc>=z.mudflat[1,1] & z.bin.max.pc<z.low[1,1], "area.km2"]))
  low=with(Site, sum(Site[z.bin.max.pc>=z.low[1,1] & z.bin.max.pc<z.mid[1,1], "area.km2"]))
  mid=with(Site, sum(Site[z.bin.max.pc>=z.mid[1,1] & z.bin.max.pc<z.high[1,1], "area.km2"]))
  high=with(Site, sum(Site[z.bin.max.pc>=z.high[1,1] & z.bin.max.pc<z.trans[1,1], "area.km2"]))
  trans=with(Site, sum(Site[z.bin.max.pc>=z.trans[1,1] & z.bin.max.pc<z.stop[1,1], "area.km2"]))

  ##Site-specific Change in Z* breaks = CHANGE IN WATER LEVEL
  #convert m to z* = 1.25
  WL2050=subset(output, Site_Name==Sites[i], select=WL2050)
  WL2100=subset(output, Site_Name==Sites[i], select=WL2100)

  z.shallowsubtidal.2050=z.subtidal+((SL2050*0.001)*1.25)
  z.mudflat.2050=z.mudflat+(WL2050*1.25)
  z.low.2050=z.low+(WL2050*1.25)
  z.mid.2050=z.mid+(WL2050*1.25)
  z.high.2050=z.high+(WL2050*1.25)
  z.trans.2050=z.trans+(WL2050*1.25)
  z.stop.2050=z.stop+(WL2050*1.25)

  z.shallowsubtidal.2100=z.subtidal+((SL2100*0.001)*1.25)
  z.mudflat.2100=z.mudflat+(WL2100*1.25)
  z.low.2100=z.low+(WL2100*1.25)
  z.mid.2100=z.mid+(WL2100*1.25)
  z.high.2100=z.high+(WL2100*1.25)
  z.trans.2100=z.trans+(WL2100*1.25)
  z.stop.2100=z.stop+(WL2100*1.25)

  ##Site-specific Change in Z* bin max = CHANGE IN ELEVATION (m)
  Elev2050=subset(output, Site_Name==Sites[i], select=Elev2050)
  Elev2100=subset(output, Site_Name==Sites[i], select=Elev2100)

  ##Apply accretion to all marsh zones
  z.bins.2050=(Site$z.bin.max.pc+(Elev2050[1,1]*1.25))
  z.bins.2100=(Site$z.bin.max.pc+(Elev2100[1,1]*1.25))

  ##Site-specific output: future hypsometry
  Hyps_future=cbind(Site,z.bins.2050,z.bins.2100)
  #Set output directory to "SCWRP RSU SLR Model Output" folder
  dirname = paste(OutputDirectory, Sites[i],"/",sep="")
  filename = paste(dirname, Sites[i],"_hypsometry.csv",sep="")
  dir.create(file.path(dirname),recursive=TRUE)
  #write.csv(Hyps_future, file=filename) #option to write hypsometry data

  #Caluculate 2050 area
  subtidal_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050<z.mudflat.2050[1,1], "area.km2"]))
  #shallowsubtidal_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050>=z.shallowsubtidal.2050[1,1] & z.bins.2050<z.mudflat.2050[1,1], "area.km2"]))
  mudflat_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050>=z.mudflat.2050[1,1] & z.bins.2050<z.low.2050[1,1], "area.km2"]))
  low_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050>=z.low.2050[1,1] & z.bins.2050<z.mid.2050[1,1], "area.km2"]))
  mid_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050>=z.mid.2050[1,1] & z.bins.2050<z.high.2050[1,1], "area.km2"]))
  high_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050>=z.high.2050[1,1] & z.bins.2050<z.trans.2050[1,1], "area.km2"]))
  trans_2050=with(Hyps_future, sum(Hyps_future[z.bins.2050>=z.trans.2050[1,1] & z.bins.2050<z.stop.2050[1,1], "area.km2"]))

  #Calculate 2100 area
  subtidal_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100<z.mudflat.2100[1,1], "area.km2"]))
  #shallowsubtidal_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100>=z.shallowsubtidal.2100[1,1] & z.bins.2100<z.mudflat.2100[1,1], "area.km2"]))
  mudflat_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100>=z.mudflat.2100[1,1] & z.bins.2100<z.low.2100[1,1], "area.km2"]))
  low_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100>=z.low.2100[1,1] & z.bins.2100<z.mid.2100[1,1], "area.km2"]))
  mid_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100>=z.mid.2100[1,1] & z.bins.2100<z.high.2100[1,1], "area.km2"]))
  high_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100>=z.high.2100[1,1] & z.bins.2100<z.trans.2100[1,1], "area.km2"]))
  trans_2100=with(Hyps_future, sum(Hyps_future[z.bins.2100>=z.trans.2100[1,1] & z.bins.2100<z.stop.2100[1,1], "area.km2"]))

  #Create and export Site-specific output:  habitat area for current, 2050, 2100
  #Aggregate marsh zones to NWI Classes: Sudtidal water, estuarine unvegetated wetland, estuarine vegetated wetland
  Area_output_NWI= cbind.data.frame(Habitat=c("Subtidal Water","Estuarine Unvegetated Wetland","Estuarine Vegetated Wetland"),
                                Current=c(rbind(subtidal, mudflat, sum(low, mid, high))),
                                SLR2050=c(rbind(subtidal_2050, mudflat_2050, sum(low_2050, mid_2050, high_2050))),
                                SLR2100=c(rbind(subtidal_2100, mudflat_2100, sum(low_2100, mid_2100, high_2100))))

  filename2 = paste(dirname, Sites[i],"_area_NWIclasses.csv",sep="")
  write.csv(Area_output_NWI, file=filename2)
}


#' Transform a power spectrum into a time series, using an inverse
#' fast Fourier transform.
#'
#' @param freq The frequency.
#' @param power The power spectral distribution.
#'
#' @return Time series.
#'
#' @export
time.series <- function(freq, power) {
    time   <- as.time(Re(freq))
    signal <- fft(power, inverse = TRUE)

    data.frame(time, signal)
}


#Consensus Mechanism
#This is the mechanism that, theoretically,
 #   1] allows the software to determine the state of Decisions truthfully, and
 #   2] only allows an efficient number of most-traded-upon-Decisions.

try(setwd("~/GitHub/Truthcoin/lib"))
#To my knowledge, R does not feature 'automatic working directories' uneless it is being run as a script

source("consensus/CustomMath2.r")

AsMatrix <- function(Vec) return(matrix(Vec,nrow=length(Vec)))

# #Function Library
GetRewardWeights <- function(M,Rep=NULL,alpha=.1,Verbose=FALSE) {
  #Calculates the new reputations using WPCA

  if(is.null(Rep)) { Rep <- ReWeight(rep(1,nrow(M)))  ;   if(Verbose) print("Reputation not provided...assuming equal influence.")  }

  if(Verbose) {
    print("****************************************************")
    print("Begin 'GetRewardWeights'")
    print("Inputs...")
    print("Matrix:")
    print(M)
    print("")
    print("Reputation:")
    print(AsMatrix(Rep))
    print("")
  }

  #Rep=ReWeight(rep(1,nrow(M)))
  Results <- WeightedPrinComp(M,Rep)

  FirstLoading <- Results$Loadings #The first loading is designed to indicate which Decisions were more 'agreed-upon' than others.
  FirstScore   <- Results$Scores   #The scores show loadings on consensus (to what extent does this observation represent consensus?)

  if(Verbose) { print("First Loading:"); print(FirstLoading); print("First Score:"); print(AsMatrix(FirstScore)) }

  #PCA, being an abstract factorization, is incapable of determining anything absolute.
  #Therefore the results of the entire procedure would theoretically be reversed if the average state of Decisions changed from TRUE to FALSE.
  #Because the average state of Decisions is a function both of randomness and the way the Decisions are worded, I quickly check to see which
  #  of the two possible 'new' reputation vectors had more opinion in common with the original 'old' reputation.
  #  I originally tried doing this using math but after multiple failures I chose this ad hoc way.
  Set1 <-  FirstScore+abs(min(FirstScore))
  Set2 <-  FirstScore-max(FirstScore)

  Old <- Rep%*%M

  New1 <- GetWeight(Set1%*%M)
  New2 <- GetWeight(Set2%*%M)

  #Difference in Sum of squared errors, if >0, then New1 had higher errors (use New2), and conversely if <0 use 1.
  RefInd <- sum( (New1-Old)^2) -  sum( (New2-Old)^2)

  if(RefInd<=0) AdjPrinComp <- Set1
  if(RefInd>0)  AdjPrinComp <- Set2

  if(Verbose) {
    print("")
    print("Estimations using: Previous Rep, Option 1, Option 2")
    print( cbind( AsMatrix(Old), AsMatrix(New1), AsMatrix(New2) ) )
    print("")
    print("Previous period reputations, Option 1, Option 2, Selection")
    print( cbind( AsMatrix(Rep), AsMatrix(Set1), AsMatrix(Set2), AsMatrix(AdjPrinComp) ) )
  }

  #Declared here, filled below (unless there was a perfect consensus).
  RowRewardWeighted <- Rep # (set this to uniform if you want a passive diffusion toward equality when people cooperate [not sure why you would]). Instead diffuses towards previous reputation (Smoothing does this anyway).
  if(max(abs(AdjPrinComp))!=0) RowRewardWeighted <- GetWeight( (AdjPrinComp * Rep/mean(Rep)) ) #Overwrite the inital declaration IFF there wasn't perfect consensus.
  #note: Rep/mean(Rep) is a correction ensuring Reputation is additive. Therefore, nothing can be gained by splitting/combining Reputation into single/multiple accounts.

  #Freshly-Calculated Reward (Reputation) - Exponential Smoothing
  #New Reward: RowRewardWeighted
  #Old Reward: Rep
  SmoothedR <- alpha*(RowRewardWeighted) + (1-alpha)*Rep

  if(Verbose) {
    print("")
    print("Corrected for Additivity , Smoothed _1 period")
    print( cbind( AsMatrix(RowRewardWeighted), AsMatrix(SmoothedR)) )
  }

  #Return Data
  Out <- list("FirstL"=FirstLoading,"OldRep"=Rep,"ThisRep"=RowRewardWeighted,"SmoothRep"=SmoothedR)  #Keep the factors and time information along for the ride, they are interesting.
  return(Out)
}

GetDecisionOutcomes <- function(Mtemp, Rep, ScaledIndex, Verbose=FALSE) {
  #Determines the Outcomes of Decisions based on the provided reputation (weighted vote)

  if(missing(Rep)) { Rep <- ReWeight(rep(1,nrow(Mtemp)))  ;   if(Verbose) print("Reputation not provided...assuming equal influence.")  }

  if(Verbose) { print("****************************************************") ; print("Begin 'GetDecisionOutcomes'")}

  RewardWeightsNA <- Rep

  DecisionOutcomes.Raw  <- 1:ncol(Mtemp) #Declare this (filled below)

  for(i in 1:ncol(Mtemp)) {
    #For each column:
    Row <- ReWeight(RewardWeightsNA[!is.na(Mtemp[,i])]) #The Reputation of the row-players who DID provide judgements, rescaled to sum to 1.
    Col <- Mtemp[!is.na(Mtemp[,i]),i]                   #The relevant Decision with NAs removed. ("What these row-players had to say about the Decisions they DID judge.")

    #Discriminate Based on Contract Type
    if(!ScaledIndex[i]) DecisionOutcomes.Raw[i] <- Row%*%Col                     #Our Current best-guess for this Binary Decision (weighted average)
    if(ScaledIndex[i]) DecisionOutcomes.Raw[i] <- weighted.median(w=Row, x=Col)  #Our Current best-guess for this Scaled Decision (weighted median)

    if(Verbose) { print("** **"); print("Column:"); print(i); print(AsMatrix(Row)); print(Col); print("Consensus:"); print(DecisionOutcomes.Raw[i])}
  }

  #Output
  return(DecisionOutcomes.Raw)
}

FillNa <- function(Mna, Rep, ScaledIndex, CatchP=.1, Verbose=FALSE) {
  #Uses exisiting data and reputations to fill missing observations.
  #Essentially a weighted average using all availiable non-NA data.
  #How much should slackers who arent voting suffer? I decided this would depend on the global percentage of slacking.

  if(missing(Rep)) { Rep <- ReWeight(rep(1,nrow(Mna)))  ;   if(Verbose) print("Reputation not provided...assuming equal influence.")  }

  Mnew <- Mna #Declare (in case no Missing values, Mnew, MnewC, and Mna will be the same)
  MnewC <- Mna

  if(sum(is.na(Mna))>0) {
    #Of course, only do this process if there ARE missing values.

    if(Verbose) print("Missing Values Detected. Beginning presolve using availiable values.")

    #Decision Outcome - Our best guess for the Decision state (FALSE=0, Ambiguous=.5, TRUE=1) so far (ie, using the present, non-missing, values).
    DecisionOutcomes.Raw <- GetDecisionOutcomes(Mna,Rep,ScaledIndex,Verbose)

    #Fill in the predictions to the original M
    NAmat <- is.na(Mna)   #Defines the slice of the matrix which needs to be edited.
    Mnew[NAmat] <- 0       #Erase the NA's

    #Slightly complicated:
    NAsToFill <- ( NAmat%*%diag(as.vector(DecisionOutcomes.Raw)) )
    #   This builds a matrix whose columns j:
        #          NAmat was false (the observation wasn't missing)     ...  have a value of Zero
        #          NAmat was true (the observation was missing)         ...  have a value of the jth element of DecisionOutcomes.Raw (the 'current best guess')
    Mnew <- Mnew + NAsToFill
    #This replaces the NAs, which were zeros, with the predicted Decision outcome.

    if(Verbose) { print("Missing Values:"); print(NAmat) ; print("Imputed Values:"); print(NAsToFill)}

    #Declare Output
    MnewC <- Mnew
    ## Discriminate based on contract type
    #Fill ONLY Binary contracts by appropriately forcing predictions into their discrete (0,.5,1) slot. (reveals .5 coordination, continuous variables are more gameable).
    MnewC[,!ScaledIndex] <- apply(Mnew[,!ScaledIndex], c(1,2), function(x) Catch(x,CatchP) )
    #

  }

  if(Verbose) { print("Raw Results:"); print(Mnew) ; print("Binned:"); print(MnewC) ; print("*** ** Missing Values Filled ** ***") }

  return(MnewC)
}

#Putting it all together:
Factory <- function(M0,Scales,Rep,CatchP=.1,MaxRow=5000,Verbose=FALSE) {
  #Main Routine
  #Fill the default reputations (egalitarian) if none are provided...unrealistic and only for testing.
  if(missing(Rep)) { Rep <- ReWeight(rep(1,nrow(M0)))
                     if(Verbose) print("Reputation not provided...assuming equal influence.")
  }

  #******************
  #Fill the default scales (binary) if none are provided. In practice, this would also never be used.
  if(missing(Scales)) { Scales <- matrix( c( rep(FALSE,ncol(M0)),
                                             rep(0,ncol(M0)),
                                             rep(1,ncol(M0))), 3, byrow=TRUE, dimnames=list(c("Scaled","Min","Max"),colnames(M1)) )
                        if(Verbose) print("Scales not provided...assuming binary (0,1).")
  }
  ScaledIndex=as.logical( Scales["Scaled",] )

  MScaled <- Rescale(M0, Scales)

  #******************

  #Handle Missing Values
  Filled <- FillNa(MScaled, Rep, ScaledIndex, CatchP, Verbose)

  ## Consensus - Row Players
  #New Consensus Reward
  PlayerInfo <- GetRewardWeights(Filled,Rep,.1,Verbose)
  AdjLoadings <- PlayerInfo$FirstL

  ##Column Players (The Decision Creators)
  # Calculation of Reward for Decision Authors
  # Consensus - "Who won?" Decision Outcome
  DecisionOutcomes.Raw <- PlayerInfo$SmoothRep %*% Filled #Declare (all binary), Simple matrix multiplication ... highest information density at RowBonus, but need DecisionOutcomes.Raw to get to that
  for(i in 1:ncol(Filled)) {    #slow implementation.. 'for loop' bad on R, much faster on python
    #Discriminate Based on Contract Type
    if(ScaledIndex[i]) DecisionOutcomes.Raw[i] <- weighted.median(Filled[,i], w=PlayerInfo$SmoothRep)  #Our Current best-guess for this Scaled Decision (weighted median)
  }

  #The Outcome Itself
  #Discriminate Based on Contract Type
  DecisionOutcome.Final <- mapply(Catch,DecisionOutcomes.Raw,Tolerance=CatchP) #Declare first (assumes all binary)
  DecisionOutcome.Final[ScaledIndex] <- DecisionOutcomes.Raw[ScaledIndex]      #Replace Scaled with raw (weighted-median)
  DecisionOutcome.Final <- t( Scales["Max",] - Scales["Min",] ) %*% diag( DecisionOutcome.Final )    #Rescale these back up.
  DecisionOutcome.Final <- DecisionOutcome.Final + Scales["Min",]                                        #Recenter these back up.

  # Quality of Outcomes - is there confusion?
  Certainty <- vector("numeric",ncol(Filled))
  #Discriminate Based on Contract Type
  # Scaled first:
  DecisionOutcome.Final
  for(i in 1:ncol(Filled)) { #For each Decision
    Certainty[i] <- sum( PlayerInfo$SmoothRep [ DecisionOutcomes.Raw[i] == Filled[,i] ] )  # Sum of, the reputations which, met the condition that they voted for the outcome which was selected for this Decision.
  }
  # Overwrite Binary:
  Certainty[!ScaledIndex] <- abs(2*(DecisionOutcomes.Raw[!ScaledIndex]-.5))    # .5 is obviously undesireable for binaries, this function travels from 0 to 1 with a minimum at .5
  ConReward <- GetWeight(Certainty)                  #Grading Authors on a curve. -not necessarily the best idea? may just use Certainty instead
  Avg.Certainty <- mean(Certainty)                   #How well did beliefs converge?

  if(Verbose) {
    print("*Decision Outcomes Sucessfully Calculated*")
    print("Raw Outcomes, Certainty, AuthorPayoutFactor"); print( cbind(DecisionOutcomes.Raw,Certainty,ConReward))
  }

  ## Participation

  #Information about missing values
  NAmat <- M0*0
  NAmat[is.na(NAmat)] <- 1 #indicator matrix for missing

  #Participation Within Decisions (Columns)
  # % of reputation that answered each Decision
  ParticipationC <- 1-(PlayerInfo$SmoothRep%*%NAmat)

  #Participation Within Agents (Rows)
  # Many options

  # 1- Democracy Option - all Decisions treated equally.
  ParticipationR  <- 1-( apply(NAmat,1,sum)/ncol(M0) )

  #General Participation
  PercentNA <- 1-mean(ParticipationC)
  #(Possibly integrate two functions of participation?) Chicken and egg problem...

  if(Verbose) {
    print("*Participation Information*")
    print("Voter Turnout by question"); print( ParticipationC )
    print("Voter Turnout across questions"); print ( ParticipationR )
  }

  ## Combine Information
  #Row
  NAbonusR <- GetWeight(ParticipationR)
  RowBonus <- (NAbonusR*(PercentNA))+(PlayerInfo$SmoothR*(1-PercentNA))

  #Column
  NAbonusC <- GetWeight(ParticipationC)
  ColBonus <- (NAbonusC*(PercentNA))+(ConReward*(1-PercentNA))

  #Present Results
  Output <- vector("list",6) #Declare
  names(Output) <- c("Original","Filled","Agents","Decisions","Participation","Certainty")

  Output[[1]] <- M0
  Output[[2]] <- Filled
  Output[[3]] <- cbind(PlayerInfo$OldRep, PlayerInfo$ThisRep,PlayerInfo$SmoothRep,apply(NAmat,1,sum),ParticipationR,NAbonusR,RowBonus)
  colnames(Output[[3]]) <- c("OldRep", "ThisRep", "SmoothRep", "NArow", "ParticipationR","RelativePart","RowBonus")
  Output[[4]] <- rbind(AdjLoadings,DecisionOutcomes.Raw,ConReward,Certainty,apply(NAmat,2,sum),ParticipationC,ColBonus,DecisionOutcome.Final)
  rownames(Output[[4]]) <- c("First Loading","DecisionOutcomes.Raw","Consensus Reward","Certainty","NAs Filled","ParticipationC","Author Bonus","DecisionOutcome.Final")
  Output[[5]] <- (1-PercentNA) #Using this to set inclusion fees.
  Output[[6]] <- Avg.Certainty #Using this to set Catch Parameter

  return(Output)
}

#Long-Term
Chain <- function(X,Scales,N=2,ThisRep) {
  #Repeats factory process N times
  if(missing(ThisRep)) ThisRep <- ReWeight(rep(1,nrow(X)))

  if(missing(Scales)) { Scales <- matrix( c( rep(FALSE,ncol(X)),
                                             rep(0,ncol(X)),
                                             rep(1,ncol(X))), 3, byrow=TRUE, dimnames=list(c("Scaled","Min","Max"),colnames(M1)) )
  }

  Output <- vector("list")
  for(i in 1:N) {
    Output[[i]] <- Factory(X,Scales,Rep=ThisRep)
    ThisRep <- Output[[i]]$Agents[,"RowBonus"]
  }

  return(Output)
}

#Notes

#Voting Across Time
#Later Votes could count more
#! ...simple change = DecisionOutcome.Final becomes exponentially smoothed result of previous chains.
#! require X number of chains (blocks) before the outcome is officially determined .. or, continue next round if ~ .5, or Decisions.Raw is within a threshold ( .2 to .8)
# Would need:
# 1] Percent Voted
# 2] Time Dimension of blocks.


x = c(50,130,145,150,155,170,250)
y = dnorm(x,mean(x),sd(x))
print(y)
plot(x,y)