# NETWORK ANALYSIS
#install.packages(c("SpiecEasi","parallelDist","Matrix","Rtsne","TSP","gmodels","igraph","parallel"))
library(SpiecEasi) # for sparcc, spieceasi
library(parallelDist) #for parDist
library(Matrix) #for tril
library(Rtsne) #for Rtsne
library(TSP) #for TSP
library(gmodels) #for fast.prcomp
library(igraph) #for components
library(parallel) #for detectCores

options(menu.graphics=FALSE)

# setup functions and locations
source("microscape-s00-setup.r")

# read from disk
# these are the metadata-filtered versions
proptab <- readRDS(file.path(outfolder,"proptab_filt.rds")) #

# Clustering
# first do PCA / the difference between PCA on x and t(x) is dependent only on which side centering is done

# Cluster samples using Bray-Curtis distances
sample.bray.dist <- parDist(proptab,method="bray",threads=14)
sample.bray.dist[is.na(sample.bray.dist)] <- 1
# PCA
sample.bray.pca <- fast.prcomp(sample.bray.dist)
sample.bray.pca.uniq <- unique(sample.bray.pca$x)
# bh-tsne
sample.tsne.bray.list <- Rtsne(sample.bray.pca.uniq,verbose=TRUE, theta=0.5, pca=FALSE)
sample.tsne.bray <- sample.tsne.bray.list$Y
# add duplicates back in
sample.tsne.bray.full <- addDups(sample.bray.dist, sample.tsne.bray)
# traveling salesperson algorithm
sample.tsne.bray.dist <- dist(sample.tsne.bray.full)
sample.tsp.bray <- solve_TSP(TSP(sample.tsne.bray.dist))
sample.tsp.bray.ind <- c(sample.tsp.bray, sample.tsp.bray[1])
plot(sample.tsne.bray.full, pch='.', main="Sample Bray")
lines(sample.tsne.bray.full[sample.tsp.bray.ind,])

# Cluster sequences using Bray-Curtis distances
seq.bray.dist <- parDist(t(proptab),method="bray",threads=14) # REDO THIS PATH
seq.bray.dist[is.na(seq.bray.dist)] <- 1
seq.bray.pca <- fast.prcomp(seq.bray.dist)
seq.bray.pca.uniq <- unique(seq.bray.pca$x)
seq.tsne.bray.list <- Rtsne(seq.bray.pca.uniq,verbose=TRUE, theta=0.5, pca=FALSE)
seq.tsne.bray <- seq.tsne.bray.list$Y
seq.tsne.bray.full <- addDups(seq.bray.dist, seq.tsne.bray)
# reorder based on clustering using traveling salesperson algorithm
seq.tsne.bray.dist <- dist(seq.tsne.bray.full)
seq.tsp.bray <- solve_TSP(TSP(seq.tsne.bray.dist))
seq.tsp.bray.ind <- c(seq.tsp.bray, seq.tsp.bray[1])
plot(seq.tsne.bray.full, pch='.', main="Sequence Bray")
lines(seq.tsne.bray.full[seq.tsp.bray.ind,])

#
# # Cluster samples using Euclidean distances
# sample.euclidean.dist <- parDist(proptab,method="euclidean",threads=14)
# sample.euclidean.dist[is.na(sample.euclidean.dist)] <- 1
# sample.euclidean.pca <- fast.prcomp(sample.euclidean.dist)
# sample.euclidean.pca.uniq <- unique(sample.euclidean.pca$x)
# sample.tsne.euclidean.list <- Rtsne(sample.euclidean.pca.uniq,verbose=TRUE, theta=0.5, pca=FALSE)
# sample.tsne.euclidean <- sample.tsne.euclidean.list$Y
# sample.tsne.euclidean.full <- addDups(sample.euclidean.dist, sample.tsne.euclidean)
# # reorder based on clustering using traveling salesperson algorithm
# sample.tsne.euclidean.dist <- dist(sample.tsne.euclidean.full)
# sample.tsp.euclidean <- solve_TSP(TSP(sample.tsne.euclidean.dist))
# sample.tsp.euclidean.ind <- c(sample.tsp.euclidean, sample.tsp.euclidean[1])
# plot(sample.tsne.euclidean.full, pch='.', main="Sample Euclidean")
# lines(sample.tsne.euclidean.full[sample.tsp.euclidean.ind,])
#
# # Cluster sequences using Euclidean distances
# seq.euclidean.dist <- parDist(t(proptab),method="euclidean",threads=14)
# seq.euclidean.dist[is.na(seq.euclidean.dist)] <- 1
# seq.euclidean.pca <- fast.prcomp(seq.euclidean.dist)
# seq.euclidean.pca.uniq <- unique(seq.euclidean.pca$x)
# seq.tsne.euclidean.list <- Rtsne(seq.euclidean.pca.uniq,verbose=TRUE, theta=0.5, pca=FALSE)
# seq.tsne.euclidean <- seq.tsne.euclidean.list$Y
# seq.tsne.euclidean.full <- addDups(seq.euclidean.dist, seq.tsne.euclidean)
# # reorder based on clustering using traveling salesperson algorithm
# seq.tsne.euclidean.dist <- dist(seq.tsne.euclidean.full)
# seq.tsp.euclidean <- solve_TSP(TSP(seq.tsne.euclidean.dist))
# seq.tsp.euclidean.ind <- c(seq.tsp.euclidean, seq.tsp.euclidean[1])
# plot(seq.tsne.euclidean.full, pch='.', main="Sequence Euclidean")
# lines(seq.tsne.euclidean.full[seq.tsp.euclidean.ind,])

dev.off()

saveRDS(sample.bray.dist,file.path(outfolder,"sample_bray_dist.rds"))
saveRDS(seq.bray.dist,file.path(outfolder,"seq_bray_dist.rds"))
# saveRDS(sample.euclidean.dist,file.path(outfolder,"sample_euclidean_dist.rds"))
# saveRDS(seq.euclidean.dist,file.path(outfolder,"seq_euclidean_dist.rds"))

saveRDS(sample.bray.pca,file.path(outfolder,"sample_bray_pca.rds"))
saveRDS(seq.bray.pca,file.path(outfolder,"seq_bray_pca.rds"))
# saveRDS(sample.euclidean.pca,file.path(outfolder,"sample_euclidean_pca.rds"))
# saveRDS(seq.euclidean.pca,file.path(outfolder,"seq_euclidean_pca.rds"))

saveRDS(sample.tsne.bray.full,file.path(outfolder,"sample_bray_tsne.rds"))
saveRDS(seq.tsne.bray.full,file.path(outfolder,"seq_bray_tsne.rds"))
# saveRDS(sample.tsne.euclidean.full,file.path(outfolder,"sample_euclidean_tsne.rds"))
# saveRDS(seq.tsne.euclidean.full,file.path(outfolder,"seq_euclidean_tsne.rds"))

saveRDS(sample.tsp.bray,file.path(outfolder,"sample_bray_tsp.rds"))
saveRDS(seq.tsp.bray,file.path(outfolder,"seq_bray_tsp.rds"))
# saveRDS(sample.tsp.euclidean,file.path(outfolder,"sample_euclidean_tsp.rds"))
# saveRDS(seq.tsp.euclidean,file.path(outfolder,"seq_euclidean_tsp.rds"))


 require(foreign)
 require(nnet)
 require(ggplot2)
 require(reshape2)

 ml <- read.table("d:/hsbdemo.csv", header=TRUE, sep=",", row.names="id")
 with(ml, table(ses, prog))

with(ml, do.call(rbind, tapply(write, prog,
  function(x) c(M = mean(x), SD = sd(x)))))

ml$prog2 <- relevel(ml$prog, ref = "academic")
test <- multinom(prog2 ~ ses + write, data = ml)

summary(test)

z <- summary(test)$coefficients/summary(test)$standard.errors
z

p <- (1 - pnorm(abs(z), 0, 1))*2
p

exp(coef(test))

head(pp <- fitted(test))

dses <- data.frame(ses = c("low", "middle", "high"),write = mean(ml$write))

predict(test, newdata = dses, "probs")

dwrite <- data.frame(ses = rep(c("low", "middle", "high"), each = 41), write = rep(c(30:70), 3))

pp.write <- cbind(dwrite, predict(test, newdata = dwrite, type = "probs", se = TRUE))

by(pp.write[, 3:5], pp.write$ses, colMeans)

lpp <- melt(pp.write, id.vars = c("ses", "write"), value.name = "probability")
head(lpp)

ggplot(lpp, aes(x = write, y = probability, colour = ses)) +
     geom_line() +
     facet_grid(variable ~ ., scales="free")

Chapter 02/2Multinomial Logistic Regression.r


# devtools::install_github( "ingewortel/celltrackR" )
setwd("~/Uni/4/NC/evolutionary-potts/analyses/")
library(celltrackR)
library(VGAM)

levywalk <- function (nsteps = 100, dim = 3, mean = .3, s = 1)
{
  if (dim < 1) {
    stop("1 or more spatial dimensions required!")
  }
  d <- pmin(rlevy(nsteps, location = mean, scale = s/100), replicate(nsteps, 400))

  a <- runif(nsteps, 0, 2*pi)
  m <- cbind(0:nsteps, stats::diffinv(d * cos(a)), stats::diffinv(d * sin(a)))
  if (dim <= 3) {
    colnames(m) <- c("t", "x", "y", "z")[1:(dim + 1)]
  }
  else {
    colnames(m) <- c("t", paste0("x", 1:dim))
  }
  m
}

fitlevy <- function(track) {
  x <- sapply(subtracks(track, 1), FUN = displacement)
  x <- data.frame(x)
  fit <- vglm(x ~ 1, levy(location = 0), data=x)
  return(fit)
}

tracklhist <- function(tracks, l) {
  hist(sapply(subtracks(tracks, l), FUN = trackLength), breaks = 50,
       main =  paste("tracks of length", as.character(l), sep=" "),
       xlab="average track length")
}

stats <- function(tracks) {
  dat <- aggregate(tracks, squareDisplacement, FUN="mean.se",
                   subtrack.length = seq(1, (maxTrackLength(tracks) / 2)))
  with( dat ,{
    plot( mean ~ i, xlab="step size",
          ylab="mean square displacement", type="l", main="Mean square displacement")
    segments( i[seq(1, length(i), 5)], lower[seq(1, length(i), 5)], y1=upper[seq(1, length(i), 5)] )
  } )

  # dat <- aggregate(tracks, overallNormDot, subtrack.length = seq(2, (maxTrackLength(tracks) - 1)))
  # plot(dat, type='l', main="autocorrelation for different step sizes",
  #      xlab="step size", ylab="autocorrelation", ylim=c(-1,1))
  #
  # dat <- aggregate(tracks, overallAngle, subtrack.length = seq(2, (maxTrackLength(tracks) - 1)))
  # plot(dat, type='l', main="mean turning angle for different step sizes",
  #      xlab="step size", ylab="mean turning angle", ylim=c(0, pi))

  tracklhist(tracks, 1)
  tracklhist(tracks, 10)
  tracklhist(tracks, 30)
  tracklhist(tracks, 50)
}

others <- function() {
  par(mfcol=c(5,2))

  br <- as.tracks(list(cell = brownianTrack(nsteps = nrow(data), dim = 2, sd = trackLength(tracks[["cell"]])/nrow(data))))
  plot(br, main="brownian motion")

  stats(br)

  lv <- as.tracks(list(cell = levywalk(nsteps = nrow(data), dim = 2, s = -0.855579)))
  plot(lv, main="levy walk")

  stats(lv)
}

analysetype <- function(prefix, names) {
  data <- list()
  for (n in names) {
    print(paste(prefix, "/", n, ".csv", sep=""))
    d <- read.csv(paste(prefix, "/", n, ".csv", sep=""))
    data[[n]] <- as.matrix(d)
  }

  par(mfrow=c(3,2))

  tracks <- as.tracks(data)
  plot(tracks, main="Evolutionary cell", xlim=c(0,400), ylim=c(0,400), cex = 0, pch.start=NULL, pch.end=1)

  stats(tracks)
  return(tracks)
}

# analysetype("none", c("600_best", "600_0", "700_best", "700_1", "800_best", "800_0"))
# analysetype("medium", c("300_0", "300_45", "400_0", "400_2", "500_0", "500_46"))
# analysetype("high", c("10_0", "10_1", "100_0", "100_44", "200_17", "200_0"))
analysetype("high", c("10_0"))
analysetype("medium", c("300_45"))
analysetype("none", c("600_0"))


 DTBRFS Example Program Results

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

 Backward errors (machine-dependent)
       4.7E-17    2.5E-17
 Estimated forward error bounds (machine-dependent)
       5.4E-14    5.8E-14


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

source("function.r")
inputfile = "hackensack.csv"
outputfile = "Results/hackensack_constrained_MCMC_"
outputplot = "Hackensack River"
data_col = 3
year_col = 1
ReferenceYear = 2018
ReturnPeriod = 100
burn_in = 500
CSVFile = read.csv(file = inputfile, header = T)
Data = CSVFile[,data_col]
Year = CSVFile[,year_col]
time_index = time.index(Year,ReferenceYear)
parameters = draw.MCMC.samples(Data,time_index,InitialValues = c(50,1,20,0.8),LocationInterceptPrior = c(0,200),LocationSlopePrior = c(0,5),ScalePrior = c(0,50),ShapePrior = c(-1,1),ProposalWidth = c(2,0.15,1,0.05),n_samples=10000)
parameters = parameters[-c(1:burn_in),]
mu_post = parameters[,1]
muslope_post = parameters[,2]
scale_post = parameters[,3]
shape_post = parameters[,4]
ret_post=rep(-1,length(mu_post))
for (i in 1:length(mu_post)){
  ret_post[i] = calc.nstat.ret.event(mu_post[i],muslope_post[i],scale_post[i],shape_post[i],n = ReturnPeriod,baseyear = ReferenceYear, analysisyear = ReferenceYear, epsilon = 1)
}

bw = c(2,0.02,0.75,0.020,10)
pdf(paste0(outputfile,"posterior_location_intercept.pdf"))
hist(mu_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(mu_post, bw = bw[1]), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_location_slope.pdf"))
hist(muslope_post,main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(muslope_post, bw = bw[2], from = 0.05), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_scale.pdf"))
hist(scale_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(scale_post, bw = bw[3]), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_shape.pdf"))
hist(shape_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(shape_post, bw = bw[4]), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_retevent.pdf"))
hist(ret_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(ret_post, bw = bw[5]), type = 'l', lwd = 2)
dev.off()

## CDF plot for return event
train_points = 100
cdf = ecdf(ret_post)
start = 0.8*quantile(cdf)[1]
end = 1.1*quantile(cdf)[5]
quants = seq(start,end,length.out = train_points)
quants_CDF = cdf(quants)
pdf(paste0(outputfile,"retevent-cdf.pdf"))
plot(quants,quants_CDF, type = 'l', lwd = 2,xlab = NA, main = outputplot,ylab = "Probability", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
abline(h=0,lty=4,lwd=2)
abline(h=1,lty=4,lwd=2)
dev.off()

### Expected and MAP Values of the parameters and the return event and the 95% C.I. for return event
d_mu = density(mu_post, bw = bw[1])
d_muslope = density(muslope_post, bw = bw[2])
d_scale = density(scale_post, bw= bw[3])
d_shape = density(shape_post, bw = bw[4])
d_retEvent = density(ret_post, bw = bw[5])

mu_exp = mean(mu_post)
mu_map = d_mu$x[which.max(d_mu$y)]
muslope_exp = mean(muslope_post)
muslope_map = 0
scale_exp = mean(scale_post)
scale_map = d_scale$x[which.max(d_scale$y)]
shape_exp =mean(shape_post)
shape_map = d_shape$x[which.max(d_shape$y)]
retEvent_exp = mean(ret_post)
retEvent_map = d_retEvent$x[which.max(d_retEvent$y)]
NLLH_exp = likelihood.val(Data,time_index,mu_exp,muslope_exp,scale_exp,shape_exp)
NLLH_map = likelihood.val(Data,time_index,mu_map,muslope_map,scale_map,shape_map)
cat("Expected Values of the Parameters:",'\n')
cat("Location Intercept:", mu_exp, '\n')
cat("Location Slope:", muslope_exp, '\n')
cat("Scale:",scale_exp, '\n')
cat("Shape:", shape_exp, '\n')
cat("100 year Return Event:", retEvent_exp, '\n')
cat("NLLH:", NLLH_exp, '\n')
cat('\n',"MAP values of the Parameters:",'\n')
cat("Location Intercept:", mu_map, '\n')
cat("Location Slope:", muslope_map, '\n')
cat("Scale:",scale_map, '\n')
cat("Shape:", shape_map, '\n')
cat("100 year Return Event:", retEvent_map, '\n')
cat("NLLH:", NLLH_map, '\n')
## 95% C.I for Return Event

d_sort = sort(ret_post)
lb = d_sort[round(0.025*9500)]
ub = d_sort[round(0.975*9500)]

cat("95% C.I. for Return Event: [",lb,ub,"]",'\n' )


data("iris")
library(dplyr)
library(caret)

# Train and Test Dataset
iris2 <- sample_n(iris, 150)
train <- iris2[1:120, ]
test <- iris2[121:150, ]

# Training
cl <- train$Species
fit <- knn3(Species~., data = train, k = 3)
predictions <- predict(fit, test[, -5], type = "class")
table(predictions, test$Species)


# Research the Data & Problem ----

# Set WD ----
setwd("C:/Users/Pedro G/OneDrive/Desktop/crypto-energy-final-project")

# Load Libraries ----
source("./R functions/libraries.r")
libraries()

# Source Functions ----

# Import the Data
data <- read_csv("data/data.csv")

# Inspect the Data ----
print(head(data))

# Subset Ignoble Variables ----
sub = data[,3:9]
str(sub)

# Explore the Original Data ----
summary(sub) # summary stats

cor = cor(sub) # correlation
png("pictures/original/cor_O.png")
print(corrplot::corrplot(cor))
dev.off()

p1 = ggplot(data, aes(timestamp, ETH_Close)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('ETH Close Price')

png("pictures/original/ETH_Close_ggplot.png")
print(p1)
dev.off()

p2 = ggplot(data, aes(timestamp, BTC_Close)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('BTC Close Price')

png("pictures/original/BTC_Close_ggplot.png")
print(p2)
dev.off()

p3 = ggplot(data, aes(timestamp, ETH_Energy)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('ETH Energy Consumption (TWh)')

png("pictures/original/ETH_Energy_ggplot.png")
print(p3)
dev.off()

p4 = ggplot(data, aes(timestamp, BTC_Energy)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('BTC Energy Consumption (TWh)')

png("pictures/original/BTC_Energy_ggplot.png")
print(p4)
dev.off()

p5 = ggplot(data, aes(timestamp, breakeven_inflation)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Breakeven Inflation')

png("pictures/original/breakeven_inflation_ggplot.png")
print(p5)
dev.off()

p6 = ggplot(data, aes(timestamp, BTC_Volume)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Bitcoin Volume')

png("pictures/original/BTC_Volume_ggplot.png")
print(p6)
dev.off()

p7 = ggplot(data, aes(timestamp, ETH_Volume)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Ethereum Volume')

png("pictures/original/ETH_Volume_ggplot.png")
print(p7)
dev.off()

png("pictures/original/grid_line_O.png")
print(plot_grid(p1, p2, p3, p4, p5, p6, p7))
dev.off()

# - Preprocess the Data ----
prep = data[3:9]
str(prep)
missing = prep %>% mice::mice(m=5,maxit=50,meth="sample",seed=500,print = FALSE)
missing <- mice::complete(missing, action=as.numeric(2))
prep = na.omit(missing)
prep = prep %>% outlieR::impute(flag = NULL, fill = "mean",
                                level = 0.1, nmax = NULL,
                                side = NULL, crit = "lof",
                                k = 5, metric = "euclidean", q = 3)
preProClean <- preProcess(x = prep, method = c("scale", "center"))
prep <- predict(preProClean, prep %>% na.omit)
print(str(prep))
write.csv(prep,"data/preprocessed_data.csv")

# Exploration of the Processed ----

# Import the Processed Data
process_data <- read_csv("data/preprocessed_data.csv")

# Inspect the Processed Data ----
print(head(process_data))

# Subset Ignoble Variables ----
sub = process_data[1:9]
str(sub)

summary(sub) # summary stats

cor = cor(sub) # correlation
png("pictures/preprocessed/cor_P.png")
print(corrplot::corrplot(cor))
dev.off()

p1 = ggplot(data, aes(timestamp, ETH_Close)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('ETH Close Price')

png("pictures/preprocessed/ETH_Close_ggplot.png")
print(p1)
dev.off()

p2 = ggplot(data, aes(timestamp, BTC_Close)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('BTC Close Price')

png("pictures/preprocessed/BTC_Close_ggplot.png")
print(p2)
dev.off()

p3 = ggplot(data, aes(timestamp, ETH_Energy)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('ETH Energy Consumption (TWh)')

png("pictures/preprocessed/ETH_Energy_ggplot.png")
print(p3)
dev.off()

p4 = ggplot(data, aes(timestamp, BTC_Energy)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('BTC Energy Consumption (TWh)')

png("pictures/preprocessed/BTC_Energy_ggplot.png")
print(p4)
dev.off()

p5 = ggplot(data, aes(timestamp, breakeven_inflation)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Breakeven Inflation')

png("pictures/preprocessed/breakeven_inflation_ggplot.png")
print(p5)
dev.off()

p6 = ggplot(data, aes(timestamp, BTC_Volume)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Bitcoin Volume')

png("pictures/preprocessed/BTC_Volume_ggplot.png")
print(p6)
dev.off()

p7 = ggplot(data, aes(timestamp, ETH_Volume)) +
  stat_summary(fun.y = mean, ##adds the points
               geom = "point") +
  stat_summary(fun.y = mean, ##adds the line
               geom = "line",
               aes(group=1)) +
  stat_summary(fun.data = mean_cl_normal, ##adds the error bars
               geom = "errorbar",
               width = .2) +
  xlab('Time')+
  ylab('Ethereum Volume')

png("pictures/preprocessed/ETH_Volume_ggplot.png")
print(p7)
dev.off()

png("pictures/preprocessed/grid_line_P.png")
print(plot_grid(p1, p2, p3, p4, p5, p6, p7))
dev.off()


# a vector (letters are builtin)
letters
#  [1] "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s"
# [20] "t" "u" "v" "w" "x" "y" "z"

# picking one element
sample(letters, 1)
# [1] "n"

# picking some elements with repetition, and concatenating to get a word
paste(sample(letters, 10, rep=T), collapse="")
# [1] "episxgcgmt"


#PIE CHARTS
#difficult to compare values of slices
par(mfrow=c(2,2)) #4 graphs on 1
slices<-c(10, 12,4,16,8)
lbls<-c("US","UK","Australia","Germany" ,"France")

pie(slices, labels=lbls, main="Simple Pie Chart")

pct<- round(slices/sum(slices)*100)
lbls2<-paste(lbls, " ", pct, "%", sep="") # add % to chart
pie(slices, labels=lbls2, col=rainbow(length(lbls2)), main="Pie Chart with Percnetages")

library(plotrix)
pie3D(slices, labels=lbls,explode=0.1, main="3D Pie Chart")

mytable <- table(state.region)
lbls3 <- paste(names(mytable), "\n", mytable, sep="")
pie(mytable, labels = lbls3, main="Pie Chart from a Table\n (with sample sizes)")


# This version (2) based on daily, not monthly, NCDC data

setwd("H:\\idahochart\\records\\weather")

## PPT
pptD = read.csv("total_monthly_ppt_v2.csv")

#convert to mm
pptD[,2:13]=pptD[,2:13]*25.4

pptD$pptWin=rowSums(pptD[,c("JAN","FEB","MAR")])
pptD$pptSpr=rowSums(pptD[,c("APR","MAY","JUN")])
pptD$pptSum=rowSums(pptD[,c("JUL","AUG","SEP")])
pptD$pptFall=rowSums(pptD[,c("OCT","NOV","DEC")])

Nrows=NROW(pptD)
pptD$pptAnnual=c(NA,rowSums(pptD[2:Nrows,c("pptWin","pptSpr")])+rowSums(pptD[1:(Nrows-1),c("pptSum","pptFall")]))

lagPpt = pptD[,c("YEAR","pptAnnual")]
names(lagPpt)[2]="pptLag1"
lagPpt$YEAR=lagPpt$YEAR+1

pptD=merge(pptD,lagPpt,all.x=T)

## SNOW-------------------------------------------------------
snowD = read.csv("total_monthly_snow_v2.csv")
#convert to cm
snowD[,2:13]=snowD[,2:13]*2.54
Nrows=NROW(snowD)
#sum snowDec thru March
snowD$snow=c(NA,(snowD$DEC[1:(Nrows-1)]+rowSums(snowD[2:Nrows,2:4])))
snowD$FebMarSnow=snowD$FEB+snowD$MAR

## SNOW DEPTH-----------------------------------------------------
snowdD = read.csv("total_monthly_snowdepth_v2.csv")
#convert to cm
snowdD[,2:13]=snowdD[,2:13]*2.54
Nrows=NROW(snowdD)
#sum snowDec thru March
snowdD$Sdepth=NA
snowdD$Sdepth[2:Nrows]=rowMeans(cbind(snowdD$DEC[1:(Nrows-1)],snowdD[2:Nrows,2:4]))
snowdD$FebMarSDepth=rowMeans(snowdD[,c("FEB","MAR")])

## MEAN TEMP-------------------------------------------------------
TmeanD = read.csv("monthly_mean_temp_v2.csv")
#convert to C
TmeanD[,2:13]=(5/9)*(TmeanD[,2:13]-32)

TmeanD$TmeanWin=rowMeans(TmeanD[,c("JAN","FEB","MAR")])
TmeanD$TmeanSpr=rowMeans(TmeanD[,c("APR","MAY","JUN")])
TmeanD$TmeanSum=rowMeans(TmeanD[,c("JUL","AUG","SEP")])
TmeanD$TmeanFall=rowMeans(TmeanD[,c("OCT","NOV","DEC")])

Nrows=NROW(TmeanD)
TmeanD$TmeanAnnual==c(NA,rowSums(TmeanD[2:Nrows,c("TmeanWin","TmeanSpr")])+rowSums(TmeanD[1:(Nrows-1),c("TmeanSum","TmeanFall")]))

# format output
climD=merge(pptD[,c(1,14:NCOL(pptD))],snowD[,c(1,14,15)],all=T)
climD=merge(climD,snowdD[,c(1,14,15)],all=T)
climD=merge(climD,TmeanD[,c(1,14:NCOL(TmeanD))],all=T)

write.table(climD,"seasonal_climate_Jul2Jun_v2.csv",row.names=F,sep=",")


# this script analyse the raw data that we collected.
# for example how frequent a tag in sentences
# distribution of contextual and non-contextual sentences in threads

data <- read.csv(file = "reasons.csv", header = TRUE)
# find frequency of each category
table(data$TagCategory)

# find frequency of each tag

data.additionalcontext <- data[data$AdditionContext=="Yes",]
table(data.additionalcontext$CandidateAdditionalContext)

# find difference between two distributions
library(dplyr)
library(tidyr)
data.answers <- distinct(data, data$AnswerID, .keep_all = TRUE)
data.answers <- data.answers %>% drop_na(AnswerVote)

data.comments <- distinct(data, data$CommentID, .keep_all = TRUE)
data.comments <- data.comments %>% drop_na(CommentID)
data.answercomments <- data.comments %>% drop_na(AnswerID)
data.answercomments <- data.answercomments %>% drop_na(CommentID)
data.questioncomments <- setdiff(data.comments, data.answercomments)
data.questioncomments <- data.questioncomments %>% drop_na(CommentID)

# all together
data.all <- distinct(data, data$AnswerID, data$CommentID, .keep_all = TRUE)
data.all <-  data.all %>% drop_na(QuestionID)
data.all$Votes <- ifelse(is.na(data.all$AnswerVote), data.all$CommentVote, data.all$AnswerVote)

# boxplot
x11(width=8, height=8)
par(mfrow=c(2,2))
boxplot(data=data.answers, data.answers$AnswerVote ~ data.answers$AdditionContext,
        boxwex = 0.4, ylim=c(0,50),
        ylab = "Score", xlab = "Distribution of answers", xaxt="n",
        main = "(a)")
axis(1, c("No \nadditional contexts", "With \nadditional contexts"), at=1:2, las=1, tck=0)

boxplot(data=data.answercomments, data.answercomments$CommentVote ~ data.answercomments$AdditionContext,
        boxwex = 0.4, ylim=c(0,10),
        ylab = "Score", xlab = "Distribution of answer comments", xaxt="n",
        main="(b)")
axis(1, c("No \nadditional contexts", "With \nadditional contexts"), at=1:2, las=1, tck=0)

boxplot(data=data.questioncomments, data.questioncomments$CommentVote ~ data.questioncomments$AdditionContext,
        boxwex = 0.4, ylim=c(0,10),
        ylab = "Score", xlab = "Distribution of questoin comments", xaxt="n",
        main="(c)")
axis(1, c("No \nadditional contexts", "With \nadditional contexts"), at=1:2, las=1, tck=0)

savePlot(filename = "voteDist.png", device = dev.cur())
#boxplot(data.all$Votes ~ data.all$AdditionContext,
#        boxwex = 0.4, ylim=c(0,50),
#        ylab = "Score", xlab = "Distribution of threads", xaxt="n")
#axis(1, c("No \nadditional contexts", "With \nadditional contexts"), at=1:2, las=1, tck=0)

# compare distributions
wilcox.test(data.answers$AnswerVote ~ data.answers$AdditionContext)
wilcox.test(data.answercomments$CommentVote ~ data.answercomments$AdditionContext)
wilcox.test(data.questioncomments$CommentVote ~ data.questioncomments$AdditionContext)

wilcox.test(data.all$Votes ~ data.all$AdditionContext)

# compare variences
library(lawstat)
levene.test(data.answers$AnswerVote, data.answers$AdditionContext)
levene.test(data.answercomments$CommentVote, data.answercomments$AdditionContext)
levene.test(data.questioncomments$CommentVote, data.questioncomments$AdditionContext)

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

data <- read.csv(file = "rq4.csv", header = TRUE)
data.votes <- data[data$VotedAdditionalContexts == "Yes", ]
nrow(data.votes[data.votes$AdditionContext == "Yes"
                & data.votes$AnswerID > 0 & data.votes$CommentID == "NA", ])
nrow(data.votes[data.votes$AdditionContext == "No"
                & data.votes$AnswerID > 0 & data.votes$CommentID == "NA", ])

nrow(data.votes[data.votes$AdditionContext == "Yes"
                & data.votes$AnswerID > 0 & data.votes$CommentID > 0, ])
nrow(data.votes[data.votes$AdditionContext == "No"
                & data.votes$AnswerID > 0 & data.votes$CommentID > 0, ])

nrow(data.votes[data.votes$AdditionContext == "Yes"
                & data.votes$AnswerID == "NA" & data.votes$CommentID > 0, ])
nrow(data.votes[data.votes$AdditionContext == "No"
                & data.votes$AnswerID == "NA" & data.votes$CommentID > 0, ])


#' Variable Shields number method to calculate paleoslope from preserved sediments
#'
#' \code{lynds_two} calculates the slope of an ancient river, provided you know the flow depth, the grain size of the bed material, and make some assumptions about shear stress in the river. The important part here is that the function implements a different shields number depending on whether the bed material is fine or coarse. Implemented from Lynds et al. (2014)
#' @param ws_mode Allows you to choose one of two different methods for calculating the settling velocity of the bedload particles. 'simple' ignores the Corey Shape Factor and the Powers Index. See documentation for \code{settle} for more information. For now, this feature is disabled.
#' @param D The median grain size of bedload sediments in meters.
#' @param H The paleoflow depth in meters.
#' @param rhos The density of the sediment in kg/m^3
#' @param rhof The density of the fluid in kg/m^3
#' @return Returns a single dimensionless number giving the slope.
#' @export

#	Second method to reconstruct paleoslope from Lynds et al. (2014)
#	Eric Barefoot
#	Nov 2017

#	function takes two main arguments, the particle size, and the depth, both in meters. Then it uses them to calculate a slope, using a raft of assumptions.
#	to use a more complicated way to calculate settling velocity, use ws_mode = 'complex'

#	requires the 'settle' function, which lives in the same package

#source(file.path(fd,'settle.r'))

lynds_two = function(D, H, ws_mode = 'simple', rhos = 2650, rhof = 1000) {

	#	NOTES:
	#	in the future, need to allow options for csf and PI, but implement more smoothly.

	#	D is the D50b or median bedload grainsize IN METERS
	#	H is Hbf or the bankfull flow depth IN METERS

	#	constants

	g = 9.8				#	gravity m/s^2
	nuu  = 1.004e-6		#	kinematic viscocity in Pa s at 20C
	rhos = rhos			# 	in kg/m^3
	rhof = rhof			#	in kg/m^3
	R = rhos/rhof - 1	#	should be close to 1650 for qtz sand
	csf = 0.7			# 	some csf for grains
	PI = 3.5			# 	average for natural grains. Varies from 0-6.

	#	key is to find the settling velocity of particles. there exist a wide variety of schemas for this. lynds uses dietrich 1982, realized in function 'settle'.

	#	function giving the particle reynolds number for a size class.

	Rep = function(D, R, g, nuu) {
		Rep = (D * sqrt(D * R * g)) / nuu
		return(Rep)
	}

	#	now determine Wstar

	Wstar = settle(ws_mode = 'simple', D, constants = list(g = g, nuu = nuu, rhos = rhos, rhof = rhof))$wstar

	#	now determine Rep

	Rp = Rep(D, R, g, nuu)

	#	determine the size class that we are in. divide for fine sand or medium sand

	if(D >= 0.25e-3 & D < 0.5e-3){szcls = 'medium'}
	else if (D < 0.25e-3 & D >= 0.0625e-3){szcls = 'fine'}
	else if (D >= 0.5e-3) {szcls = 'medium'; warning('coarse sand, choosing medium value')}
	else if (D < 0.0625e-3) {szcls = 'fine'; warning('very fine silt, choosing fine value')}
	else {stop('something is wrong with the ustar/ws values')}

	#	switch defines value for ustar/ws ratio

	u_w = switch(szcls,
				 medium = 1.6,
				 fine = 3.1
				)

	#	now solve equation 9 in Lynds 2014 for slope

	S = ((R * D) / H) * (u_w * (Wstar / Rp)^(1/3))^2

	return(S)

}


suppressMessages(library(craze))

x = matrix(as.double(1:6), 3)
v = c(3.0, 7.0)
x_fml = fmlmat(x)
v_fml = fmlmat(v)

test = as.matrix(diag(x_fml))
truth = diag(x)
stopifnot(all.equal(test, truth))

test = as.matrix(diag(v_fml, 5, 4))
truth = diag(v, 5, 4)
stopifnot(all.equal(test, truth))


library(tidyverse)
library(scales)
library(readxl)
library(ggforce)
setwd("~/Public_Policy/Projects/Voter Turnout Analysis")

turnout_dat = read_excel("data/voter turnout by age and ideology.xlsx", 'clean table')

##### get voter turnout / vote share by #####
reg_vote_dat = read_excel("data/voter turnout by age and ideology.xlsx", '2018 nov midterm reg turnout', skip = 3) %>%
  filter(
    !age %in% c('80-84', '85 and over')
  ) %>%
  mutate(
    age_int = ifelse(age == '80+', 80, as.integer(age)),
    age_group = cut(age_int, breaks = c(18, 29, 44, 64, 80), include.lowest = T, right = T, ordered_result = T)
  )
names(reg_vote_dat) = str_replace_all(names(reg_vote_dat), '[ ]', '_')

total_voted = sum(reg_vote_dat$citizen_voted)
total_citizen_pop = sum(reg_vote_dat$citizen_pop)

reg_vote_dat = mutate(reg_vote_dat,
                      share_of_citizen_pop = citizen_pop / total_citizen_pop,
                      share_of_vote = citizen_voted / total_voted,
                      influence_ratio = share_of_vote / share_of_citizen_pop
                      )

long_reg_vote_dat = pivot_longer(reg_vote_dat, cols = c('share_of_citizen_pop', 'share_of_vote')) %>%
  filter(age_int != 80)

influence_polynomial = lm(influence_ratio ~ age_int + I(age_int^2) + I(age_int^3) + I(age_int^4), data = reg_vote_dat)
reg_vote_dat$influence_polynomial_pred = predict(influence_polynomial)

summary(influence_polynomial)

breakeven_influence = optim(par = c(18), lower=18, upper = 79, fn = function(par){
  pred_dat = data.frame(age_int = par[1])
  the_prediction = predict(influence_polynomial, newdata= pred_dat)
  return((the_prediction - 1)^2)
}, method = 'Brent')

ggplot(reg_vote_dat, aes(age_int, influence_ratio)) +
  theme_bw() +
  geom_point() +
  geom_line(aes(y = influence_polynomial_pred), size = 1, colour = 'blue') +
  geom_hline(aes(yintercept = 1), size =  0.75) +
  geom_vline(aes(xintercept = breakeven_influence$par), size = .75) +
  scale_x_continuous(breaks = seq(20, 80, by = 5)) +
  labs(
    y = 'Influence Ratio\n(vote share / population share)\n', x = '\nAge',
    title = 'Voter Influence by Age, Nov. 2018 Midterm Election',
    subtitle = str_wrap("An influence ratio of 1 means an age group's share of the vote is equal to their share of the population (one person, one vote).", 90)
  ) +
  theme(
    legend.text = element_text(size = 12),
    title = element_text(size = 16),
    text = element_text(size = 14),
    plot.subtitle = element_text(size = 12)
  )
ggsave('output/voter_influence_by_age.png', height = 8, width = 8, units = 'in', dpi = 600)

ggplot(long_reg_vote_dat, aes(age_int, value, colour = name)) +
  theme_bw() +
  geom_point() +
  stat_smooth(se = F, span = 0.35, size = 1.25) +
  scale_y_continuous(labels = percent) +
  scale_x_continuous(breaks = seq(20, 80, by = 5)) +
  scale_colour_manual(
    name = '',
    labels = c('share_of_citizen_pop' = 'Share of Population', 'share_of_vote' = 'Share of Vote'),
    values = c('share_of_citizen_pop' = 'steelblue', 'share_of_vote' = 'orange')
  ) +
  labs(
    y = 'Percent Share\n', x = '\nAge'
  )
ggsave('output/share_of_vote_vs_pop_share.png', height = 8, width = 9, units = 'in', dpi = 600)

stats_by_age_group = group_by(reg_vote_dat, age_group) %>%
  summarize(
    tot_citizen_pop = sum(citizen_pop),
    tot_citizen_registered = sum(citizen_registered),
    tot_citizen_voted = sum(citizen_voted)
  ) %>%
  mutate(
    share_of_vote = tot_citizen_voted / total_voted
  )

ggplot(reg_vote_dat, aes(age_int, citizen_pct_voted)) +
  geom_point() +
  stat_smooth()

ggplot(reg_vote_dat, aes(age_int, pct_citizen_registered)) +
  geom_point() +
  stat_smooth()

##### get partisan leanings by age group #####
age_pop_by_year = read_excel("data/voter turnout by age and ideology.xlsx", 'age by indv years') %>%
  pivot_longer(-Age, names_to = 'year') %>%
  mutate(
    age_int = ifelse(Age == '100+', 100, as.integer(Age)),
    age_group = cut(age_int, breaks = c(18, 35, 51, 70, 88), include.lowest = T, right = T, ordered_result = T)
         ) %>%
  filter(year == 2018, age_int >= 18, !is.na(age_group))

counts_by_age_group =
  group_by(age_pop_by_year, age_group) %>%
  summarize(
    total_pop = sum(value),
    n_ages = n_distinct(age_int),
    min_age = min(age_int),
    max_age = max(age_int)
  )
partisan_lean_dat = read_excel("voter turnout by age and ideology.xlsx", 'lean_data_clean') %>%
  filter(age_group != 'Total')

counts_by_age_group_partisanship = inner_join(counts_by_age_group, partisan_lean_dat) %>%
  pivot_longer(
    cols = c('lib_dem', 'mod_dem', 'mod_rep', 'con_rep'),
    values_to = 'proportion',
    names_to = 'partisan_lean'
  ) %>%
  mutate(
    value_vs_pop = proportion * total_pop,
    party_lean = ifelse(str_detect(partisan_lean, 'dem'), 'DEM', 'REP'),
    age_group = factor(age_group, levels = levels(age_pop_by_year$age_group))
  )

counts_by_party = group_by(counts_by_age_group_partisanship, party_lean) %>%
  summarize(
    party_total = sum(value_vs_pop)
  ) %>%
  mutate(
    pct_of_total = party_total / sum(party_total)
  )

counts_by_party_age = group_by(counts_by_age_group_partisanship, age_group, party_lean) %>%
  summarize(
    party_age_total = sum(value_vs_pop)
  ) %>%
  inner_join(counts_by_party) %>%
  mutate(
    pct_of_party_total = party_age_total / party_total
  )
ggplot(counts_by_party_age, aes(age_group, party_age_total, fill = party_lean)) +
  geom_bar(stat = 'identity', position = 'dodge') +
  scale_y_continuous(labels = comma)

bar_width = 0.75
ggplot(counts_by_party_age, aes(age_group, pct_of_party_total, fill = party_lean)) +
  theme_bw() +
  geom_bar(stat = 'identity', position = 'dodge', colour = 'black', width = bar_width) +
  geom_text(aes(label = percent(pct_of_party_total, accuracy = 1)), position = position_dodge(width = bar_width), vjust = -0.5) +
  scale_y_continuous(labels = percent) +
  scale_fill_manual(
    name = 'Party Lean',
    values = c('DEM' = '#00aef3', 'REP' = '#d8171e')
  ) +
  labs(
    y = 'Percent of Party Lean\n', x = '\nAge Group',
    caption = 'Chart: Taylor G. White\nData: U.S. Census, Pew Research',
    title = 'Partisan Leanings by Age Group, 2016-2018',
    subtitle = 'Partisan leanings extracted from Pew Research and multipled by population estimates'
  ) +
  theme(
    legend.text = element_text(size = 12),
    title = element_text(size = 16),
    text = element_text(size = 14),
    plot.subtitle = element_text(size = 12)
  )
ggsave('output/partisan_leanings_by_age_group.png', height = 8, width = 9, units = 'in', dpi = 600)

##### get turnout by age group #####
voter_pref_dat =
  turnout_dat %>%
  pivot_longer(
    cols = c('TX Biden Share', 'TX Sanders Share', 'CA Biden Share', 'CA Sanders Share'),
    values_to = 'vote_share', names_to = 'state_candidate_preference'
  ) %>%
  rename(
    age_group = `Age Group`
  ) %>%
  filter(age_group != 'Total') %>%
  select(age_group, state_candidate_preference, vote_share) %>%
  mutate(
    state = ifelse(str_detect(state_candidate_preference, '^(CA)'), 'CA', 'TX'),
    candidate = ifelse(str_detect(state_candidate_preference, 'Biden'), 'Biden', 'Sanders')
  )

ggplot(voter_pref_dat, aes(age_group, vote_share, fill = candidate)) +
  theme_bw() +
  facet_wrap(~state, ncol = 2) +
  geom_bar(stat = 'identity', colour = 'black', position = 'dodge', width = bar_width) +
  geom_text(aes(label = percent(vote_share, accuracy = 1)),
            position = position_dodge(width = bar_width), vjust = -0.5, size = 3) +

  scale_y_continuous(labels = percent) +
  scale_fill_manual(
    name = '',
    values = c('Biden' = 'steelblue', 'Sanders' = 'orange')
  ) +
  labs(
    y = 'Estimated Vote Share\n', x = '\nAge Group',
    caption = 'Chart: Taylor G. White\nData: Washington Post Exit Polls',
    title = 'Estimated Vote Share by Age Group',
    subtitle = 'Democratic Primary, 2020'
  ) +
  theme(
    title = element_text(size = 16),
    text = element_text(size = 14),
    legend.text = element_text(size = 12),
    plot.subtitle = element_text(size = 12),
    strip.text = element_text(size = 14, face = 'bold')
  )
ggsave('output/vote_share_by_age_group.png', height = 8, width = 9, units = 'in', dpi = 600)

#### get share of electorate ####
  electorate_shares = pivot_longer(
    turnout_dat,
    cols = c("Share of Voting Age Pop", "Super Tuesday Avg")
  ) %>%
    rename(
      age_group = `Age Group`
    ) %>%
    filter(age_group != 'Total') %>%
    mutate(
      name = factor(name, levels = c('Share of Voting Age Pop', 'Super Tuesday Avg'))
    )
names(turnout_dat)

bar_width = 0.75
ggplot(electorate_shares, aes(age_group, value, fill = name)) +
  theme_bw() +
  geom_bar(stat = 'identity', position = 'dodge', colour = 'black', width = bar_width) +
  scale_y_continuous(labels = percent) +
  geom_text(aes(label = percent(value, accuracy = 1)), position = position_dodge(width = bar_width), vjust = -0.5) +
  labs(
    x = '\bAge Group', y = ''
  ) +
  theme(
    legend.position = 'right'
  ) +
  labs(
    y = 'Share of Electorate\n', x = '\nAge Group',
    caption = 'Chart: Taylor G. White\nData: U.S. Census, Washington Post Exit Polls',
    title = 'Estimated Share of Electorate by Age Group',
    subtitle = 'Democratic Primary, 2020'
  ) +
  theme(
    title = element_text(size = 16),
    text = element_text(size = 14),
    legend.text = element_text(size = 12),
    plot.subtitle = element_text(size = 12),
    strip.text = element_text(size = 14, face = 'bold')
  ) +
  scale_fill_manual(name = '', values = c('Share of Voting Age Pop' = 'darkorange', 'Super Tuesday Avg' = 'purple4'))

ggsave('output/share_of_electorate_by_age_group.png', height = 8, width = 9, units = 'in', dpi=600)

##### show loss of influence #####
turnout_dat_fin =
  rename(turnout_dat, age_group = `Age Group`, pop_loss = `Implied Loss of Population`) %>%
  filter(age_group != 'Total')

dem_count = filter(counts_by_party, party_lean == 'DEM')$party_total
total_pop = filter(turnout_dat, `Age Group` == 'Total')$Population
dem_pct_of_voting_pop = dem_count / total_pop
lab_pos = dem_pct_of_voting_pop * 0.5

ggplot(turnout_dat_fin, aes(age_group, pop_loss * dem_pct_of_voting_pop)) +
  theme_bw() +
  geom_hline(aes(yintercept = 0)) +
  geom_bar(stat = 'identity', width = bar_width, colour = 'black', fill = 'steelblue') +
  geom_text(aes(label = comma(pop_loss * dem_pct_of_voting_pop), y = (pop_loss * lab_pos))) +
  scale_y_continuous(labels = comma) +
  labs(
    x  = '\nAge Group', y = 'Implied Population Change\n',
    title = 'Estimated Change in Influence from\nDisproportionate Turnout\nSuper Tuesday Dem. Primary 2020',
    subtitle = str_wrap('Younger voters represent less of the Democratic primary electorate because of low registration and turnout rates, given them a smaller influence on elections than their population size would suggest.', 90),
    caption = 'Chart: Taylor G. White\nData: U.S. Census, Washington Post Exit Polls, Pew Research'
  ) +
  theme(
    title = element_text(size = 16),
    text = element_text(size = 14),
    legend.text = element_text(size = 12),
    plot.subtitle = element_text(size = 12),
    strip.text = element_text(size = 14, face = 'bold')
  )
ggsave('output/influence_change_disproportionate_turnout.png', height = 8, width = 8, units = 'in', dpi = 600)


library("quantmod")
library("ggplot2")
library("rvest")
library("reshape2")
library("lubridate")

get_year <- function(date){
  return(format(date, "%Y"))
}

count_values <- function(val, vec){
  return(length(vec[vec == val]))
}

get_workdays <- function(start, end, dates_file='data/dates.csv'){
    workdays = as.Date(read.csv(dates_file)[,1])
    workdays = workdays[workdays <= end]
    workdays = workdays[workdays > start]
    return(as.Date(workdays))
}

taxa_diaria <- function(data, lista_juros, n_dias) {
  year = get_year(data)
  t <- (((lista_juros[[year]]/100 + 1))^(1/n_dias) - 1)
  return(t)
}

valor_futuro <- function(txs_dia, valor_ini){

  serie = valor_ini
  for (i in 1:(length(txs_dia)-1)){
    serie = c(serie, serie[i]*(1 + txs_dia[i]))
  }

  return(serie)
}

get_fatia_ir <- function(n){

    if (n > 720) {
        imposto <- 15
    }
    if(n <= 720){
        imposto <- 17.5
    }
    if(n <= 360){
        imposto <- 20
    }
    if(n <= 180){
        imposto <- 22.5
    }

    return((100 - imposto)/100)

}

get_n_dias <- function(data_fim, data_ini){

    return(as.Date(data_fim) - as.Date(data_ini))
}

imposto_renda <- function(datas) {

    n_dias = unlist(lapply(datas, get_n_dias, head(datas,1)))
    faixas_ir = lapply(n_dias, get_fatia_ir)
    return(unlist(faixas_ir))
}

correct_workday <- function(datas, date, increase=TRUE){

    while(!(date %in% datas)){
        if (increase){
            date <- date + 1
        }
        else {
            date <- date - 1
        }
    }
    return(date)
}

calcular_cupons <- function(serie_td, tx_cupom, data_ini, data_fim){

    datas = get_workdays(data_ini, data_fim)

    venc = tail(datas,1)
    cupom_dates = c()
    while(venc > head(datas, 1)){
        cupom_dates <- c(cupom_dates, as.Date(venc))
    month(venc) <- month(venc) - 6
    }
    cupom_dates = as.Date(cupom_dates)
    cupom_vals = c()
    c_dates = c()
    for (date in sort(cupom_dates)) {
       c_date = correct_workday(datas, date)
       c_dates = c(c_dates, c_date)
       cupom_vals <- c(cupom_vals, drop(coredata(serie_td[as.Date(c_date)]) * ((1 + tx_cupom/100)^(1/2) - 1)))
    }
    df1 = xts(cupom_vals, sort(as.Date(c_dates)))
    df2 = xts(rep(0, length(datas)), datas)
    df3 = merge.xts(df1, df2)
    return(xts(cumsum(rowSums(df3, na.rm=TRUE)), datas))
}

proj_tesdir <- function(valor_ini, juros_anuais, data_ini, data_fim){

  datas = get_workdays(data_ini, data_fim)

  if (typeof(juros_anuais) == 'double'){

    yini = get_year(head(datas, 1))
    yend = get_year(tail(datas, 1))
    yrange = as.character(as.numeric(yini):as.numeric(yend))

    val = juros_anuais
    juros_anuais = list()
    for (y in yrange) {
      juros_anuais[[y]] = val
    }
  }

  txs_dia = unlist(lapply(datas, taxa_diaria, juros_anuais, 252))
  valores_ini = rep(valor_ini, length(datas))
  serie_td = valor_futuro(txs_dia, valor_ini)
  serie_ir = imposto_renda(datas)
  retornos = serie_td - valores_ini
  serie_td = serie_td + retornos*(serie_ir - 1)
  serie_td = xts(serie_td, datas)

  return(serie_td)

}

valor_de_resgate <- function(merged_proj, ...) {

    vencs = list(...)
    dates = index(merged_proj)
    resgts = xts(rep(0, length(dates)), dates)

    for (i in 1:length(vencs)){
        c_date = correct_workday(dates, as.Date(vencs[[i]]), increase=FALSE)
        resgts[c_date] = resgts[c_date] + merged_proj[,i][c_date]
    }
    return(cumsum(resgts))

}

extrair_ipca <- function(){

  site = read_html("http://www.valor.com.br/valor-data/indices-financeiros/indicadores-de-mercado")
  site %>%
    html_node("#evolucao-das-aplicacoes-financeiras .row-1.vd-hide .last") %>%
    html_text() -> taxaIPCA
  taxaIPCA <- as.numeric(gsub(",",".",taxaIPCA))

  return(taxaIPCA)

}

extrair_selic <- function(){

  site = read_html("http://www.valor.com.br/valor-data/indices-financeiros/indicadores-de-mercado")
  site %>%
    html_node("#evolucao-das-aplicacoes-financeiras .row-2 .last") %>%
    html_text() -> taxaIPCA
  taxaSELIC <- as.numeric(gsub(",",".",taxaIPCA))

  return(taxaSELIC)

}

retorno_total <- function(investimento, IR = TRUE, annualized = TRUE){

    retorno = tail(investimento$serie, 1)/tail(investimento$montante_ini,1)
    n_dias = length(investimento$datas)

    if(annualized){

        retorno = retorno^(252/n_dias)

    }

    if(IR) { imposto = imposto_renda(as.Date(investimento$datas[1]), Sys.Date()) }

    else { imposto = 1 }

    return((retorno - 1) * 100 * imposto)
}

retorno_instantaneo <- function(investimento,  annualized = TRUE){

    retorno = tail(investimento$serie, 2)[2]/tail(investimento$serie, 2)[1]

    if(annualized){

        retorno = retorno^(252)

    }

    return((retorno - 1) * 100)

}


################################################################################
# The contents of this file are Teradata Public Content
# and have been released to the Public Domain.
# Licensed under BSD; see "license.txt" file for more information.
# Copyright (c) 2021 by Teradata
################################################################################
#
# R And Python Analytics with SCRIPT Table Operator
# Orange Book supplementary material
# Alexander Kolovos - October 2021 - v.2.1
#
# Example 4: System-Wide Parallelism - AMP Operations module (R version)
# File     : ex4rLoc.r
#
# Use case:
# A retail company has 5 stores and retains 3 departments in almost every store.
# We have simulated data of the revenue for each individual department, and we
# seek to find the global average revenue value per department per store.
# This is a system-wide task because it requires data from all SQL Engine AMPs.
# The task takes place in 2 steps, namely a "map" and a "reduce" step:
# In the "map" step, the R AMP Operations module "ex4rLoc.r" computes the
#   average revenue per department whose data are assigned on the local AMP.
# In the "reduce" step, the R Global Average module "ex4rGlb.r" combines
#   the partial results from all AMPs to reduce them to the final answer.
#
# Script accounts for the general scenario that an AMP might have no data.
#
# Required input:
# - ex4tbl table data from the file "ex4data.csv"
#
# Output:
# - CompanyID     : The ID of the example company
# - DepartmentID  : The ID of the present department
# - Department    : Name of the preseent department
# - avgDeptRevenue: Average revenue of the present department
# - nObs          : Number of records that determine the average revenue
#
################################################################################

DELIMITER <- '\t'
stdin <- file(description="stdin",open="r")

inputDF <- data.frame();

# Know your data: You must know in advance the number and data types of the
# incoming columns from the SQL Engine database!

cv <- c("numeric", "numeric", "character", "numeric")
inputDF <- try(read.table(stdin, sep=DELIMITER, flush=TRUE, header=FALSE,
                          quote="", na.strings="", colClasses=cv), silent=TRUE)

close(stdin)

# For AMPs that receive no data, choose to simply quit the script immediately.
if (class(inputDF) == "try-error") {
    inputDF <- NULL
    quit()
}

nObs <- nrow(inputDF)
avgDeptRevenue <- round(mean(inputDF[,4], na.rm=TRUE), digits=2)
CompanyID <- inputDF[1,1]
DepartmentID <- inputDF[1,2]
Department <- inputDF[1,3]

# Build export data frame:
output <- data.frame(CompanyID, DepartmentID, Department, avgDeptRevenue, nObs)

# Export results to the SQL Engine database through standard output
write.table(output, file=stdout(), col.names=FALSE, row.names=FALSE,
            quote=FALSE, sep=DELIMITER, na="")


# Exploratory analysis
# Playing around with data to figure out pivot points
#
# Jon V

#install.packages("quantmod")
#require("quantmod")

data <- read.csv("~/Sources/COT/all_data.csv", sep=";",header = T)
latest <- tail(data, 300)
Date <- as.Date( latest$date, '%m/%d/%Y')

volatility_long <- data.frame(Date, Delt(latest$com_long, latest$com_long, k=1))
volatility_short <- data.frame(Date, Delt(latest$com_short, latest$com_short, k=1))

latest$volatility_long_100 <- volatility_long$Delt.1.arithmetic * 100
latest$volatility_short_100 <- volatility_short$Delt.1.arithmetic * 100

latest$volatility_long <- volatility_long$Delt.1.arithmetic
latest$volatility_short <- volatility_short$Delt.1.arithmetic

plot(volatility_long[abs(volatility_long$Delt.1.arithmetic) > 0.1,], type="o",col="blue")
volatility = data.frame(latest$volatility_long, latest$volatility_short)
#barplot(as.matrix(t(volatility)), beside = T, col=c("dark green","red"))

volatility_long[abs(volatility_long$Delt.1.arithmetic) > 0.1,]
volatility_short[abs(volatility_short$Delt.1.arithmetic) > 0.1,]


# Uses OECD to create figure on energy prices

##################################################################################
# Energy prices and figure
##################################################################################
all <- read.csv("~/Dropbox/project/studyguide/data/OECD_CPI_All.csv", header=TRUE)
all <- select(all,LOCATION,Country,TIME,Value)
colnames(all) <- c("isocode","Country","Year","CPIAll")

ener <- read.csv("~/Dropbox/project/studyguide/data/OECD_CPI_Energy.csv", header=TRUE)
ener <- select(ener,LOCATION,Country,TIME,Value)
colnames(ener) <- c("isocode","Country","Year","CPIEnergy")

d <- merge(all,ener,by = c('isocode','Year')) # merge All and Energy CPI data
d$diff <- d$CPIAll-d$CPIEnergy # take differences to see relative inflation

d <- mutate(group_by(d,isocode), cumdiff=rev(cumsum(diff))) # accumulate diffs to get index of relative prices
d$relenergy <- exp(d$cumdiff/100) # put in level terms

f <- d[which(d$isocode %in% c("USA","GBR","JPN","KOR","CHL")),]

fig <- plot_ly(f, x = ~Year, y = ~relenergy, linetype = ~isocode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Relative price of energy', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list(title = 'Real energy price (2019=1)'),
              hovermode="x unified")
api_create(fig, filename = "oecd-cpi-energy")


b<-read.table(file='sole_XSA_summary.dat',header=T)

Blim<-770

recs<-subset(b,SSB>=Blim)
mu<-mean(log(recs$Recruitment))
std<-sd(log(recs$Recruitment))

# alfa in SMS SSB-R
alfa<-log(exp(mu)/Blim)

arti.mean<-mean(b$Recruitment)
geo.mean<-exp(mean(log(b$Recruitment)))
sd(log(b$Recruitment))

cat("#model alfa  beta std\n",100,alfa,Blim,std,'\n', file='SSB_R.in')


subroutine cross(x,y,ijk,cprd)
implicit double precision(a-h,o-z)
dimension x(3), y(3)
# Calculates a ``normalized'' cross product of the vectors joining
# [x(1),y(1)] to [x(2),y(2)] and [x(3),y(3)] respectively.
# The normalization consists in dividing by the square of the
# shortest of the three sides of the triangle.  This normalization is
# for the purposes of testing for collinearity; if the result is less
# than epsilon, the smallest of the sines of the angles is less than
# epsilon.

# Set constants
zero = 0.d0
one  = 1.d0
two  = 2.d0
four = 4.d0

# Adjust the coordinates depending upon which points are ideal,
# and calculate the squared length of the shortest side.

# case 0: No ideal points; no adjustment necessary.
if(ijk==0) {
	smin = -one
	do i = 1,3 {
		ip = i+1
		if(ip==4) ip = 1
		a = x(ip) - x(i)
		b = y(ip) - y(i)
		s = a*a+b*b
		if(smin < zero | s < smin) smin = s
	}
}

# case 1: Only k ideal.
if(ijk==1) {
	x(2) = x(2) - x(1)
	y(2) = y(2) - y(1)
	x(1) = zero
	y(1) = zero
	cn   = sqrt(x(2)**2+y(2)**2)
	x(2) = x(2)/cn
	y(2) = y(2)/cn
	smin  = one
}

# case 2: Only j ideal.
if(ijk==2) {
	x(3) = x(3) - x(1)
	y(3) = y(3) - y(1)
	x(1) = zero
	y(1) = zero
	cn   = sqrt(x(3)**2+y(3)**2)
	x(3) = x(3)/cn
	y(3) = y(3)/cn
	smin = one
}

# case 3: Both j and k ideal (i not).
if(ijk==3) {
		x(1) = zero
		y(1) = zero
		smin  = 2
}

# case 4: Only i ideal.
if(ijk==4) {
	x(3) = x(3) - x(2)
	y(3) = y(3) - y(2)
	x(2) = zero
	y(2) = zero
	cn   = sqrt(x(3)**2+y(3)**2)
	x(3) = x(3)/cn
	y(3) = y(3)/cn
	smin = one
}

# case 5: Both i and k ideal (j not).
if(ijk==5) {
	x(2) = zero
	y(2) = zero
	smin = two
}

# case 6: Both i and j ideal (k not).
if(ijk==6) {
	x(3) = zero
	y(3) = zero
	smin = two
}

# case 7: All three points ideal; no adjustment necessary.
if(ijk==7) {
	smin = four
}

a = x(2)-x(1)
b = y(2)-y(1)
c = x(3)-x(1)
d = y(3)-y(1)

cprd = (a*d - b*c)/smin
return
end


setwd("/Users/evandro/Projetos/Kaggle/Competicao_DSA")

library(ggplot2)

df = read.csv("train-pre01.csv")

'''
df$Largest.Property.Use.Type...Gross.Floor.Area..ft...1
class(df$Largest.Property.Use.Type...Gross.Floor.Area..ft...1)

df$X2nd.Largest.Property.Use...Gross.Floor.Area..ft..
class(df$X2nd.Largest.Property.Use...Gross.Floor.Area..ft..)

df$X3rd.Largest.Property.Use.Type...Gross.Floor.Area..ft..
class(df$X3rd.Largest.Property.Use.Type...Gross.Floor.Area..ft..)

df$Total.area..ft.. = df$Largest.Property.Use.Type...Gross.Floor.Area..ft...1 + df$X2nd.Largest.Property.Use...Gross.Floor.Area..ft.. + df$X3rd.Largest.Property.Use.Type...Gross.Floor.Area..ft..
df$Site.Gas..kBtu.ft.. = df$Natural.Gas.Use..kBtu. / df$Total.area..ft..
df$Site.Gas..kBtu.ft..
'''

# ENERGY.STAR.Score x Source.EUI..kBtu.ft..
plot(df$ENERGY.STAR.Score, df$Source.EUI..kBtu.ft.., xlab='Energy Star Score', ylab='Source EUI',type="p")

plot(ENERGY.STAR.Score ~ Source.EUI..kBtu.ft.., data=df, log='x')

qplot(ENERGY.STAR.Score, Source.EUI..kBtu.ft.., data=df, geom="point")

# ENERGY.STAR.Score x Weather Normalized Source.EUI..kBtu.ft..
plot(df$ENERGY.STAR.Score, df$Weather.Normalized.Source.EUI..kBtu.ft.., xlab='Energy Star Score', ylab='Weather N Source EUI',type="p")

plot(ENERGY.STAR.Score ~ Weather.Normalized.Source.EUI..kBtu.ft.., data=df, log='x')

# ENERGY.STAR.Score x Site.EUI..kBtu.ft..
plot(df$ENERGY.STAR.Score, df$Site.EUI..kBtu.ft.., xlab='Energy Star Score', ylab='Site EUI',type="p")

plot(ENERGY.STAR.Score ~ Site.EUI..kBtu.ft.., data=df, log='x')

qplot(ENERGY.STAR.Score, Site.EUI..kBtu.ft.., data=df, geom="point")

# ENERGY.STAR.Score x Site.Gas..kBtu.ft..
plot(df$ENERGY.STAR.Score, df$Site.Gas..kBtu.ft.., xlab='Energy Star Score', ylab='Gas EUI',type="p")

plot(ENERGY.STAR.Score ~ Site.Gas..kBtu.ft.., data=df, log='x')

qplot(ENERGY.STAR.Score, Site.Gas..kBtu.ft.., data=df, geom="point")

# ENERGY.STAR.Score x Electricity.Use.Area..kBtu.ft..
plot(df$ENERGY.STAR.Score, df$Electricity.Use.Area..kBtu.ft.., xlab='Energy Star Score', ylab='Eletricity Used Area',type="p")

plot(ENERGY.STAR.Score ~ Electricity.Use.Area..kBtu.ft.., data=df, log='x')

qplot(ENERGY.STAR.Score, Electricity.Use.Area..kBtu.ft.., data=df, geom="point")

# ENERGY.STAR.Score x GHG.Emissions.Area..Metric.Tons.CO2e.ft..
plot(df$ENERGY.STAR.Score, df$GHG.Emissions.Area..Metric.Tons.CO2e.ft.., xlab='Energy Star Score', ylab='GHG Emissions Area',type="p")

plot(ENERGY.STAR.Score ~ GHG.Emissions.Area..Metric.Tons.CO2e.ft.., data=df, log='x')

qplot(ENERGY.STAR.Score, GHG.Emissions.Area..Metric.Tons.CO2e.ft.., data=df, geom="point")

View(df)

# ENERGY.STAR.Score x Site.EUI..kBtu.ft.. x Site.Gas..kBtu.ft.. x GHG.Emissions.Area..Metric.Tons.CO2e.ft..
camada1 = geom_point(
  mapping = aes(x=ENERGY.STAR.Score, y=Site.EUI..kBtu.ft..),
  data = df,
  size = 3
)
ggplot() + camada1

camada2 <- geom_point(
  mapping = aes(x=ENERGY.STAR.Score, y=Site.Gas..kBtu.ft..),
  data = df,
  color = "red"
)
ggplot() + camada1 + camada2

camada3 <- geom_point(
  mapping = aes(x=ENERGY.STAR.Score, y=GHG.Emissions.Area..Metric.Tons.CO2e.ft..),
  data = df,
  color = "blue"
)
ggplot() + camada1 + camada2 + camada3

# Tentanto pelo tipo da propriedade
camada1 = geom_point(
  mapping = aes(x=ENERGY.STAR.Score, y=Site.EUI..kBtu.ft.., color=Primary.Property.Type...Self.Selected),
  data = df,
  size = 3
)
ggplot() + camada1

unique(df$Primary.Property.Type...Self.Selected)
?unique


# Compute INSE Monte Carlo covariance estimate using mcse.initseq function of mcmcse package

## Load libraries

library(mcmcse)

## Read chains

chains <- read.table(file="chain01.csv", header=FALSE, sep=",")

## Compute INSE Monte Carlo covariance estimate

print(mcse.initseq(chains)$cov)

## Compute adjusted INSE Monte Carlo covariance estimate

print(mcse.initseq(chains, adjust=TRUE)$cov.adj)


#' Generalized Linear Model Fitters
#'
#' Linear regression (Gaussian GLM), logistic regression, and poisson
#' regression model fitters.
#'
#' @details
#' Each function is implemented with gradient descent using the conjugate
#' gradients method ("CG") of the \code{optim()} function.
#'
#' Both of \code{x} and \code{y} must be distributed in an identical fashion.
#' This means that the number of rows owned by each MPI rank should match, and
#' the data rows \code{x} and response rows \code{y} should be aligned.
#' Additionally, each MPI rank should own at least one row.  Ideally they should
#' be load balanced, so that each MPI rank owns roughly the same amount of data.
#'
#' @section Communication:
#' The communication consists of an allreduce of 1 double (the local
#' cost/objective function value) at each iteration of the optimization.
#'
#' @param x,y
#' The input data \code{x} and response \code{y}.  Each must be a shaq, and
#' each must be distributed in an identical fashion.  See the details section
#' for more information.
#' @param maxiter
#' The maximum number of iterations.
#'
#' @return
#' The return is the output of an \code{optim()} call.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' comm.set.seed(1234, diff=TRUE)
#'
#' x = ranshaq(rnorm, 10, 3)
#' y = ranshaq(function(i) sample(0:1, size=i, replace=TRUE), 10)
#'
#' fit = logistic.fit(x, y)
#' comm.print(fit)
#'
#' finalize()
#' }
#'
#' @references
#' McCullagh, P. and Nelder, J.A., 1989. Generalized Linear Models, no. 37 in
#' Monograph on Statistics and Applied Probability.
#'
#' Duda, R.O., Hart, P.E. and Stork, D.G., 1973. Pattern classification (pp.
#' 526-528). Wiley, New York.
#'
#' @seealso
#' \code{\link{lm_coefs}}
#'
#' @name glms
#' @rdname glms
NULL

# linkinv_gaussian = identity

cost_gaussian = function(theta, x, y)
{
  m = nrow(x)
  J.local = (1/(2*m))*sum((DATA(x)%*%theta - DATA(y))^2)

  as.double(allreduce_dbl(J.local))
}

#' @rdname glms
#' @export
reg.fit = function(x, y, maxiter=100)
{
  check.is.shaq(x)
  check.is.shaq(y)
  check.is.posint(maxiter)

  control = list(maxit=maxiter)
  theta = numeric(ncol(x))
  if (is.float(DATA(x)))
    theta = fl(theta)

  optim(par=theta, fn=cost_gaussian, x=x, y=y, method="CG", control=control)
}

linkinv_logistic = binomial(logit)$linkinv

cost_logistic = function(theta, x, y)
{
  m = nrow(x)
  eta = DATA(x)%*%theta
  h = linkinv_logistic(eta)
  J.local = (1/m)*sum((-DATA(y)*log(h)) - ((1-DATA(y))*log(1-h)))

  allreduce_dbl(J.local)
}

#' @rdname glms
#' @export
logistic.fit = function(x, y, maxiter=100)
{
  check.is.shaq(x)
  check.is.shaq(y)
  check.is.posint(maxiter)

  control = list(maxit=maxiter)
  theta = numeric(ncol(x))
  optim(par=theta, fn=cost_logistic, x=x, y=y, method="CG", control=control)
}

linkinv_poisson = poisson(log)$linkinv

cost_poisson = function(theta, x, y)
{
  eta = DATA(x) %*% theta
  J.local = -sum(DATA(y) * eta - linkinv_poisson(eta))

  allreduce_dbl(J.local)
}

#' @rdname glms
#' @export
poisson.fit = function(x, y, maxiter=100)
{
  check.is.shaq(x)
  check.is.shaq(y)
  check.is.posint(maxiter)

  control = list(maxit=maxiter)
  theta = numeric(ncol(x))
  optim(par=theta, fn=cost_poisson, x=x, y=y, method="CG", control=control)
}


sal = read.csv("Salaries.csv", header = TRUE)
salary = sal$Salary
SincePhd = sal$Yrs.since.phd
corval = cor(salary,SincePhd,method="pearson")
corVal


PATH <- '00_data/WORLD.CSV'

WORLD <- read.csv(PATH)
WORLD. <- WORLD[c(5, 6, 8, 9, 10, 12, 16:19)]

COR <- cor(WORLD.[c(1:6)], use = 'pairwise')
COR

library(corrplot)
corrplot(COR, type = 'lower')

library(corrgram)
corrgram(COR, upper.panel = NULL)

plot(WORLD.)

library(ggplot2)
library(GGally)
ggpairs(WORLD.)


#' @export
#' @title convert.degmin2degdec
#' @description This function converts coordinates in dd.mmmm to decimal degrees
#' @param \code{x} = dataframe to be handled, with lat and lon colnames
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @examples
#' test=as.data.frame(cbind(-52.3050,55.20))
#' colnames(test)=c("lat","lon")
#' convert.degmin2degdec(test)
#' lat      lon
#' 1 -52.50833 55.33333
#' @family coordinate converters
#' @export
  convert.degmin2degdec = function (x, y=NULL, vnames=c("lon", "lat") ) {
    xlon = x[,vnames[1]]
    xlat = x[,vnames[2]]
    if (is.null(y)) {
      x[,vnames[1]] = trunc(xlon) + round((xlon - trunc(xlon)) /60 * 100, 6)
      x[,vnames[2]] = trunc(xlat) + round((xlat - trunc(xlat)) /60 * 100, 6)
    } else {
      if (y=="lon") x = - (floor(x/100)+(x-100*floor(x/100))/60)
      if (y=="lat") x = floor(x /100)+(x - 100*floor(x /100))/60
    }
    return (x)
  }


#--------------------------------------------------------------------------------
# Name:         myfunctions_SOD.r
# Purpose:      Modules (functions) called by the main script
# Author:       Francesco Tonini
# Email:        ftonini84@gmail.com
# Created:      01/07/2015
# Copyright:    (c) 2015 by Francesco Tonini
# License:      GNU General Public License (GPL)
# Software:     Tested successfully using R version 3.0.2 (http://www.r-project.org/)
#-----------------------------------------------------------------------------------------------------------------------

addalpha <- function(colors, alpha=1.0) {
  r <- col2rgb(colors, alpha=T)
  # Apply alpha
  r[4,] <- alpha*255
  r <- r/255.0
  return(rgb(r[1,], r[2,], r[3,], r[4,]))
}

cauchy.weight <- function(rs, d, scale, gamma = NULL) {

  #univariate Cauchy
  #f(x) = 1 / (pi * scale * (1 + (d/scale)^2))

  #bivariate Cauchy from http://en.wikipedia.org/wiki/Cauchy_distribution
  #f(x) = (1/2*pi) * (scale / (p[,1] + p[,2] + scale^2)^1.5)

  if(is.null(scale)) stop('Parameter scale needs to be specified')

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)
  m[ceiling(ny/2), ceiling(nx/2)] <- 1

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  dist <- as.matrix(distance(r))
  #p <- xyFromCell(r, 1:ncell(r))^2   #use this and comment 'dist' if using bivar Cauchy

  if (length(scale) == 1) {
    if (!is.null(gamma)) stop('The parameter gamma has to be NULL when using a single Cauchy pdf')

    #using PDF
    #half-cauchy: f(x) = 2/pi * (scale/(r^2 + scale^2))  #where scale is the median disp distance here...
    m <- 2/pi * (scale/(dist^2 + scale^2))

    #using bivariate cauchy from http://en.wikipedia.org/wiki/Cauchy_distribution
    #m <- (1/2*pi) * (scale / (p[,1] + p[,2] + scale^2)^1.5)
    #m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

    #sum of weights should add up to 1
    #m / sum(m)
    m

  }else{   #Cauchy mixture

    if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf')
    if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
    scale1 <- scale[1]
    scale2 <- scale[2]

    m <- (gamma * 2/pi * (scale[1]/(dist^2 + scale[1]^2)) ) + ( (1-gamma) * 2/pi * (scale[2]/(dist^2 + scale[2]^2)) )

    #using bivariate cauchy from http://en.wikipedia.org/wiki/Cauchy_distribution
    #m <- gamma * ((1/2*pi) * (scale1 / (p[,1] + p[,2] + scale1^2)^1.5)) + (1-gamma) * ((1/2*pi) * (scale2 / (p[,1] + p[,2] + scale2^2)^1.5))
    #m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

    #sum of weights should add up to 1
    m / sum(m)

  }

}

gauss.weight <- function(rs, d, sigma=NULL, alpha=NULL) {

  #bivariate Gaussian filter, according to http://en.wikipedia.org/wiki/Gaussian_filter
  #f(x) = 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2))

  #two-parameter dispersal kernel as defined in Clark, J.S., 1998. Why trees migrate so fast [...]
  #f(x) = ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(d/alpha)^c  )

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  dist <- as.matrix(distance(r))
  #p <- xyFromCell(r, 1:ncell(r))^2   #use this and comment 'dist' if using bivar Gauss

  #using Clark, J.S., 1998
  if (length(alpha) != 1) stop('The parameter alpha must be a single number (average distance)')
  if (is.null(alpha)) stop('The parameter alpha must be specified (average distance)')

  c <- 2
  m <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dist/alpha)^c  )
  m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

  #using bivariate filter
  #if (length(sigma) != 1) stop('The parameter sigma must be a single number')
  #if (is.null(sigma)) stop('The parameter sigma must be specified')
  #m <- 1/(2*pi*sigma^2) * exp(-(p[,1]+p[,2])/(2*sigma^2))
  #m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

  #sum of weights should add up to 1
  m / sum(m)

}

exp.weight <- function(rs, d, alpha) {

  #two-parameter dispersal kernel as defined in Clark, J.S., 1998. Why trees migrate so fast [...]
  #f(x) = ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(d/alpha)^c  )

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  dist <- as.matrix(distance(r))

  #using Clark, J.S., 1998
  if (length(alpha) != 1) stop('The parameter alpha must be a single number (average distance)')
  if (is.null(alpha)) stop('The parameter alpha must be specified (average distance)')

  c <- 1
  m <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dist/alpha)^c  )
  m <- matrix(m, ncol=nx, nrow=ny, byrow=TRUE)

  #sum of weights should add up to 1
  m / sum(m)

}

Kernel.gen <- function(x, d, type = c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), scale = NULL, gamma = NULL, sigma = NULL, alpha = NULL){

  type <- match.arg(type)
  x <- res(x)

  if (type == 'Cauchy'){
    cauchy.weight(x, d, scale)
  }else if (type =='Cauchy Mixture'){
    cauchy.weight(x, d, scale, gamma)
  }else if (type =='Exponential'){
    exp.weight(x, d, alpha = alpha)
  }else if (type == 'Gauss'){
    gauss.weight(x, d, alpha = alpha)
  }

}

WindKernel.gen <- function(x, d, mu, kappa){

  rs <- res(x)

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  m <- matrix(ncol=nx, nrow=ny)

  xr <- (nx * rs[1]) / 2
  yr <- (ny * rs[2]) / 2
  r <- raster(m, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')
  r[ceiling(ny/2), ceiling(nx/2)] <- 1

  dir <- direction(r, from=TRUE)
  dir[ceiling(ny/2), ceiling(nx/2)] <- 0

  m <- as.matrix(dvm(dir, mu, kappa))

  #sum of weights should add up to 1
  #m / sum(m)
  m

}

distGen <- function(n, type = c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), mean = NULL, sd = NULL, scale = NULL, gamma=NULL) {

  type <- match.arg(type)

  if (type == 'Cauchy'){

    dist <- abs(rcauchy(n, scale = scale))

  }else if (type =='Cauchy Mixture'){

    if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
    if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf!')
    if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
    f <- sample(1:2, n, replace=TRUE, prob=c(gamma, 1-gamma))
    dist <- abs(sapply(f, FUN=function(x) if(x==1) rcauchy(1, scale = scale[1]) else if (x==2) rcauchy(1, scale = scale[2])))

  }else if (type =='Exponential'){

    if (is.null(mean)) stop('The parameter mean must be specified when using an Exponential pdf!')
    dist <- rexp(n, rate = 1/mean)

  }else if (type == 'Gauss'){

    if (is.null(mean) | is.null(sd)) stop('The parameters mean and standard deviation (sd) must be specified when using an Gaussian pdf!')
    dist <- abs(rnorm(n, mean = mean, sd = sd))

  }

  return(dist)

}

#use Von Mises pdf to generate angular data
angleGen <- function(n, mean=0, k=0){

  #mean: mean direction in radians of the von Mises distribution
  #k: concentration parameter of the von Mises distribution. Small k --> large variance; large k --> small variance
  #if(k>0) theta <- rvm(n, mean, k) else
  theta <- runif(n, 0, 360)
  return(theta)

}

findRowPos <- function(x, w){

  nrow <- nrow(HI.raster) - nearest.raster.point(x[1], x[2], w)[[1]] + 1
  return(nrow)

}

findColPos <- function(x, w){

  ncol <- nearest.raster.point(x[1], x[2], w)[[2]]
  return(ncol)

}

spores.count <- function(x, y){

  sum(x[1] == y[,1] & x[2] == y[,2])

}

#Within each infected cell (I > 0) draw random number of infections ~Poisson(lambda=rate of spore production) for each infected host.
#Take SUM for total infections produced by each cell.

new.infections.gen <- function(x, rate, clim=NULL){

    if(is.null(clim)) x <- rpois(x,lambda=rate) else x <- rpois(x,lambda=rate * clim)

    x <- sum(x)
    return(x)

}

myFocal.fun <- function(u, v, ngb){

  spores <- getValuesFocal(u, ngb=ngb)
  spores[is.na(spores)] <- 0
  prob <- c(t(v))

  new.I <- apply(spores, MARGIN = 1, FUN = function(x) ifelse(any(x>0), x %*% prob, 0))

  return(new.I)

}

radialDisp <- function(xyAOIPos, AOI_owin){

  #generate dispersal distances and angles from user-defined pdf
  distance <- distGen(n = sum(spores.lst), type = 'Cauchy', scale=20.57, gamma=0.9947)
  theta <- angleGen(n = sum(spores.lst))

  #set of new xy coords of dispersed spores
  x.new <- rep(x[spores.lst>0], spores.lst[spores.lst>0]) + sin(theta) * distance
  y.new <- rep(y[spores.lst>0], spores.lst[spores.lst>0]) + cos(theta) * distance

  #remove/ignore xy coords falling outside study area
  condx <- which(x.new < extent(HI.raster)[1] | x.new > extent(HI.raster)[2])
  condy <- which(y.new < extent(HI.raster)[3] | y.new > extent(HI.raster)[4])

  x.new <- x.new[-unique(c(condx,condy))]
  y.new <- y.new[-unique(c(condx,condy))]

  #get index (position) of cells in study area containing new xy coords of dispersed spores
  yPos <- apply(cbind(x.new,y.new), 1, FUN=findRowPos, AOI_owin)
  xPos <- apply(cbind(x.new,y.new), 1, FUN=findColPos, AOI_owin)

  #create list of spore counts (spores in each cell after dispersal)
  new.spores.lst <- apply(xyAOIPos, 1, FUN=spores.count, cbind(xPos, yPos))

  return(new.spores.lst)

}

SporeDisp <- function(x, S, I, W=NULL, rs, rtype=c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), mean = NULL, sd = NULL, scale = NULL, gamma=NULL,
                      wtype=c('Uniform', 'VM'), wdir=c('N','NE','E','SE','S','SW','W','NW'), kappa=NULL){

  out <- list()

  rtype <- match.arg(rtype) #radial distribution type
  wtype <- match.arg(wtype) #wind distribution type

  #LOOP THROUGH EACH CELL of the input matrix 'x' (this should be the study area)
  for(row in 1:nrow(x)){

    for(col in 1:ncol(x)){

      if(x[row,col] > 0){  #if [row,col] > 0 disperse spores from it

        for(sp in 1:x[row,col]){

          ##GENERATE DISTANCES
          if (rtype=='Cauchy'){
            if(is.null(scale)) stop('Kernel of type "Cauchy" requires a scale parameter!')
            dist <- abs(rcauchy(1, scale = scale))
          }else if (rtype=='Cauchy Mixture'){
            if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
            if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf!')
            if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
            f <- sample(1:2, 1, prob=c(gamma, 1-gamma))
            if(f == 1) dist <- abs(rcauchy(1, scale = scale[1])) else dist <- abs(rcauchy(1, scale = scale[2]))
          }else if (rtype =='Exponential'){
            if (is.null(mean)) stop('The parameter mean must be specified when using an Exponential pdf!')
            dist <- rexp(1, rate = 1/mean)
          }else if (rtype == 'Gauss'){
            if (is.null(mean) | is.null(sd)) stop('The parameters mean and standard deviation (sd) must be specified when using an Gaussian pdf!')
            dist <- abs(rnorm(1, mean = mean, sd = sd))
          }

          ##GENERATE ANGLES
          if (wtype=='Uniform'){
            theta <- runif(1, -pi, pi)
          }else if(wtype=='VM'){
            if(is.null(kappa) | kappa <= 0) stop('kappa must be greater than zero!')
            #Check predominant windDir
            if(wdir == 'N') {
              theta <- rvm(1, mean = 0 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'NE'){
              theta <- rvm(1, mean = 45 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'E'){
              theta <- rvm(1, mean = 90 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'SE'){
              theta <- rvm(1, mean = 135 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'S'){
              theta <- rvm(1, mean = 180 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'SW'){
              theta <- rvm(1, mean = 225 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'W'){
              theta <- rvm(1, mean = 270 * (pi/180), kappa)  #kappa=concentration
            }else if(wdir == 'NW'){
              theta <- rvm(1, mean = 315 * (pi/180), kappa)  #kappa=concentration
            }
          }

          #distance in cell counts
          #distc <- round(dist / res.win)

          row0 <- row - round((dist * cos(theta)) / rs)
          col0 <- col + round((dist * sin(theta)) / rs)

          if (row0 < 1 | row0 > nrow(x)) next     ## outside the region ##
          if (col0 < 1 | col0 > ncol(x)) next     ## outside the region ##

          if(S[row0, col0] > 0){
            PropS <- S[row0, col0] / (S[row0, col0] + I[row0, col0])
            U <- runif(1)
            if(!is.null(W)) Prob <- PropS * W[row0, col0] else Prob <- PropS    #added weather

            if (U < Prob){
              I[row0, col0] <- I[row0, col0] + 1
              S[row0, col0] <- S[row0, col0] - 1
            }
          }#ENF IF

        }#END FOR LOOP OVER ALL SPORES WITHIN CURRENT CELL

      }#END IF

    }
  }#END LOOP OVER ALL CELLS

  out$I <- I
  out$S <- S

  return(out)

}

SporeDisp2 <- function(x, S, I, W=NULL, rs, rtype=c('Cauchy', 'Cauchy Mixture', 'Exponential', 'Gauss'), mean = NULL, sd = NULL, scale = NULL, gamma=NULL,
                       wtype=c('Uniform', 'VM'), wdir=c('N','NE','E','SE','S','SW','W','NW'), kappa=NULL){

  out <- list()

  rtype <- match.arg(rtype) #radial distribution type
  wtype <- match.arg(wtype) #wind distribution type

  #LOOP THROUGH EACH CELL of the input matrix 'x' (this should be the study area)
  for(row in 1:nrow(x)){

    for(col in 1:ncol(x)){

      if(x[row,col] > 0){  #if [row,col] > 0 disperse spores from it

        ##GENERATE DISTANCES ALL AT ONCE
        if (rtype=='Cauchy'){
          if(is.null(scale)) stop('Kernel of type "Cauchy" requires a scale parameter!')
          dist <- abs(rcauchy(x[row,col], scale = scale))
        }else if (rtype=='Cauchy Mixture'){
          if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
          if (is.null(gamma)) stop('The parameter gamma has to be specified when using a mixture Cauchy pdf!')
          if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
          f <- sample(1:2, x[row,col], prob=c(gamma, 1-gamma))
          dist <- ifelse(f == 1, abs(rcauchy(1, scale = scale[1])), abs(rcauchy(1, scale = scale[2])))
        }else if (rtype =='Exponential'){
          if (is.null(mean)) stop('The parameter mean must be specified when using an Exponential pdf!')
          dist <- rexp(x[row,col], rate = 1/mean)
        }else if (rtype == 'Gauss'){
          if (is.null(mean) | is.null(sd)) stop('The parameters mean and standard deviation (sd) must be specified when using an Gaussian pdf!')
          dist <- abs(rnorm(x[row,col], mean = mean, sd = sd))
        }

        ##GENERATE ANGLES ALL AT ONCE
        if (wtype=='Uniform'){
          theta <- runif(x[row,col], -pi, pi)
        }else if(wtype=='VM'){
          if(is.null(kappa) | kappa <= 0) stop('kappa must be greater than zero!')
          #Check predominant windDir
          if(wdir == 'N') {
            theta <- rvm(x[row,col], mean = 0 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'NE'){
            theta <- rvm(x[row,col], mean = 45 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'E'){
            theta <- rvm(x[row,col], mean = 90 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'SE'){
            theta <- rvm(x[row,col], mean = 135 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'S'){
            theta <- rvm(x[row,col], mean = 180 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'SW'){
            theta <- rvm(x[row,col], mean = 225 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'W'){
            theta <- rvm(x[row,col], mean = 270 * (pi/180), kappa)  #kappa=concentration
          }else if(wdir == 'NW'){
            theta <- rvm(x[row,col], mean = 315 * (pi/180), kappa)  #kappa=concentration
          }
        }

        #distance in cell counts
        #distc <- round(dist / res.win)

        row0 <- row - round((dist * cos(theta)) / rs)
        col0 <- col + round((dist * sin(theta)) / rs)

        bool <- ifelse(row0 < 1 | row0 > nrow(x) | col0 < 1 | col0 > ncol(x), 1, 0)

        ## outside the region ##
        if(any(bool==1)){
          row0 <- row0[-which(bool==1)]
          col0 <- col0[-which(bool==1)]
        }

        #if all spores fall outside region continue loop to next cell
        if (length(row0) == 0 | length(col0) == 0) next

        ##LOOP THROUGH ROW0 and COL0 TO ADD DISPERSED SPORES
        for(i in 1:length(row0)){
          if(S[row0[i], col0[i]] > 0){
            PropS <- round(S[row0[i], col0[i]] / (S[row0[i], col0[i]] + I[row0[i], col0[i]]), 2)
            U <- runif(1)
            if(!is.null(W)) Prob <- PropS * W[row0[i], col0[i]] else Prob <- PropS    #added weather
            if (U < Prob){
              I[row0[i], col0[i]] <- I[row0[i], col0[i]] + 1
              S[row0[i], col0[i]] <- S[row0[i], col0[i]] - 1
            }#ENF IF
          }#ENF IF
        }#END LOOP OVER DISP SPORES FROM CURRENT SOURCE CELL

      }#END IF

    }
  }#END LOOP OVER ALL CELLS

  out$I <- I
  out$S <- S

  return(out)

}

randomU <- function(x, y, z){

  out <- list()

  if(z > 0 & x > 0){

    currentPropS <- round( z / (z + y), 2)

    for (i in 1:x){
      r <- runif(1)
      if (r < currentPropS){
        y <- y + 1
        z <- z - 1
        currentPropS <- round( z / (z + y), 2)
      }
    }

  }

  out$I <- y
  out$S <- z

  return(out)

}

buffer.areas <- function(x, rs, width.row, width.col){

  z <- matrix(x, ncol=ncol(rs), byrow=T)
  buffer.col <- matrix(NA, nrow=nrow(rs), ncol=floor((width.col - 1)/2))
  z <- cbind(buffer.col, z, buffer.col)
  buffer.row <- matrix(NA, ncol=ncol(z), nrow=floor((width.row - 1)/2))
  z <- rbind(buffer.row, z, buffer.row)

  return(z)

}

kernel2D <- function(x, d){

  rs <- res(x)
  if(d <= res(x)[1] | d <= res(x)[2]) stop('d must be >= grain of study area')

  nx <- 1 + 2 * floor(d/rs[1])
  ny <- 1 + 2 * floor(d/rs[2])

  probKernel <- matrix(NA, ncol=nx, nrow=ny)
  probKernel[ceiling(ny/2), ceiling(nx/2)] <- 1

  return(probKernel)

}

kernel2DToDistance <- function(x, r){

  rs <- res(r)

  xr <- (ncol(x) * rs[1]) / 2
  yr <- (nrow(x) * rs[2]) / 2
  rast <- raster(x, xmn=-xr[1], xmx=xr[1], ymn=-yr[1], ymx=yr[1], crs='+proj=utm +zone=1')

  z <- as.matrix(distance(rast))

  return(z)

}

dispFunction <- function(bkgr, dst, type=c('Cauchy','Cauchy Mixture','Gauss',"Exponential"), c=NULL, scale=NULL, gamma=NULL, sd=NULL, rate=NULL){

  type <- match.arg(type)

  hw_col <- floor(ncol(dst)/2)
  hw_row <- floor(nrow(dst)/2)

  if(is.null(c)) stop('c must be specified in the dispersal function!')
  if(c != 2 & c > 1) stop('c must be either <= 1 or = 2')

  #Start moving the kernel over all cells of study area. BUT only run dispersal on top of source cells (cells with bkgr)
  for(row in 1:nrow(bkgr)){

    for(col in 1:ncol(bkgr)){

      if(!is.na(bkgr[row,col]) & bkgr[row,col] > 0) {

        #************************
        #RADIAL DISPERSAL
        #************************

        #sample a value for alpha using a radial dispersal pdf (this step is necessary to add stochasticity)
        if(type == 'Cauchy'){
          if(c > 1) stop('for type == Cauchy the value of c must be < 1')
          #sample alpha from chosen distribution of interest
          alpha <- abs(rcauchy(1, location=0, scale=scale))
        }else if(type == 'Cauchy Mixture'){
          if(c > 1) stop('for type == "Cauchy" the value of c must be < 1')
          if(length(scale) != 2) stop('The parameter scale must have two values, one for each component of the mixture!')
          if (gamma >= 1 | gamma <= 0) stop('The parameter gamma must range between (0-1)')
          f <- sample(1:2, 1, prob=c(gamma, 1-gamma))
          if(f==1) alpha <- abs(rcauchy(1, location=0, scale = scale[1])) else if (f==2) alpha <- abs(rcauchy(1, location=0, scale = scale[2]))
        }else if(type == 'Gauss'){
          if(c != 2) stop('for type = "Gauss" the value of c must be = 2')
          alpha <- abs(rnorm(1, location=0, sd=sd))
        }else if(type == 'Exponential'){
          if(c != 1) stop('for type = "Exponential" the value of c must be = 1')
          alpha <- rexp(1, rate=1/rate)
        }

        #now we can calculate the kernel weights using the value of alpha and set of distances from central source cell
        kernelWt <- ( c / 2 * alpha * gamma(1/c) ) * exp( -abs(dst/alpha)^c  )  ##CHECK IF THIS NEEDS TO BE CONVERTED INTO ANOTHER LOOP IN C++

        #sum of weights should add up to 1
        Wt <- kernelWt/sum(kernelWt)

        #MULTIPLY THE SPORES IN THE SOURCE CELL BY EACH VALUE IN DISP KERNEL
        #spores_disp <- round(bkgr[row,col] * Wt)
        spores_disp <- bkgr[row,col] * Wt

        bkgr[(row-hw_row):(row+hw_row), (col-hw_col):(col+hw_col)] <- bkgr[(row-hw_row):(row+hw_row), (col-hw_col):(col+hw_col)] + spores_disp

      } #END IF

    }
  } #END LOOP OVER EACH CELL INSIDE STUDY BUFFERED STUDY AREA

  return(round(bkgr))
}

infectFun <- function(bkgr, S, I){

  out <- list()

  #LOOP OVER EACH CELL OF STUDY AREA AND FOR EACH NON-ZERO SPORE CELL (dispersed spores) RUN THE PROBABILISTIC
  #LOOP TO SEE HOW MANY SPORES TURN INTO AN INFECTION
  for(row in 1:nrow(bkgr)){
    for(col in 1:ncol(bkgr)){

      if(!is.na(S[row,col]) & S[row,col] > 0 & bkgr[row,col] > 0){
        currentPropS <- round(S[row,col] / (S[row,col] + I[row,col]), 2)
        for(spNbr in 1:bkgr[row,col]){
          U <- runif(1)
          if (U < currentPropS){
            I[row,col] <- I[row,col] + 1
            S[row,col] <- S[row,col] - 1
            currentPropS <- round( S[row,col] / (S[row,col] + I[row,col]), 2)
          }
        } #END LOOP OVER EACH SPORE IN CELL [row,col]
      } #ENF IF

    }
  }

  out$S <- S
  out$I <- I
  return(out)

}

climGen <- function(ls, start, end, Wrank, scn=NA){

  #CASE 1: no future weather needed
  if(is.na(scn) & end <= last_yr){
    ls <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)  #use only the raster files matching the years of interest
    ls.stack <- stack(ls)
    #CASE 2: RANDOM future weather scenario
  }else if(scn == 'random'){
    if(end <= last_yr) stop('you specified a future weather scenario BUT the end year is not a future year!')
    yrs <- sample(weather_rank[,1], size = end - last_yr, replace = T)
    ls_1 <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)
    ls_2 <- unlist(lapply(yrs, FUN=function(x){grep(as.character(x), ls, value=TRUE)}))
    ls <- c(ls_1, ls_2)
    ls.stack <- stack(ls)
    #CASE 3: UPPER 50% (favorable) future weather scenario
  }else if(scn == 'favorable'){
    if(end <= last_yr) stop('you specified a future weather scenario BUT the end year is not a future year!')
    yrs <- sample(weather_rank[1:9,1], size = end - last_yr, replace = T)
    ls_1 <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)
    ls_2 <- unlist(lapply(yrs, FUN=function(x){grep(as.character(x), ls, value=TRUE)}))
    ls <- c(ls_1, ls_2)
    ls.stack <- stack(ls)
    #CASE 4: LOWER 50% (unfavorable) future weather scenario
  }else{
    if(end <= last_yr) stop('you specified a future weather scenario BUT the end year is not a future year!')
    yrs <- sample(weather_rank[10:18, 1], size = end - last_yr, replace = T)
    ls_1 <- grep(paste(as.character(seq(start,end)), collapse="|"), ls, value=TRUE)
    ls_2 <- unlist(lapply(yrs, FUN=function(x){grep(as.character(x), ls, value=TRUE)}))
    ls <- c(ls_1, ls_2)
    ls.stack <- stack(ls)
  }

  return(ls.stack)

}


myLoopFunction <- function(){ #function with no argument
x <- c("what","is","truth")

if("Truth" %in% x) { #if-else statement
   print("Truth is found")
} else {
   print("Truth is not found")
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

#In switch statement
#If the value of expression is not a character string it is coerced to integer
#there is no default, and if there are more than one match, the first one is returned
x <- switch(
   2,
   "first",
   "second",
   "third",
   "fourth"
)
print(x)

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
v <- c("Hello","loop")
cnt <- 2

repeat { #repeat statement (like a recursive function)
   print(v)
   cnt <- cnt+1

   if(cnt > 5) {
      break
   }
}

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
while (cnt < 7) { #while statement
   print(v)
   cnt = cnt + 1
}

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
v <- LETTERS[1:6]
for ( i in v) { #for statement
    if (i == "D") {
      next
   }
   print(i)
}
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#Built-in functions
myBuilt_in_function <- function(){
# Create a sequence of numbers from 32 to 44.
print(seq(32,44))

# Find mean of numbers from 25 to 82.
print(mean(25:82))

# Find sum of numbers frm 41 to 68.
print(sum(1:10))
}
# Create a function to print squares of numbers in sequence.
new.function <- function(a) {
   for(i in 1:a) {
      b <- i^2
      c <- 2*b
      print(c)
   }
}

# Call the function new.function supplying 6 as an argument.
new.function(3)

myfunction <- function(a=1,b=2,c=3){ #we can determine default values
    result <- a+b*c
    print(result)
}

# Call the function by position of arguments.
myfunction(5,3,11)

# Call the function by names of the arguments.
myfunction(a = 11, b = 5, c = 3)

# Call the function without giving any argument.
myfunction()


context("Check accuracy of AR using Card data")

test_that("AR test without exogeneous covariates and intercept, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.462792094733,0.470402558386))
  expect_equal(teststat_out$p.value,0)
  expect_equal(teststat_out$df,c(1,3009))
  expect_equal(teststat_out$Fstat,6679.92118721)
})

test_that("AR test without exogeneous covariates and intercept, mult-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]

  foo = ivmodel(Y=Y,D=D,Z=Z,intercept=FALSE)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.465107588912,0.470042589959))
  expect_equal(teststat_out$p.value,0)
  expect_equal(teststat_out$df,c(2,3008))
  expect_equal(teststat_out$Fstat,4165.66455412)
})

test_that("AR test with intercept, but without exogeneous covariates, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]

  foo = ivmodel(Y=Y,D=D,Z=Z)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.143037504074,0.250862634531))
  expect_equal(teststat_out$p.value,0)
  expect_equal(teststat_out$df,c(1,3008))
  expect_equal(teststat_out$Fstat,82.7445324192)
})

test_that("AR test with intercept, but without exogeneous covariates, mult-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]

  foo = ivmodel(Y=Y,D=D,Z=Z)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.166084633236,0.260253933988))
  expect_equal(teststat_out$p.value,0)
  expect_equal(teststat_out$df,c(2,3007))
  expect_equal(teststat_out$Fstat,51.3582485426)
})

test_that("AR test with exogeneous covariates, but no intercept, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.280764970615,0.346153931966))
  expect_equal(teststat_out$p.value,0)
  expect_equal(teststat_out$df,c(1,2995))
  expect_equal(teststat_out$Fstat,113.307424185)
})

test_that("AR test with exogeneous covariates, but no intercept, multi-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X,intercept=FALSE)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.310404897446,0.355337343207))
  expect_equal(teststat_out$p.value,0)
  expect_equal(teststat_out$df,c(2,2994))
  expect_equal(teststat_out$Fstat,134.812593279)
})

test_that("AR test with exogeneous covariates and intercept, single-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,"nearc4"]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.0248048359651, 0.284823593339))
  expect_equal(teststat_out$p.value,0.0200276297596)
  expect_equal(teststat_out$df,c(1,2994))
  expect_equal(teststat_out$Fstat,5.41527923822)
})

test_that("AR test with exogeneous covariates, but no intercept, multi-IV", {
  Y=card.data[,"lwage"]
  D=card.data[,"educ"]
  Z=card.data[,c("nearc4","nearc2")]
  Xname=c("exper", "expersq", "black", "south", "smsa", "reg661",
          "reg662", "reg663", "reg664", "reg665", "reg666", "reg667",
          "reg668", "smsa66")
  X=card.data[,Xname]

  foo = ivmodel(Y=Y,D=D,Z=Z,X=X)
  teststat_out = AR.test(foo)
  expect_equal(as.numeric(teststat_out$ci),c(0.0536002610089, 0.361980791255))
  expect_equal(teststat_out$p.value,.00532805613556)
  expect_equal(teststat_out$df,c(2,2993))
  expect_equal(teststat_out$Fstat,5.24393512598)
})