#Suppose the food label on a cookie bag states that there is at most 2 grams
#of saturated fat in a single cookie. In a sample of 35 cookies, it is
#found that the mean amount of saturated fat per cookie is 2.1 grams.
#Assume that the sample standard deviation is 0.3 gram. At .05 significance
#level, can we reject the claim on food label?

xbar = 2.1
mu0 = 2

s = 0.3

n = 35

t = (xbar-mu0)/(s/(sqrt(n)))

t #1.9720

alpha = 0.05

#Valores criticos
t.alpha = qt(1-alpha,df = n-1)

#rechazamos la hipotesis
t.alpha #1.6991

pval = pt(t,df=n-1,lower.tail = FALSE)

Parcial/1. Prueba de hipotesis/UpperTailMeanUnknownVariance.r


# Declaration of variables with raw data
rawData <- c(33, 24, 17, 26)
avoidanceRawData <- c("Avoidance behaviour", "No avoidance behaviour")
parasitedRawData <- c("Unparasitised", "Parasitised")

# Creation of 2*2 matrix using rownames() and colnames()
matrixAvoidanceBehaviourRates <- matrix(rawData, ncol=2, nrow=2, byrow="TRUE")
rownames(matrixAvoidanceBehaviourRates) <- avoidanceRawData
colnames(matrixAvoidanceBehaviourRates) <- parasitedRawData

# Draw a barplot using barplot() include a legend with legend()
barplot(matrixAvoidanceBehaviourRates,
main = "Fish Parasitism and Predator Avoidance",
xlab = "Fish Parasitism",
ylab = "Number of fish",
col = c("red","blue")
)

legend('topleft',
legend = avoidanceRawData,
title = "Predator Avoidance",
fill = c("red","blue"),
bg = c("white")
)

# Carry out a chi square test for independence of data using chisq.test()
chisq <- chisq.test(matrixAvoidanceBehaviourRates)

chisq
# Pearson's Chi-squared test with Yates' continuity correction executed
# RESULT => X-squared = 2.6112, df = 1, p-value = 0.1061
# What is a null hypothesis?
# What are the assumptions behind a chi square test? Do your data meet them?
# What does the statistical test tell you?


M <- 1E6
theta.samp.1 <- rnorm(M, mean = 0, sd = sqrt(2.19))
theta.samp.2 <- rcauchy(M)

predictive.X1 <- rnorm(M, mean = theta.samp.1, sd = 1)
predictive.X2 <- rnorm(M, mean = theta.samp.2, sd = 1)

library(ggplot2)

forplot <- data.frame(x_pred = c(predictive.X1, predictive.X2),
                      prior = rep(c("Normal", "Cauchy"), each = M))

p0 <- ggplot(forplot,
                      aes(x = x_pred, colour = prior, fill = prior)) +
       geom_density(alpha = .4) +
  scale_x_continuous(expression(x[pred]), limits = c(-10, 10)) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 16) +
  geom_vline(xintercept = c(-4, 4), linetype = "longdash") +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

p0

ggsave(plot = p0, filename = "../slides/figures/BC_example_326.pdf")

#### Second part: inference
## First let's generate some data

N <- 3
true_theta <- -20
X <- rnorm(n = N, mean = true_theta, sd = 1)

## Now let's fit the model under both priors
library(cmdstanr)
library(rstan)
stanfit <- function(fit) rstan::read_stan_csv(fit$output_files())

example_326  <- cmdstanr::cmdstan_model("stan/BC_example_326.stan")

stan.data <- list(N = N, x = X, prior = 1)
fit.normal <- stanfit(example_326$sample(data = stan.data, refresh = 0))
stan.data$prior <- 2
fit.cauchy <- stanfit(example_326$sample(data = stan.data, refresh = 0))

theta.df <- data.frame(
  theta = c(extract(fit.normal, 'theta')$theta,
            extract(fit.cauchy, 'theta')$theta)
)
theta.df$prior <- rep(c("Normal", "Cauchy"), each = nrow(theta.df)/2)

## Compare posteriors
p1 <- ggplot(theta.df,
             aes(x = theta, colour = prior, fill = prior)) +
  geom_density(alpha = .4) +
  scale_x_continuous(expression(theta)) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 16) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p1

## Compare posterior predictives
pred.df <- data.frame(
  x_pred = c(as.vector(extract(fit.normal, 'x_pred')$x_pred),
             as.vector(extract(fit.cauchy, 'x_pred')$x_pred))
)
pred.df$prior <- rep(c("Normal", "Cauchy"), each = nrow(pred.df)/2)

p2 <- ggplot(pred.df,
             aes(x = x_pred, colour = prior, fill = prior)) +
  geom_density(alpha = .4) +
  scale_x_continuous(expression(x[pred])) +
  scale_y_continuous("Density", expand = c(0, 0)) +
  theme_bw(base_size = 16) +
  # geom_vline(xintercept = c(-4, 4), linetype = "longdash") +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))

p2


# variable y  with normal distribution N(??, ??), where ??=70 and ?? = 13
#  the probability that a measurement will be less than 60 is given by
pnorm(60,mean =70,sd=13)
#  probability that a randomly selected vehicle will have emission levels greater than 90 ppb
pnorm(90,mean =70,sd=13,lower.tail = FALSE)
# the probability that a randomly selected vehicle will have emission levels between 60 and 90 ppb
pnorm(90,mean =70,sd=13)-pnorm(60,mean =70,sd=13)


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

pdf = function(x) {
    1 / (pi * (1 + x^2))
}

inverse_cdf = function(u) {
    tan(pi * (u - 1/2))
}

bin_count = 50
samples_count = 100000

###############################################################################
#                           Inverse Function Method                           #
###############################################################################

# Plot the original function.
x_orig = seq(-5, 5, length.out=200)
y_orig = pdf(x_orig)
plot(x_orig, y_orig, type='l', main='Original PDF', xlab='x', ylab='y')

# Plot the inverse function.
u_inv_cdf = seq(0.02, 0.98, length.out=100)
x_inv_cdf = inverse_cdf(u_inv_cdf)
plot(u_inv_cdf, x_inv_cdf, type='l', main='Inverse CDF', xlab='u', ylab='x')

# Sample from uniform and transform it.
start = proc.time()
u = runif(samples_count)
x = inverse_cdf(u)
end = proc.time()
duration_inverse_cdf = end - start
cat('Time for Inverse Function:', duration_inverse_cdf, '\n')

# There is a complication that the resulting values span the whole real
# numbers. We cannot sensibly display that in a histogram. Therefore we need to
# limit the histogram. Just using `xlim` here does not suffice; it would just
# adjust the plotting window. We want to have the bins focussed in a sensible
# interval. R would complain if the bins do not cover all the values, so we
# need to select the interesting values as well.
selection = -5 < x & x < 5
hist(x[selection], breaks=seq(-5, 5, length.out=bin_count), freq=FALSE,
     main='Sampling with Inverse Function Method')

# By not using all data points, we effectively have sampled a different pdf.
# This means that the normalization is off, we need to correct for that.
factor = samples_count / sum(selection)
lines(x_orig, y_orig * factor, col='red')

###############################################################################
#                                Ratio Method                                 #
###############################################################################

start = proc.time()
x = rnorm(samples_count)
y = rnorm(samples_count)
z = x / y
end = proc.time()
duration_inverse_cdf = end - start
cat('Time for Ratio:', duration_inverse_cdf, '\n')

selection = -5 < z & z < 5
hist(z[selection], breaks=seq(-5, 5, length.out=bin_count), freq=FALSE,
     main='Sampling with Ratio Method')

factor = samples_count / sum(selection)
lines(x_orig, y_orig * factor, col='red')


##### Chapter 5: Classification using Decision Trees and Rules -------------------

#### Part 1: Decision Trees -------------------

## Understanding Decision Trees ----
# calculate entropy of a two-class segment
-0.60 * log2(0.60) - 0.40 * log2(0.40)

curve(-x * log2(x) - (1 - x) * log2(1 - x),
      col = "red", xlab = "x", ylab = "Entropy", lwd = 4)

## Example: Identifying Risky Bank Loans ----
## Step 2: Exploring and preparing the data ----
credit <- read.csv("credit.csv")
str(credit)

# look at two characteristics of the applicant
table(credit$checking_balance)
table(credit$savings_balance)

# look at two characteristics of the loan
summary(credit$months_loan_duration)
summary(credit$amount)

# look at the class variable
table(credit$default)

# create a random sample for training and test data
# use set.seed to use the same random number sequence as the tutorial
set.seed(123)
train_sample <- sample(1000, 900)

str(train_sample)

# split the data frames
credit_train <- credit[train_sample, ]
credit_test  <- credit[-train_sample, ]

# check the proportion of class variable
prop.table(table(credit_train$default))
prop.table(table(credit_test$default))

## Step 3: Training a model on the data ----
# build the simplest decision tree
library(C50)
credit_model <- C5.0(credit_train[-17], credit_train$default)

# display simple facts about the tree
credit_model

# display detailed information about the tree
summary(credit_model)

## Step 4: Evaluating model performance ----
# create a factor vector of predictions on test data
credit_pred <- predict(credit_model, credit_test)

# cross tabulation of predicted versus actual classes
library(gmodels)
CrossTable(credit_test$default, credit_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))

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

## Boosting the accuracy of decision trees
# boosted decision tree with 10 trials
credit_boost10 <- C5.0(credit_train[-17], credit_train$default,
                       trials = 10)
credit_boost10
summary(credit_boost10)

credit_boost_pred10 <- predict(credit_boost10, credit_test)
CrossTable(credit_test$default, credit_boost_pred10,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))

## Making some mistakes more costly than others

# create dimensions for a cost matrix
matrix_dimensions <- list(c("no", "yes"), c("no", "yes"))
names(matrix_dimensions) <- c("predicted", "actual")
matrix_dimensions

# build the matrix
error_cost <- matrix(c(0, 1, 4, 0), nrow = 2, dimnames = matrix_dimensions)
error_cost

# apply the cost matrix to the tree
credit_cost <- C5.0(credit_train[-17], credit_train$default,
                          costs = error_cost)
credit_cost_pred <- predict(credit_cost, credit_test)

CrossTable(credit_test$default, credit_cost_pred,
           prop.chisq = FALSE, prop.c = FALSE, prop.r = FALSE,
           dnn = c('actual default', 'predicted default'))

#### Part 2: Rule Learners -------------------

## Example: Identifying Poisonous Mushrooms ----
## Step 2: Exploring and preparing the data ----
mushrooms <- read.csv("mushrooms.csv", stringsAsFactors = TRUE)

# examine the structure of the data frame
str(mushrooms)

# drop the veil_type feature
mushrooms$veil_type <- NULL

# examine the class distribution
table(mushrooms$type)

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

# train OneR() on the data
mushroom_1R <- OneR(type ~ ., data = mushrooms)

## Step 4: Evaluating model performance ----
mushroom_1R
summary(mushroom_1R)

## Step 5: Improving model performance ----
mushroom_JRip <- JRip(type ~ ., data = mushrooms)
mushroom_JRip
summary(mushroom_JRip)

# Rule Learner Using C5.0 Decision Trees (not in text)
library(C50)
mushroom_c5rules <- C5.0(type ~ odor + gill_size, data = mushrooms, rules = TRUE)
summary(mushroom_c5rules)


# Load dataset
dataset2 <- read.csv("dataset2.csv", quote="")
# Print summary of dataset
summary(dataset2)

# Perform MANOVA analysis
manova_results <- manova(cbind(time, error) ~ menu, data=dataset2)
print("Summary of Manova Analysis:")
# Print summary of MANOVA
summary(manova_results)
# Get the p_value of the test
p_value <- summary(manova_results)$stats[[1,6]]
print(p_value)

if (p_value < 0.05) {  # If p_value < 0.05: reject the null hypothesis
  print("p_value is less than 0.05. Hence the results are not by chance variation and the null hypothesis is rejected. There is significant effect of independent variable menu type on dependent variable access time and error.")
} else {  # Else accept the null hypothesis
  print("p_value is greater than or equal to 0.05. Hence the results could be by chance variation and we cannot reject the null hypothesis. There is no significant effect of independent variable menu type on dependent variable access time and error.")
}

# Perform ANOVA analysis
print("Perform ANOVA analysis to find out which dependent variable (time or error) does the independent variable (menu) has a significant effect on.")
anova_results <- summary.aov(manova_results)
print(anova_results)

# Analyze effect of menu on time
p_value_time <- anova_results$` Response time`$`Pr(>F)`[[1]]
print(paste("p_value time: ", p_value_time))
if (p_value_time < 0.05) {
  print("p_value of time is less than 0.05. Hence independent variable menu has significant effect on dependent variable time.")
} else {
  print("p_value of time is not less than 0.05. Hence independent variable menu does not have a significant effect on dependent variable time.")
}

# Analyze effect of menu on error
p_value_error <- anova_results$` Response error`$`Pr(>F)`[[1]]
print(paste("p_value error: ", p_value_error))
if (p_value_error < 0.05) {
  print("p_value of error is less than 0.05. Hence independent variable menu has significant effect on dependent variable error")
} else {
  print("p_value of error is not less than 0.05. Hence independent variable menu does not have a significant effect on dependent variable error")
}

# Perform pairwise t-test with dependent variable time
t_test_results <- pairwise.t.test(dataset2$time, dataset2$menu, p.adjust.method = "bonferroni", paired = TRUE)
print(t_test_results)

# One tailed t-test between toolpalette and controlmenu
toolpalette <- subset(dataset2, menu == "toolpalette")
controlmenu <- subset(dataset2, menu == "controlmenu")
t_test_result <- t.test(toolpalette$time, controlmenu$time, alternative = "greater", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolpalette-controlmenu: ", p_value))

# One tailed t-test between toolpalette and flowmenu
toolpalette <- subset(dataset2, menu == "toolpalette")
flowmenu <- subset(dataset2, menu == "flowmenu")
t_test_result <- t.test(toolpalette$time, flowmenu$time, alternative = "greater", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolpalette-flowmenu: ", p_value))

# One tailed t-test between toolpalette and toolglass
toolpalette <- subset(dataset2, menu == "toolpalette")
toolglass <- subset(dataset2, menu == "toolglass")
t_test_result <- t.test(toolpalette$time, toolglass$time, alternative = "greater", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolpalette-toolglass: ", p_value))

# Perform pairwise t-test with dependent variable error
t_test_results <- pairwise.t.test(dataset2$error, dataset2$menu, p.adjust.method = "bonferroni", paired = TRUE)
print(t_test_results)

# One tailed t-test between toolglass and controlmenu
toolglass <- subset(dataset2, menu == "toolglass")
controlmenu <- subset(dataset2, menu == "controlmenu")
t_test_result <- t.test(toolglass$error, controlmenu$error, alternative = "less", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolglass-controlmenu: ", p_value))

# One tailed t-test between toolglass and flowmenu
toolglass <- subset(dataset2, menu == "toolglass")
flowmenu <- subset(dataset2, menu == "flowmenu")
t_test_result <- t.test(toolglass$error, flowmenu$error, alternative = "less", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolglass-flowmenu: ", p_value))

# One tailed t-test between toolglass and toolpalette
toolglass <- subset(dataset2, menu == "toolglass")
toolpalette <- subset(dataset2, menu == "toolpalette")
t_test_result <- t.test(toolglass$error, toolpalette$error, alternative = "less", paired = TRUE)
p_value <- t_test_result$p.value
print(paste("p_value toolglass-toolpalette: ", p_value))

# Visualizations
boxplot(time~menu,
        data=dataset2,
        main="Different boxplots for each menu",
        xlab="Menu",
        ylab="Time",
        frame = FALSE,
        col = c("#DDEDAA", "#F4AC45", "#FFCAB1", "#92BFB1"),
        border="black"
)

boxplot(error~menu,
        data=dataset2,
        main="Different boxplots for each menu",
        xlab="Menu",
        ylab="Error",
        frame = FALSE,
        col = c("#DDEDAA", "#F4AC45", "#FFCAB1", "#92BFB1"),
        border="black"
)

# between-within plot for time
B <- anova(lm(time ~ menu, data = dataset2))$"Mean Sq"
names(B) <- c("between", "within")
barplot(B, main = "Between vs. within", xlab = "Group (Menu)", ylab = "Sum of Squares (Time)", col = c("#DDEDAA", "#F4AC45"))

# between-within plot for error
B <- anova(lm(error ~ menu, data = dataset2))$"Mean Sq"
names(B) <- c("between", "within")
barplot(B, main = "Between vs. within", xlab = "Group (Menu)", ylab = "Sum of Squares (Error)", col = c("#DDEDAA", "#F4AC45"))


# Poisson Distribution
# Poisson probability of observing y events in a unit of time or space is given by the formula
# probability_y<-((U^y)*(e^-U))/factorial(y)
# U is the average value of y
U<-2.3
# The probability that a trap contains exactly four field mice is computed
y<-4
probability_findingexactlyfour<-((U^y)*(exp(1)^-U))/factorial(y)
print(probability_findingexactlyfour)
# The probability That a trap contains atmost four feild mice is computed as
probability_findingatmost_four=(((U^0)*(exp(1)^-U))/factorial(0))+(((U^1)*(exp(1)^-U))/factorial(1))+(((U^2)*(exp(1)^-U))/factorial(2))+(((U^3)*(exp(1)^-U))/factorial(3))+(((U^4)*(exp(1)^-U))/factorial(4))
print(probability_findingatmost_four)
# The probability of finding more than four field mice
probability_findingmorethanfour=1-probability_findingatmost_four
print(probability_findingmorethanfour)


library(deSolve)
library(ggplot2)
library(reshape2)
library(gridExtra)
library(Rcpp)
library(RColorBrewer)

SIR <- function(Time, State, Pars) {

    with(as.list(c(State, Pars)), {

        B   <- R0*r/N
        BSI <- B*S*I
        rI  <- r*I

        dS = -BSI
        dI = BSI - rI
        dR = rI

        return(list(c(dS, dI, dR)))

    })

}

StocSIR <- function(y, pars, T, steps) {

	out <- matrix(NA, nrow = (T+1), ncol = 4)

	R0 <- pars[['R0']]
	r <- pars[['r']]
	N <- pars[['N']]
	eta <- pars[['eta']]
	berr <- pars[['berr']]

	S <- y[['S']]
	I <- y[['I']]
	R <- y[['R']]

	B0 <- R0 * r / N
	B <- B0

	out[1,] <- c(S,I,R,B)

	h <- 1 / steps

	for ( i in 1:(T*steps) ) {

		B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(1, 0, berr) )

		BSI <- B*S*I
		rI <- r*I

		dS <- -BSI
		dI <- BSI - rI
		dR <- rI

		S <- S + h*dS  #newInf
		I <- I + h*dI  #newInf - h*dR
		R <- R + h*dR  #h*dR

		if (i %% steps == 0)
			out[i/steps+1,] <- c(S,I,R,B)

	}

	return(out)

}

set.seed(50721456)

T 		<- 60
i_infec <- 5
steps 	<- 7
N 		<- 500
sigma 	<- 10
Tlim 	<- T

## Generate true trajecory and synthetic data
##

pars_true <- c(R0 = 3.0, 	# new infected people per infected person
          r = 0.1, 		# recovery rate
		  N = 500, 		# population size
		  eta = 0.5, 	# geometric random walk
		  berr = 0.3) 	# Beta geometric walk noise

true_init_cond <- c(S = N - i_infec,
					I = i_infec,
					R = 0)

sdeout_true <- StocSIR(true_init_cond, pars_true, T, steps)
colnames(sdeout_true) <- c('S','I','R','B')

#quartz()
#plot(1:(T+1), sdeout[,'B'])

infec_counts_raw <- sdeout_true[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

plotdata <- data.frame(times = 0:T, true = sdeout_true[,'I'], data = infec_counts)

g <- ggplot(plotdata, aes(times)) +
        geom_line(aes(y = true, colour = "True")) +
        geom_point(aes(y = data, colour = "Data")) +
        labs(x = "Time", y = "Infection count", color = "") +
        scale_color_brewer(palette="Paired") +
        theme(panel.background = element_rect(fill = "#F0F0F0"))

if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
print(g)

#ggsave(g, filename="dataplot.pdf", height=4, width=6.5)

## Rcpp stuff
##

NP <- 30000
nPasses <- 10
coolrate <- 0.9

sourceCpp(paste(getwd(),"if2.cpp",sep="/"))

if2data <- if2(infec_counts[1:(Tlim+1)], Tlim+1, N, NP, nPasses, coolrate)

paramdata <- data.frame( if2data$paramdata )
names(paramdata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

convergedata <- data.frame( if2data$means )
names(convergedata) <- c("R0", "r", "sigma", "eta", "berr", "Sinit", "Iinit", "Rinit")

statedata <- data.frame( if2data$statemeans )
names(statedata) <- c("S","I","R")

## last particle filter means plot
if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
qplot(1:(T+1), sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection counts") +
	geom_point(aes(y = infec_counts)) +
	geom_line(aes(y = statedata[,'I']), linetype = "dashed") +
	theme_bw()

## sample from parameter distributions
##

nTraj 	<- 100
datlen 	<- dim(paramdata)[1]
inds 	<- sample.int(datlen,nTraj,replace = TRUE)
params 	<- paramdata[inds,]

bootstrapdata <- matrix(NA, nrow = nTraj, ncol = T+1)

for (i in 1:nTraj) {

	init_cond <- c(S = params$Sinit[i],
	               I = params$Iinit[i],
	               R = params$Rinit[i])
	pars <- c(R0 = params$R0[i],
	          r = params$r[i],
	          N = 500.0,
	          eta = params$eta[i],
	          berr = params$berr[i])

	sdeout <- StocSIR(init_cond, pars, T, steps)
	colnames(sdeout) <- c('S','I','R','B')

	bootstrapdata[i,] <- sdeout[,'I']

}

meanTraj 	<- colMeans(bootstrapdata)
quantTraj 	<- t(apply(bootstrapdata, 2, quantile, probs = c(0.025,0.975)))
colnames(quantTraj) <- c("025","975")

datapart <- c(infec_counts[1:(Tlim+1)],rep(NA,T-Tlim))

g <- qplot(1:(T+1), sdeout_true[,'I'], geom = "line", xlab = "Time", ylab = "Infection count") +
        geom_ribbon(aes(ymin = quantTraj[,'025'], ymax=quantTraj[,'975']), alpha=0.1) +
        geom_line(aes(y = meanTraj), linetype = "dashed") +
        geom_point(aes(y = datapart)) +
        theme_bw()

if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
print(g)

#ggsave(g, filename="if2plot.pdf", height=4, width=6.5)

f <- function(pal) brewer.pal(brewer.pal.info[pal, "maxcolors"], pal)
kcolours <- f("Paired")

trueval.R0 		<- 3.0
trueval.r 		<- 0.1
trueval.sigma 	<- 10.0
trueval.Iinit 	<- 5
trueval.eta 	<- 0.5
trueval.berr 	<- 0.3

meanval.R0 		<- mean(convergedata$R0)
meanval.r 		<- mean(convergedata$r)
meanval.sigma 	<- mean(convergedata$sigma)
meanval.Iinit 	<- mean(convergedata$Iinit)
meanval.eta 	<- mean(convergedata$eta)
meanval.berr 	<- mean(convergedata$berr)

linecolour <- "grey50"
lineweight <- 0.5

## Convergence 'kernels'
if (FALSE) {
	R0kernel <- qplot(convergedata$R0, geom = "density", xlab = expression(R[0]), ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	rkernel <- qplot(convergedata$r, geom = "density", xlab = "r", ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	sigmakernel <- qplot(convergedata$sigma, geom = "density", xlab = expression(sigma), ylab = "") +
	    			geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	infeckernel <- qplot(convergedata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "") +
	    			geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	etakernel <- qplot(convergedata$eta, geom = "density", xlab = expression(eta), ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	berrkernel <- qplot(convergedata$berr, geom = "density", xlab = expression(epsilon[proc]), ylab = "") +
	    			geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
	    			geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
					theme_bw()

	# show grid
	if ( Sys.info()['sysname'] == 'Darwin' )
		quartz()
	grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel,
	             ncol = 3, nrow = 2, top = "Convergence kernels")
}

# Convergence plots

R0converge <- qplot(1:dim(convergedata)[1], convergedata$R0, geom = "line", xlab = expression(R[0]), ylab = "frequency") +
    			geom_hline(aes(yintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rconverge <- qplot(1:dim(convergedata)[1], convergedata$r, geom = "line", xlab = "r", ylab = "") +
    			geom_hline(aes(yintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmaconverge <- qplot(1:dim(convergedata)[1], convergedata$sigma, geom = "line", xlab = expression(sigma), ylab = "") +
    			geom_hline(aes(yintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infecconverge <- qplot(1:dim(convergedata)[1], convergedata$Iinit, geom = "line", xlab = "Initial Infected", ylab = "frequency") +
    			geom_hline(aes(yintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etaconverge <- qplot(1:dim(convergedata)[1], convergedata$eta, geom = "line", xlab = expression(eta), ylab = "") +
    			geom_hline(aes(yintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrconverge <- qplot(1:dim(convergedata)[1], convergedata$berr, geom = "line", xlab = expression(epsilon[proc]), ylab = "") +
    			geom_hline(aes(yintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_hline(aes(yintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

# show grid
if ( Sys.info()['sysname'] == 'Darwin' )
	quartz()
grid.arrange(R0converge, rconverge, sigmaconverge, infecconverge, etaconverge, berrconverge,
             ncol = 3, nrow = 2, top = "Convergence plots")

# Final swarm kernel densities

meanval.R0 		<- mean(paramdata$R0)
meanval.r 		<- mean(paramdata$r)
meanval.sigma 	<- mean(paramdata$sigma)
meanval.Iinit 	<- mean(paramdata$Iinit)
meanval.eta 	<- mean(paramdata$eta)
meanval.berr 	<- mean(paramdata$berr)

linecolour <- "grey50"
lineweight <- 0.5

R0kernel <- qplot(paramdata$R0, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
    			geom_vline(aes(xintercept=pars_true['R0']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.R0), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

rkernel <- qplot(paramdata$r, geom = "density", xlab = "r") +
    			geom_vline(aes(xintercept=pars_true['r']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.r), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

sigmakernel <- qplot(paramdata$sigma, geom = "density", xlab = expression(sigma)) +
    			geom_vline(aes(xintercept=sigma), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.sigma), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

infeckernel <- qplot(paramdata$Iinit, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
    			geom_vline(aes(xintercept=i_infec), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.Iinit), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

etakernel <- qplot(paramdata$eta, geom = "density", xlab = expression(eta)) +
    			geom_vline(aes(xintercept=pars_true['eta']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.eta), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

berrkernel <- qplot(paramdata$berr, geom = "density", xlab = expression(epsilon[proc])) +
    			geom_vline(aes(xintercept=pars_true['berr']), linetype="solid", size=lineweight, color=linecolour) +
    			geom_vline(aes(xintercept=meanval.berr), linetype="dashed", size=lineweight, color=linecolour) +
				theme_bw()

# show grid
grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, etakernel, berrkernel,
             ncol = 3, nrow = 2, top = "Swarm final density kernels")

#pdf("if2kernels.pdf", height = 6.5, width = 6.5)
#grid.arrange(R0kernel, rkernel, sigmakernel, infeckernel, ncol = 2, nrow = 2)
#dev.off()


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 01

rm(list = ls())

observed <- c(967, 1008, 975, 1022, 1003, 989, 1001, 981, 1043, 1011)

(n <- sum(observed))
# 10000

(k <- length(observed))
# 10

(expected <- 1 / k * n)
# 1000

(Q <- sum((observed - expected) ^ 2 / expected))
# 4.724

(pvalue <- 1 - pchisq(Q, k - 1))
# 0.857673749486367


omedian <- function(v) {
  if ( length(v) < 1 )
    NA
  else {
    sv <- sort(v)
    l <- length(sv)
    if ( l %% 2 == 0 )
      (sv[floor(l/2)+1] + sv[floor(l/2)])/2
    else
      sv[floor(l/2)+1]
  }
}

a <- c(4.1, 5.6, 7.2, 1.7, 9.3, 4.4, 3.2)
b <- c(4.1, 7.2, 1.7, 9.3, 4.4, 3.2)

print(median(a))   # 4.4
print(omedian(a))
print(median(b))   # 4.25
print(omedian(b))


#' Computes the maximum likelihood estimator for the sample covariance matrix
#' under the assumption of multivariate normality.
#'
#' For a sample matrix, `x`, we compute the sample covariance matrix of the
#' data as the maximum likelihood estimator (MLE) of the population covariance
#' matrix.
#'
#' If the `diag` option is set to `TRUE`, then we assume the population
#' covariance matrix is diagonal, and the MLE is computed under this assumption.
#' In this case, we return a vector of length `p` instead.
#'
#' @export
#' @importFrom stats var cov
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param diag logical value. If TRUE, assumes the population covariance matrix
#' is diagonal. By default, we assume that `diag` is `FALSE`.
#' @return sample covariance matrix of size \eqn{p \times p}. If `diag` is
#' `TRUE`, then a vector of length `p` is returned instead.
cov_mle <- function(x, diag = FALSE) {
  x <- as.matrix(x)
  n <- nrow(x)
  if (diag) {
    (n - 1) / n * apply(x, 2, var)
  } else {
    (n - 1) / n * cov(x)
  }
}

#' Computes the pooled maximum likelihood estimator (MLE) for the common
#' covariance matrix
#'
#' For the matrix `x`, we compute the MLE for the population covariance
#' matrix under the assumption that the data are sampled from \eqn{K}
#' multivariate normal populations having equal covariance matrices.
#'
#' @export
#' @importFrom stats cov
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param y class labels for observations (rows) in `x`
#' @return pooled sample covariance matrix of size \eqn{p \times p}
#' @examples
#' cov_pool(iris[, -5], iris$Species)
cov_pool <- function(x, y) {
  x <- as.matrix(x)
  y <- as.factor(y)
  n <- length(y)

  scatter_matrices <- tapply(seq_len(n), y, function(i) {
    (length(i) - 1) * cov(as.matrix(x[i, ]))
  })
  as.matrix(Reduce("+", scatter_matrices) / n)
}

#' Computes the covariance-matrix maximum likelihood estimators for each class
#' and returns a list.
#'
#' For a sample matrix, `x`, we compute the MLE for the covariance matrix
#' for each class given in the vector, `y`.
#' @export
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param y class labels for observations (rows) in `x`
#' @return list of the sample covariance matrices of size \eqn{p \times p} for
#' each class given in `y`.
cov_list <- function(x, y) {
  x <- as.matrix(x)
  y <- as.factor(y)
  tapply(seq_along(y), y, function(i) {
    cov_mle(x[i, ])
  })
}

#' Computes the eigenvalue decomposition of the maximum likelihood estimators
#' (MLE) of the covariance matrices for the given data matrix
#'
#' For the classes given in the vector `y`, we compute the eigenvalue
#' (spectral) decomposition of the class sample covariance matrices (MLEs) using
#' the data matrix `x`.
#'
#' If the `fast` argument is selected, we utilize the so-called Fast
#' Singular Value Decomposition (SVD) to quickly compute the eigenvalue
#' decomposition. To compute the Fast SVD, we use the [corpcor::fast.svd()]
#' function, which employs a well-known trick for tall data (large `n`,
#' small `p`) and wide data (large `p`, small `n`) to compute the
#' SVD corresponding to the nonzero singular values. For more information about
#' the Fast SVD, see [corpcor::fast.svd()].
#'
#' @importFrom corpcor fast.svd
#' @export
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param y class labels for observations (rows) in `x`
#' @param pool logical. Should the sample covariance matrices be pooled?
#' @param fast logical. Should the Fast SVD be used? See details.
#' @param tol tolerance value below which the singular values of `x` are
#' considered zero.
#' @return a list containing the eigendecomposition for each class. If
#' `pool = TRUE`, then a single list is returned.
#' @examples
#' cov_eigen(x = iris[, -5], y = iris[, 5])
#' cov_eigen(x = iris[, -5], y = iris[, 5], pool = TRUE)
#' cov_eigen(x = iris[, -5], y = iris[, 5], pool = TRUE, fast = TRUE)
#'
#' # Generates a data set having fewer observations than features.
#' # We apply the Fast SVD to compute the eigendecomposition corresponding to the
#' # nonzero eigenvalues of the covariance matrices.
#' set.seed(42)
#' n <- 5
#' p <- 20
#' num_classes <- 3
#' x <- lapply(seq_len(num_classes), function(k) {
#'   replicate(p, rnorm(n, mean = k))
#' })
#' x <- do.call(rbind, x)
#' colnames(x) <- paste0("x", 1:ncol(x))
#' y <- gl(num_classes, n)
#' cov_eigen(x = x, y = y, fast = TRUE)
#' cov_eigen(x = x, y = y, pool = TRUE, fast = TRUE)
cov_eigen <- function(x, y, pool = FALSE, fast = FALSE, tol = 1e-6) {
  x <- as.matrix(x)
  y <- as.factor(y)

  if (fast) {
    # First, we center each class.
    x_centered <- center_data(x = x, y = y)
    if (pool) {
      n <- nrow(x_centered)
      svd_out <- fast.svd(x_centered)
      eigenvals <- svd_out$d^2 / n
      # We retain only the 'q' eigenvalues greater than 'tol'. Effectively, 'q'
      # is our estimate for the rank of the covariance matrix.
      q <- sum(eigenvals > tol)
      seq_q <- seq_len(q)
      eigen_out <- list(vectors = svd_out$v[, seq_q], values = eigenvals[seq_q])
    }
    else {
      eigen_out <- tapply(seq_along(y), y, function(i) {
        n <- length(i)
        svd_out <- fast.svd(x_centered[i, ])
        eigenvals <- svd_out$d^2 / n
        # We retain only the 'q' eigenvalues greater than 'tol'. Effectively, 'q'
        # is our estimate for the rank of the covariance matrix.
        q <- sum(eigenvals > tol)
        seq_q <- seq_len(q)
        list(vectors = svd_out$v[, seq_q], values = eigenvals[seq_q])
      })
    }
  } else {
    if (pool) {
      eigen_out <- eigen(cov_pool(x = x, y = y), symmetric = TRUE)
    } else {
      eigen_out <- lapply(cov_list(x = x, y = y), eigen, symmetric = TRUE)
    }
  }
  eigen_out
}

#' Computes the observation weights for each class for the HDRDA classifier
#'
#' This function calculates the weight for each observation in the data matrix
#' `x` in order to calculate the covariance matrices employed in the HDRDA
#' classifier, implemented in [rda_high_dim()].
#'
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param lambda the RDA pooling parameter. Must be between 0 and 1, inclusively.
#' @return list containing the observations for each class given in `y`
#'
#' @references Ramey, J. A., Stein, C. K., and Young, D. M. (2013),
#' "High-Dimensional Regularized Discriminant Analysis."
rda_weights <- function(x, y, lambda = 1) {
  x <- as.matrix(x)
  y <- as.factor(y)
  N <- length(y)
  tapply(seq_along(y), y, function(i) {
    n_k <- length(i)
    weights_k <- lambda / N + (1 - lambda) / n_k
    replace(rep(lambda / N, N), i, weights_k)
  })
}

#' Calculates the RDA covariance-matrix estimators for each class
#'
#' For the classes given in the vector `y`, this function calculates the
#' class covariance-matrix estimators employed in the HDRDA classifier,
#' implemented in [rda_high_dim()].
#'
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @param lambda the RDA pooling parameter. Must be between 0 and 1, inclusively.
#' @return list containing the RDA covariance-matrix estimators for each class
#' given in `y`
#'
#' @references Ramey, J. A., Stein, C. K., and Young, D. M. (2013),
#' "High-Dimensional Regularized Discriminant Analysis."
rda_cov <- function(x, y, lambda = 1) {
  x_centered <- center_data(x = x, y = y)
  weights <- rda_weights(x = x, y = y, lambda = lambda)
  lapply(weights, function(weights_k) {
    x_scaled <- sqrt(weights_k) * x_centered
    crossprod(x_scaled)
  })
}

#' Computes a shrunken version of the maximum likelihood estimator for the
#' sample covariance matrix under the assumption of multivariate normality.
#'
#' For a sample matrix, `x`, we compute the sample covariance matrix as the
#' maximum likelihood estimator (MLE) of the population covariance matrix and
#' shrink it towards its diagonal.
#'
#' Let \eqn{\widehat{\Sigma}} be the MLE of the covariance matrix \eqn{\Sigma}.
#' Then, we shrink the MLE towards its diagonal by computing
#' \deqn{\widehat{\Sigma}(\gamma) = \gamma \widehat{\Sigma} + (1 - \gamma)
#' \widehat{\Sigma} \circ I_p,} where \eqn{\circ} denotes the Hadamard product
#' and \eqn{\gamma \in [0,1]}.
#'
#' For \eqn{\gamma < 1}, the resulting shrunken covariance matrix estimator is
#' positive definite, and for \eqn{\gamma = 1}, we simply have the MLE, which can
#' potentially be positive semidefinite (singular).
#'
#' The estimator given here is based on Section 18.3.1 of the Hastie et
#' al. (2008) text.
#'
#' @export
#' @param x data matrix with `n` observations and `p` feature vectors
#' @param gamma the shrinkage parameter. Must be between 0 and 1, inclusively.
#' By default, the shrinkage parameter is 1, which simply yields the MLE.
#' @return shrunken sample covariance matrix of size \eqn{p \times p}
#'
#' @references Hastie, T., Tibshirani, R., and Friedman, J. (2008), "The
#' Elements of Statistical Learning: Data Mining, Inference, and Prediction,"
#' 2nd edition. \url{http://web.stanford.edu/~hastie/ElemStatLearn/}
cov_shrink_diag <- function(x, gamma = 1) {
  if (gamma < 0 || gamma > 1) {
    rlang::abort("The value of 'gamma' must be between 0 and 1, inclusively.")
  }
  cov_x <- cov_mle(x)
  gamma * cov_x + (1 - gamma) * diag(diag(cov_x))
}


# ************************************************
### simon munzert
### ols and multiple regression
# ************************************************

source("packages.r")
source("functions.r")

# ************************************************
# Bivariate regression, OLS estimation -----------

# load data
data("wage1")

# inspect relationship
qplot(educ, wage, data = wage1)
plot(wage1$educ, wage1$wage)
cor(wage1$wage, wage1$educ)
with(wage1, cor(educ, wage))

# run linear model
wage_model <- lm(wage ~ educ, data = wage1)
summary(wage_model)
coef(wage_model)

# export model
stargazer(wage_model, single.row = TRUE, header = FALSE, style = "apsr", type = "html", out = "../output/wage_model_ols.html")
browseURL("../output/wage_model_ols.html")

# manual computation
covariance_xy <- with(wage1, cov(wage, educ))
variance_x <- var(wage1$educ)
covariance_xy / variance_x # beta_1
mean(wage1$wage) - (covariance_xy / variance_x)*mean(wage1$educ) # beta_0

# ************************************************
# Multiple regression, OLS estimation ------------

# run linear model
wage_model <- lm(wage ~ educ + female, data = wage1)
summary(wage_model)
coef(wage_model)

# manual computation for beta_educ

# step 1: isolate part of X that is linearly independent from Z
wage_model_xz <- lm(educ ~ female, data = wage1)
resid_xz <- residuals(wage_model_xz)

# step 2: explain Y by part of X that is independent from Z
wage_model_yx <- lm(wage1$wage ~ resid_xz)
coef(wage_model_yx)

## continue in analogy to arrive at point estimate for beta_female.

# ************************************************
# How are coefficients from simple and -----------
# multiple OLS estimates related? ----------------

wage_model <- lm(wage ~ educ, data = wage1)
coef_simple <- coef(wage_model)[2]

wage_model_mult <- lm(wage ~ educ + female, data = wage1)
coef_multiple <- coef(wage_model_mult)[2]

wage_model_zx <- lm(female ~ educ, data = wage1)
coef_simple_zx <- coef(wage_model_zx)[2]

# these two are the same:
coef_simple
coef_multiple + coef(wage_model_mult)[3]*coef(wage_model_zx)[2]

# ***************************************************
# Effects of controls on coefficients of interest ---

wage_model_1 <- lm(wage ~ educ, data = wage1)
wage_model_2 <- lm(wage ~ educ + female, data = wage1)
wage_model_3 <- lm(wage ~ educ + female + nonwhite, data = wage1)
wage_model_4 <- lm(wage ~ educ + female + nonwhite + profocc, data = wage1)

stargazer(wage_model_1, wage_model_2, wage_model_3, wage_model_4, header = FALSE, style = "apsr", type = "html", out = "../output/wage_model_multiple.html")
browseURL("../output/wage_model_multiple.html")
stargazer(wage_model_1, wage_model_2, wage_model_3, wage_model_4, header = FALSE, title = "Regressing wage on...", omit.table.layout = "dln", style = "apsr", font.size = "scriptsize", df = FALSE, report = "vcs", single.row = FALSE, no.space = TRUE, type = "latex", out = "../output/wage_model_multiple.tex")

cor(select(wage1, wage, educ, female, nonwhite, profocc))

# ************************************************
# Post-estimation bias: simulation ---------------

set.seed(42)
N <- 500
x <- rnorm(N, 0, 1)
ed <- rnorm(N, 0, .5)
d <- .8*x + ed  # d is mediator
ey <- rnorm(N, 0, .5)
y <- x + d + ey

cor(cbind(y, x, d))
plot(x, y)

# complete "true" models
summary(lm(d ~ x))
summary(lm(y ~ x))

# model with induced post-treatment bias
summary(lm(y ~ x + d))

# ************************************************
# Multicollinearity: detection -------------------

data(bwght2)
?bwght2
vars <- c("mage", "meduc", "monpre", "npvis", "fage", "feduc", "cigs", "drink", "male")
b <- paste(vars, collapse = "+")
frmla <- as.formula(paste("bwght ~ ", b, sep = ""))

# example: perfect collinearity
summary(lm(bwght ~ fwhte + fblck + foth, data = bwght2))

# full model
model_out <- lm(frmla, data = bwght2)
summary(model_out)

# inspect correlation matrix
cor(bwght2[,vars], use = "pairwise.complete.obs")

# inspect scatterplots
plot(bwght2[,vars])

# evaluate variance inflation factors
vif(model_out) # function from car package

# ************************************************
# Anscombe's quartett ----------------------------

?anscombe
summary(anscombe)

# correlation
sapply(1:4, function(x) cor(anscombe[, x], anscombe[, x+4]))

# variance
sapply(5:8, function(x) var(anscombe[, x]))

# linear regression
summary(lm(y1 ~ x1, data = anscombe))
summary(lm(y2 ~ x2, data = anscombe))
summary(lm(y3 ~ x3, data = anscombe))
summary(lm(y4 ~ x4, data = anscombe))

# plot
ff <- y ~ x
par(mfrow = c(2, 2))
for(i in 1:4) {
  ff[2:3] <- lapply(paste0(c("y","x"), i), as.name)
  plot(ff, data = anscombe, col = "red", pch = 21, bg = "orange", cex = 1.2, xlim = c(3, 19), ylim = c(3, 13))
  model_out <- lm(ff, data = anscombe)
  abline(model_out, col = "blue")
}
mtext("Anscombe's 4 regression data sets", outer = TRUE, cex = 1.5)

# ************************************************
# Functional form misspecification ---------------

N <- 500
x <- runif(N, 0, 1)
y <- log(x) + rnorm(N, 0, .3)

# look at model
summary(lm(y ~ x))
summary(lm(y ~ log(x)))

# plot relationship
par(mfrow = c(1, 3))
# misspecified
plot(x, y); abline(lm(y ~ x), col = "red")
# correctly specified
dat <- data.frame(x = sort(x), ypred = predict(lm(y ~ log(x)), newdata = data.frame(x = sort(x))))
plot(x, y); lines(dat$x, dat$ypred, col = "red")
# correctly specified
plot(log(x), y); abline(lm(y ~ log(x)), col = "red")

# RESET test
resettest(lm(y ~ x))
resettest(lm(y ~ log(x)))


## Created on Thursday, March 10, 2010 at 10:10pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2020, SomeWeekendReading.  All rights reserved.  As if you care.

##
## Pretty pictures of fractal "boundary" of convergence in Newton's method for solving a cubic
## in the complex plane.  See Strogatz's NYT column:
## http://opinionator.blogs.nytimes.com/2010/03/07/finding-your-roots/
##
## "boundary" in quotes: wherever you think 2 colors have a boundary, the 3rd interposes!
##

doit <- function(xlim = c(-1, +1), ylim = c(-1, +1), npix = 500, doExact = FALSE, ask = TRUE) {
  ## Cyclotomic cubic z^3 - 1 has 3 roots in complex z plane, to which we assign colors.
  ## Other points are colored by the speed with which Newton's algorithm converges to a root.
  ## Plot a subset of the complex plane as described by xlim & ylim, npix per side.

  roots       <- (function(angle) { complex(mod = 1, arg = angle) })(c(0, 2*pi/3, 4*pi/3))
  nearestRoot <- function(x, y) { which.min(abs(complex(real = x, imag = y) - roots)) }
  findRoot    <- function(z, nIter = 0, eps = 1.0e-3) {# Which root by Newton & num iterations
    if (Re(z) == 0 && Im(z) == 0)                      # If at origin, then step away
      z <- complex(real = Re(z) + jitter(Re(z)), imag = Im(z) + jitter(Im(z)))
    flags <- abs(z - roots) < eps                      # Diffs from roots: only 1 can converge
    if (any(flags))                                    # If any root has converged (uniquely!)
      c("rootNum" = which(flags), "nIter" = nIter)     #  then return root # and # iterations
    else                                               # Else unconverged so far
      ## Newton's method in general for finding roots of f(z) = 0:
      ##   z[i+1] = z[i] - f(z[i]) / f'(z[i])
      ## Here, f(z) = z^3 - 1, hence f'(z) = 3 z^2, so:
      ##   z[i+1] = z[i] - (z[i]^3 - 1) / (3 z[i]^2) = 2/3 z[i] + 1/(3 z[i]^2)
      findRoot(2/3 * z + 1 / (3 * z^2), nIter + 1)     # Take Newton step, bump iteration
  }                                                    #  count, and try again

  plotRootFractal <- function(df, col, wrd) {          # Plot expected/actual fractals
    oldParList <- NULL                                 # Capture graphics param changes
    tryCatch({                                         # Guarantee restoring graphics params
      oldParList <- par("mgp" = c(1.5, 0.5, 0),        # Spacing of axis title, labels, & line
                        "mar" = c(2.5, 2.5, 2.5, 1.0), # Margins: (bottom, left, top, right))
                        "ps"  = 10,                    # Point size type in labels
                        "las" = 1,                     # Always horizontal labels
                        "ask" = ask,                   # Ask before replotting
                        "pty" = "m")                   # Maximal plotting area
      image(x = sort(unique(df$"x")),                  # Color by which root a point converges
            y = sort(unique(df$"y")),                  #   to, and how fast
            z = t(matrix(df[, col], nrow = npix, ncol = npix, byrow = TRUE)),
            xlim = xlim, ylim = ylim, xlab = "Re(z)", ylab = "Im(z)",
            main = sprintf("%s Convergence of Newton's Algorithm on Cube Roots of Unity", wrd),
            col = c(rgb(red = 0:255, green = 0,     blue = 0,     maxColorValue = 255),
                    rgb(red = 0,     green = 0:255, blue = 0,     maxColorValue = 255),
                    rgb(red = 0,     green = 0,     blue = 0:255, maxColorValue = 255)))
      box(which = "plot")                              # Put it in a box with a ribbon on it
    }, finally = par(oldParList))                      # Restore graphics parameters
  }                                                    #

  ## (1) Start with skeleton of (x, y) pairs in the complex plane
  ## (2) Add on which root it converged to, and in how many iterations
  ## (3) Encode color in a funny way by root number and number of iterations
  df   <- expand.grid(x = seq(from = xlim[[1]], to = xlim[[2]], length.out = npix),
                      y = seq(from = ylim[[1]], to = ylim[[2]], length.out = npix))
  df   <- cbind(df,                                    # Adjoin onto skeleton 2 new columns:
                t(apply(df, 1, function(dfr) { findRoot(complex(real = dfr[[1]],
                                                                imag = dfr[[2]])) })))
  maxN <- max(df$"nIter")                              # Scale color by max # of iterations
  df   <- transform(df, color = rootNum - nIter/maxN)  # Clunky color encoding
  plotRootFractal(df, "color", "Actual")               # Plot the observed fractal

  if (doExact) {                                       # If also plot expectations (exact root)
    df <- transform(transform(df, exactRootNum = Vectorize(nearestRoot)(x, y)),
                    exactRootDist = abs(complex(real = x, imag = y) - roots[exactRootNum]))
    maxDist = max(df$"exactRootDist")                  # Color by distance from nearest root
    df <- transform(df, exactColor = exactRootNum - exactRootDist / maxDist)
    plotRootFractal(df, "exactColor", "Expected")      # Plot the expected "fractal"
  }                                                    #

  invisible(df)                                        # Return large dataframe, but invisibly
}                                                      #

##
## Usage
##

## > system.time(foo <- doit(npix = 10), gcFirst = TRUE)
##    user  system elapsed
##    0.05    0.01    0.07
## > system.time(foo <- doit(npix = 20), gcFirst = TRUE)
##    user  system elapsed
##    0.16    0.01    0.16
## > system.time(foo <- doit(npix = 50), gcFirst = TRUE)
##    user  system elapsed
##    0.50    0.05    0.58
## > system.time(foo <- doit(npix = 100), gcFirst = TRUE)
##    user  system elapsed
##    1.80    0.17    2.12
## > system.time(foo <- doit(npix = 200), gcFirst = TRUE)
##    user  system elapsed
##    7.49    0.76    8.69
## > system.time(foo <- doit(npix = 500), gcFirst = TRUE)
##    user  system elapsed
##   51.97    4.35   57.99
## > system.time(foo <- doit(npix = 1000), gcFirst = TRUE)
##    user  system elapsed
##  225.70   19.19  255.33

## > png(filename = "root-fractal-2000.png", width = 2200, height = 2200, bg = "transparent"); doit(npix = 2000, ask = FALSE); dev.off()

## Test our hypothesis that time required scales quadratically with npix:
##
## > data <- data.frame(n = c(10, 20, 50, 100, 200, 500, 1000), t = c(0.07, 0.16, 0.58, 2.12, 8.69, 57.99, 255.33))
##
## > model <- lm(t ~ 1 + n + I(n^2), data = data); summary(model); transform(data.frame(data, tPred = predict(model, newdata = subset(data, select = "n"))), pctDiff = 100 * (t - tPred) / t)
##
## Coefficients:
##               Estimate Std. Error t value Pr(>|t|)
## (Intercept)  9.410e-01  5.374e-01   1.751  0.15483
## n           -2.233e-02  4.068e-03  -5.490  0.00536 **
## I(n^2)       2.765e-04  4.009e-06  68.984 2.65e-07 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.9065 on 4 degrees of freedom
## Multiple R-squared: 0.9999,  Adjusted R-squared: 0.9999
## F-statistic: 3.258e+04 on 2 and 4 DF,  p-value: 3.767e-09
##
##      n      t       tPred       pctDiff
## 1   10   0.07   0.7453594 -964.79907826
## 2   20   0.16   0.6050261 -278.14134139
## 3   50   0.58   0.5158754   11.05597205
## 4  100   2.12   1.4734535   30.49747513
## 5  200   8.69   7.5367204   13.27134203
## 6  500  57.99  58.9114051   -1.58890341
## 7 1000 255.33 255.1521601    0.06965098
##
## Model p-value from F-statistic is 2 orders of magnitude better if we drop the constant term:
##
## > model2 <- lm(t ~ 0 + n + I(n^2), data = data); summary(model2); transform(data.frame(data, tPred = predict(model2, newdata = subset(data, select = "n"))), pctDiff = 100 * (t - tPred) / t)
##
## Coefficients:
##          Estimate Std. Error t value Pr(>|t|)
## n      -1.743e-02  3.508e-03  -4.968  0.00422 **
## I(n^2)  2.725e-04  3.882e-06  70.185 1.11e-08 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 1.078 on 5 degrees of freedom
## Multiple R-squared: 0.9999,  Adjusted R-squared: 0.9999
## F-statistic: 2.955e+04 on 2 and 5 DF,  p-value: 6.582e-11
##
##      n      t       tPred     pctDiff
## 1   10   0.07  -0.1470371 310.0530241
## 2   20   0.16  -0.2395803 249.7376874
## 3   50   0.58  -0.1902462 132.8010768
## 4  100   2.12   0.9818559  53.6860445
## 5  200   8.69   7.4131051  14.6938423
## 6  500  57.99  59.4032132  -2.4369946
## 7 1000 255.33 255.0412611   0.1130846
##


euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

# The oneNN function categorizes points based on the 1 nearest neighbour method.
# Returns: a vector of class names for corresponding points.
# Params:
#   dataset -- a data frame, must have exactly 2 columns.
#   points -- a list of points to categorize. Each point is a vector of length 2.
#   dist -- optional. A metric function to use in the 1-NN method. Defaults to the Euclidean distance.
oneNN <- function(dataset, points, dist = euclidean) {
  answer <- data.frame()

  for (i in 1:length(points[1,])) {
    currAns <- dataset[1,]

    for (j in 1:dim(dataset)[1]) {
      if (dist(currAns[3:4], points[,i]) > dist(dataset[j, 3:4], points[,i])) {
        currAns <- dataset[j,]
      }
    }
    answer <- rbind(answer, data.frame(currAns))
  }

  return (answer)
}

colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green")
plot(iris[, 3:4], bg = colors[iris$Species], pch=23)

z <- array(c(runif(5, 1, 7), runif(5, 0, 2.5)), dim = c(2, 5))

print(z[1,])
print(z[2,])

result <- oneNN(iris, z)
points(z[1,], z[2,], bg = colors[result$Species], pch = 22)


### Author: Sergio García Prado
### Title: 2017 Final Exam

rm(list = ls())

### Exercise 1

P <- matrix(c(
  0.0, 1/2, 0.0, 1/2, 0.0, 0.0, 0.0, 0.0, 0.0,
  1/3, 0.0, 1/3, 0.0, 1/3, 0.0, 0.0, 0.0, 0.0,
  0.0, 1/2, 0.0, 0.0, 0.0, 1/2, 0.0, 0.0, 0.0,
  1/2, 0.0, 0.0, 0.0, 0.0, 0.0, 1/2, 0.0, 0.0,
  0.0, 1/3, 0.0, 0.0, 0.0, 1/3, 0.0, 1/3, 0.0,
  0.0, 0.0, 1/2, 0.0, 1/2, 0.0, 0.0, 0.0, 0.0,
  0.0, 0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0,
  0.0, 0.0, 0.0, 0.0, 1/2, 0.0, 0.0, 0.0, 1/2,
  0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.0
),9, 9, byrow = TRUE)

R <- P[1:8, 1:8]

g <- solve(diag(nrow(R)) - R) %*% rep(1, nrow(R))

(doors <- g[1])
# 44.5

(visits.A <- solve(diag(nrow(R)) - R)[1, 1] - 1)
# 6.5

### Exercise 2

(l.coche <- (5 / 60) ^ (-1))
# 12

(l.moto <- (10 / 60) ^ (-1))
# 6

(l.bus <- (30 / 60) ^ (-1))
# 2

### a) 2 cars and 1 motorcycle in 20 minutes.
dpois(2, lambda = l.coche / 3) * dpois(1, lambda = l.moto / 3)
# 0.0396600348266617

### b) Non-change return in 10 minutes.
dpois(0, lambda = 1 / 4 * (l.coche + l.moto + l.bus) / 6)
# 0.434598208507078

### c) 0 motorcycles from 20 vehicles.
dbinom(0, size = 20, prob = l.moto / (l.coche + l.moto + l.bus))
# 0.000797922662976119

### d) 7th car before 2th motorcycle.
pbinom(7 - 1, size = 7 + 2 - 1, prob = l.coche / (l.coche + l.moto),
       lower.tail = FALSE)
# 0.195092211553117

### Exercise 3

lambda <- 9
# 9

(mu <- 1 /(5 /60))
# 12

### a)
##
## L ~ Geometric((mu - lambda) / mu) = Geometric(1/4)

## E[L]
lambda / (mu - lambda)
# 3

### b)

## Waiting Total.
(1 / (mu - lambda))
# 0.3333333

## Waiting in queue.
(lambda / mu * (1 / (mu - lambda)))
# 0.25

### c)

## Busy period length.
(1 / (mu - lambda))
# 0.333333333333333

### d)

R <- matrix(c(
  -lambda, lambda,
  mu, -(mu + lambda)
), 2, 2, byrow = TRUE)

(g <- - solve(R) %*% rep(1, 2))
# 0.3703704
# 0.2592593

g[1]
# 0.37037037037037


#### 13-1 기초 통계
## 대표값과 산포(변동성)
x <- runif(50, 1, 100)
x
hist(x)
y <- c(x, 1000)
y

mean(x)
mean(y)
median(x)
median(y)
sd(x)
sd(y)
range(x)
range(y)
IQR(x)
IQR(y)

boxplot(x)
boxplot(y)

install.packages('fBasics')
library(fBasics)
require(fBasics)
skewness(x)
skewness(y)
# - 추가학습: skewness와 boxcox 변환

## 2.0 다양한 분포함수
# binorm : 이항분포
# f: f분포
# geom: 기하분포
# hyper: 초기하분포
# nbinorm: 음이항분포
# pois: 프와송 분포
# t: t분포
# unif: 균등분포
# chisq 카이제곱분포
set.seed(123)

## 분포함수 : norm에 대해
# dnorm(x, mean = 0, sd = 1, log = FALSE): density
# pnorm(q, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE): probablilty 누적확률
## - lower.tail = T: return P(x<q)    |   lower.tail = F: return P(x>q)
## - log.p = F: return Prob           |   log.p = T: return log(Prob)
# qnorm(p, mean = 0, sd = 1, lower.tail = TRUE, log.p = FALSE): quantile
      #누적확률이 p가 될때의 X값
qnorm(pnorm(6)) #이렇게 하면 6(x값)이 나온다
# rnorm(n, mean = 0, sd = 1): random generation n samples =randn

# 평균이 0이고 표준편차가 10인 정규분포에서 100개의 난수 생성.
x <- rnorm(100, 0, 1)
hist(x, breaks=10)

plot(density(rnorm(1000000, 9, 10)))

# 평균이 0이고 표준편차가 1인 정규분포로부터:
pnorm(1)
pnorm(1, lower.tail = F)
pnorm(1, log.p = T)
exp(pnorm(1, log.p = T))

pnorm(1) - pnorm(-1)
pnorm(1.67) - pnorm(-1.67)
pnorm(1.96) - pnorm(-1.96)

pnorm(2)
pnorm(2) - pnorm(-2)

pnorm(3) - pnorm(-3)
pnorm(6) - pnorm(-6)

##- 소수점 k 자리까지의 정밀도를 1  ~ 22까지 표현가능하다. 기본값은 7.
specify_decimal <- function(x, k) trimws(format(round(x, k), nsmall=k))
specify_decimal(pnorm(6) - pnorm(-6), 10)

# density로 부터 두 값에 대한 분포확률(우도) 예측하기.
dnorm(1.1, 1.15, 1)*dnorm(1.2, 1.15, 1)
dnorm(1.1, 0.9, 1)*dnorm(1.2, 0.9, 1)

# 누적 확률이 0.9가 되는 x값을 찾아라.
q = qnorm(.9, 9, 10)
pnorm(q, 9, 10)
z = (qnorm(.9, 9, 10) - 9)/10
z
qnorm(.9, 0, 1)

(cps <- 1:9 / 10)
qs = qnorm(cps, 9, 10)
zs = (qs - 9)/10
pnorm(zs, 0, 1)

# N(9, 10) 분포에서 신뢰구간이 0.9가 되는 x를 찾아라.
tmp <- qnorm(0.05, 9, 10)
pnorm(9+9-tmp, 9, 10)
q = 18-tmp
z = (q-9)/10
pnorm(z, 0, 1)

## 프와송 분포: f(n, lambda)의 이해
# - 단위시간(단위공간)당 사건 발생 건수가 lambda일 때,
# - 단위시간 내, n번의 사건이 발생할 확률
dpois(1, 1.5) + ppois(0, 1.5)
ppois(1, 1.5)
ppois(3, 1.5)
qpois(0.9, 1.5)

dpois(3, 3)
dpois(3, 1)

# 단위시간당 1건 발생확률에서 0 ~ 5건까지 발생확률에 대한 누적합
sum = 0
for (i in 0:5){
  sum = sum + dpois(i, 1)
}
sum

# - 누적분포함수로 구하면:
ppois(5, 1)

## 이항분포
# - tv리모콘 문제: 채널 50에서 6번 눌렀을 때 채널 50.
# - 6C3 (1/2)^6
6*5*4/(3*2)*(0.5^6)
dbinom(3, 6, 0.5)  #6C3 (1/2)^6

#채널 50 이하일 경우
sum= 0
for (i in 0:3){
  sum = sum +dbinom(i,6,0.5)
}
sum
pbinom(3,6,0.5) #for문 돌린것과 동일하다

## 2.1 기초통계량
mean(1:10)
sd(1:10)
var(1:10)
# - 분산의 정의로부터: Var(x) = 1/(N-1) * sum[(x - mean(x))^2]
sum( (1:10 - mean(1:10))^2 ) / (10-1)

## 2.2 summay
# - 알고 보면 쉽게:
x <- 1:10
summary(x)
# - 알고 보면 쉽지 않다:
str(boxplot(x))
boxplot(x)$stats # data로부터

# - 왜 다를까?
c(min(x), quantile(x, 1/4), median(x), quantile(x, 3/4), max(x))

IQR(x)
quantile(x, c(1/4, 3/4))
qt <- quantile(x, c(1/4, 3/4), names = F)
qt[2] - qt[1]

## 2.3 명목형 변수에 대한 최빈값(mode)
x <- factor(c("a", "b", "c", "c", "c", "d", "d"))
x
str(x)
table(x) # named vector
str(table(x))
which.max(table(x))
str(which.max(table(x))) # named vector: https://rpubs.com/sowmya21jan/338762

names(table(x))[which.max(table(x))]

summary(x)
str(summary(x))

#### 13-2 t- 검정: 평균의 차 검정 ####

## -------------------------------------------------------------------- ##
mpg <- as.data.frame(ggplot2::mpg)

library(dplyr)
mpg_diff <- mpg %>%
  select(class, cty) %>%
  filter(class %in% c("compact", "suv"))

head(mpg_diff)
table(mpg_diff$class)

t.test(data = mpg_diff, cty ~ class, var.equal = T)

test <- aov(cty ~ class, data = mpg)
summary(test)

## -------------------------------------------------------------------- ##
mpg_diff2 <- mpg %>%
  select(fl, cty) %>%
  filter(fl %in% c("r", "p"))  # r:regular, p:premium

table(mpg_diff2$fl)

t.test(data = mpg_diff2, cty ~ fl, var.equal = T)

#### 13-3 ####

## -------------------------------------------------------------------- ##
economics <- as.data.frame(ggplot2::economics)
cor.test(economics$unemploy, economics$pce)

## -------------------------------------------------------------------- ##
head(mtcars)
car_cor <- cor(mtcars)  # 상관행렬 생성
round(car_cor, 2)       # 소수점 셋째 자리에서 반올림해서 출력

install.packages("corrplot")
library(corrplot)

corrplot(car_cor)

corrplot(car_cor, method = "number")

col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))

corrplot(car_cor,
         method = "color",       # 색깔로 표현
         col = col(200),         # 색상 200개 선정
         type = "lower",         # 왼쪽 아래 행렬만 표시
         order = "hclust",       # 유사한 상관계수끼리 군집화
         addCoef.col = "black",  # 상관계수 색깔
         tl.col = "black",       # 변수명 색깔
         tl.srt = 45,            # 변수명 45도 기울임
         diag = F)               # 대각 행렬 제외


sample_size=6
sw2=0.0153
y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500
t=5
alpha=0.05
F_value=qf(1-alpha,t-1,25)

a=c(4,-1,-1,-1,-1)# for control vs agents
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(4*y1bar-y2bar-y3bar-y4bar-y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}

a=c(0,1,1,-1,-1)# Biological vs. chemical
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(0*y1bar+y2bar+y3bar-y4bar-y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}

a=c(0,1,-1,0,0)# Bio1 vs. Bio2
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(0*y1bar+y2bar-y3bar+0*y4bar+0*y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}

a=c(0,0,0,1,-1)# Chm1 vs. Chm2
# test statistic
vl=sw2*((a[1]^2+a[2]^2+a[3]^2+a[4]^2+a[5]^2)/sample_size)
print(vl)
S=sqrt(vl)*sqrt((t-1)*F_value)
print(S)
# critcal value
l=abs(0*y1bar+0*y2bar+0*y3bar+y4bar-y5bar)
print(l)
if(S<l){
  print("  contrasts are significantly different from zero")

}else{
  print(" contrasts are not significantly different from zero")
}


# Possible growth functions:
# ---------------------------

# L(t) = Linf * f(t-t0)

# where f(t-t0) can be any of the following functions:

growthvb.f<- function(a,param.f,ssnl=0)
{   # this is the standard VB growth curve
    tf<- a<0
    a[tf]<- 0
    k<- param.f[1]
    f<- 1-exp(-k*a)
    return(f)
}

growthvblogk.f<- function(a,param.f,ssnl=0)
{   # this is the VB log k growth curve
    tf<- a<0
    a[tf]<- 0
    k1<-    param.f[1]
    k2<-    param.f[2]
    alpha<- param.f[3]
    beta<-  param.f[4]
    theta<- -(k2-k1)/beta
    d1<- 1+exp(-beta*(a-alpha))
    d2<- 1+exp(beta*alpha)
    g<-  (d1/d2)^theta
    g<-  1-exp(-k2*a)*g
    return(g)
}

growthrich.f <- function(a, param.f,ssnl=0)
{	# this is the Richard's growth curve
	#tf<- a<0
	#a[tf]<- 0
	k <- param.f[1]
	alpha <- param.f[2]
	beta <- param.f[3]
	k <- param.f[1]
	alpha <- param.f[2]
	beta <- param.f[3]
	g <- (1 + beta * exp( - k * (a - alpha)))^(-1/beta) - (1 + beta * exp(k * alpha))^
		(-1/beta)
	return(g)
}

# Seasonal growth models
#--------------------------------------------------------

growthvb.ssnl.f<- function(a,param.f,julian)
{   # this is the VB growth curve with a sinusoidal seasonal component
    # "julian" is in decimal yrs (ie. fraction of yr since Jan 1)

    tf<- a<0
    a[tf]<- 0

    k<- param.f[1]
    u<- param.f[2]
    w<- param.f[3]
    1-exp(-k*(a+u/(2*pi)*sin(2*pi*(julian-w))))
}

growthvblogk.ssnl.f<- function(a,param.f,julian)
{   # this is the VB log k growth curve
    # "julian" is in decimal yrs (ie fraction of yr since Jan 1)

    tf<- a<0
    a[tf]<- 0

    k1<-    param.f[1]
    k2<-    param.f[2]
    alpha<- param.f[3]
    beta<-  param.f[4]
    u<-     param.f[5]
    w<-     param.f[6]

    theta<- -(k2-k1)/beta
    d1<- 1+exp(-beta*(a+u/(2*pi)*sin(2*pi*(julian-w))-alpha))
    d2<- 1+exp(beta*alpha)
    g<-  (d1/d2)^theta
    g<-  1-exp(-k2*(a+u/(2*pi)*sin(2*pi*(julian-w))))*g
    return(g)
}


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 10

rm(list = ls())

observed <- c(40, 32, 15, 7, 6)

(k <- length(observed))
# 5

(n <- sum(observed))
# 100

(expected <- n * c(dgeom(0:(k - 2), prob = 0.5), 1 - pgeom(k - 2, prob = 0.5)))
# 50 25 12.5 6.25 6.25

(Q <- sum((observed - expected)^2 / expected))
# 4.56

(pvalue <- 1- pchisq(Q, df = k - 1))
# 0.335492198026963


#' myncurve
#'
#' @param mu mean value
#' @param sigma standard defiation value
#' @param a upper bound of lower tail problem
#'
#' @return a normal distribution graph with probability place on it
#' @export
#'
#' @examples
#' myncurve(mu=10,sigma=5, a=6)
myncurve = function(mu, sigma, a){
  curve(dnorm(x,mean=mu,sd=sigma), xlim = c(mu-3*sigma, mu + 3*sigma))
  xcurve=seq(mu-3*sigma, a,length=1000)
  ycurve=dnorm(xcurve,mean=mu,sd=sigma)
  polygon(c(mu-3*sigma,xcurve,a),c(0,ycurve,0),col="Red")
  prob=pnorm(a,mean=mu,sd=sigma)
  prob=round(prob,4)
  text(x=(a-(mu-3*sigma))/2, y=max(ycurve)/2, paste("Area = ", prob, sep=""))
}


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Gender analysis: utility  functions
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# adapted from https://github.com/lukeholman/genderGapCode/

pfunc <- function(t, r, c) exp(0.5*r*t) / (2*exp(0.5*r*t) + c)
pfunc.deriv <- function(p, r) r*p*(0.5-p)

# log likelihood of data given the parameters, assuming binomial distribution
# returns the negative log-likelihood to be minimised with optim()
find.ll <-function(data, par) {

    sample <- dbinom(
        x=data$nFemales, size=data$n,
        prob=pfunc(t=data$date, r=par[1], c=par[2]), log=TRUE
    )

    -1 * sum(sample)
}

# Internal function to perform 1D optimisation and find
# the parameters r and c that optimises the log likelihood
# for the focal set of data. Arbitrarily chosen starting values
run.optimiser <- function(data) optim(par = c(0.1, 1), find.ll, data = data)

# Used to find the 95% CIs on a proportion
# (uses default method of the binom.test function).
# Works for a pair of columns nFemales and nMales
get.CIs <- function(nFemales.column, nMales.column){

    CIs <- data.frame(lowerCI = numeric(length(nFemales.column)), upperCI = NA)

    for(i in 1:length(nFemales.column)){

        CIs.foc <- as.numeric(binom.test(
            nFemales.column[i],
            nFemales.column[i] + nMales.column[i]
        )$conf.int)

    CIs$lowerCI[i] <- CIs.foc[1]
    CIs$upperCI[i] <- CIs.foc[2]

    }

    return(100 * CIs)

}

Mode <- function(x) {
    ux <- unique(x)
    ux[which.max(tabulate(match(x, ux)))]
}
##############################

find.response.variables <- function(data) {

    # This function runs the optimiser on a focal bit of resampled data,
    # and gets the current gender ratio, rate of change, and
    # the year at which the ratio got within
    # 5% of gender parity using the pfunc model with optimised parameters

    optim.results <- run.optimiser(data)
    r <- optim.results$par[1]
    c <- optim.results$par[2]

    # Compute the predicted gender ratio at the "present",
    # i.e. the first year with data
    gender.ratio.at.present <- pfunc(max(data$date), r, c)

    # Compute the rate of change in the gender ratio at the "present"
    current.rate.of.change <- pfunc.deriv(p = gender.ratio.at.present, r = r)

    # Compute parity year
    year.range <- 0:9999
    predicted.gender.ratio <- pfunc(year.range, r, c)

    # check if female ratio increasing
    is_female_ratio_increasing <- ifelse(
        predicted.gender.ratio[2] > predicted.gender.ratio[1], TRUE, FALSE
    )

    if(is_female_ratio_increasing) { # becoming more female biased

    parity.year <- ifelse(
        gender.ratio.at.present < 0.5,
        # record first year it got within 5% of parity
        year.range[which(predicted.gender.ratio > 0.45)][1],
        "Female-biased and becoming more so"
    )

    } else { # becoming more male biased

    parity.year <- ifelse(
        gender.ratio.at.present > 0.5,
        # record first year it got within 5% of parity
        year.range[which(predicted.gender.ratio < 0.55)][1],
        "Male-biased and becoming more so"
    )

    }

    return(data.frame(
        gender.ratio.at.present = gender.ratio.at.present,
        current.rate.of.change = current.rate.of.change,
        parity.year = parity.year, r = r, c = c,
        stringsAsFactors = F)
    )
}


#' @title rmse
#'
#' @description Calculates the root mean square error (RMSE) from observed and
#' predicted values.
#'
#' @inheritParams e
#'
#' @return The root mean square err or (RMSE) calculated from the observed and
#' the predicted values.
#'
#' @details rmse = sqrt(mean((observed - predicted)^2))
#'
#' @examples
#' o<-1:5
#' p<-c(2,2,4,3,5)
#' rmse(observed=o, predicted=p)
#'
#' @export
rmse<-function(observed, predicted) return(sqrt(mean((observed - predicted)^2)))


#!/usr/bin/R -q -f
#
# R script to calculate pearson distance
#
# Objective: To calculate the pearson distance for a mock-up dataset
#
# Input : a mock-up 6-row, 2-column data frame
#
# Output: STDOUT, a single value for the pearson distance
#

# load dplyr package
library(dplyr)

# load the mockup data into a 2 column, 6 row data frame
data <- data_frame(c(3,4,7,6,8,2),c(5,3,10,8,12,5))

# assign the column names so the data is more readable
colnames(data) <- c('x', 'y')

# check the data
data

# add STDEV, MEAN, and COUNT into the dataset
mutate(data, xmean = mean(x), sdx = sd(x), ymean = mean(y), sdy = sd(y), n1 = nrow(data)-1) %>%
# add the intermediate value into the dataset
mutate(xx = ((x-xmean)/(n1*sdx))*((y-ymean)/(sdy))) %>%
# only select the intermediate value column
select(xx) %>%
# sum it to get the pearson distance
sum()


#############################################
# Data Preparation
#############################################
# Set the random number generator or seed
# to make the results reproducible
set.seed(314159)

# set the number of items I and persons P
I.items <- 30
P.persons <- 2000

# set the fixed item and population parameters
a.disc <- 1 + runif(I.items, -0.5, 0.5)
b.diff <- seq(-3,3,length = I.items )

mean.theta <- 0
sig2.theta <- (1.25^2)

# generate thetas and the I x P matrix of response probabilities
theta.abl <- rnorm(P.persons, mean = mean.theta, sd = sqrt(sig2.theta))
term.1 <- outer(theta.abl,a.disc)
term.2 <- matrix(rep(a.disc*b.diff, P.persons), nrow = P.persons, byrow = TRUE)
P.prob <- plogis(term.1 - term.2) ### 1/(1+exp(term.2-term.1))

# generate the 0/1 responses U as a matrix of Bernoulli draws
U <- ifelse(runif(I.items * P.persons) < P.prob, 1, 0)


#the code for calculating EM must first be run for initializing the means!

#use of stats library
# mixtools library
library("mixtools")
library("stats")
library("mvtnorm")

#EM algorithm

pdf('standardized_em.pdf')

#--------------(1)-------Initialize the means μk , covariances Σk and mixing coefficients πk--------

	#in the following comment there are the means in case the k-means algorithm is not run.

	k=3;
	#construct the covariance matrices
	#add each covariance matrix to a node in the list S

	a = matrix(nrow=3,ncol=2)
	S = rep(list(a),3)
	for(t in 1:k){
		a= which(rnk_matrix==t)
		tr1=matrix(nrow=length(a),ncol=2)
		counter1=1;
		for (i in a){
			tr1[counter1,1]=dataset[i,1]
			tr1[counter1,2]=dataset[i,2]
			counter1= counter1+1
		}
		S[[t]]=cov(tr1)
	}

	N=length(dataset[,1])
	#array pk -> mixing coefficients

	pk = matrix(nrow=3,ncol=1)
	for(t in 1:k){
		pk[t,] = length(which(rnk_matrix==t))/N
	}

par(mfrow=c(2,2))

plot(dataset[,1],dataset[,2],col="green",xlim=c(-3.2,3.2),ylim=c(-3.2,3.2),panel.first = grid(),xlab="x",ylab="y",pch=20,main="Initialized data from kmeans")
color_=rgb(0,0,0,alpha=0.6)
points(mean_Ar[,1],mean_Ar[,2],col=color_,pch=4)
ellipse(mean_Ar[1,], S[[1]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[2,], S[[2]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[3,], S[[3]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)

#-----evaluate the initial value of the log likelihood-------

likelihood=0;

Nk =matrix(nrow=k,ncol=1)
for(t in 1:k){
	Nk[t,1] =  length(which(rnk_matrix==t));
}

#evaluate the likelihood using the formula
likelihood=0;
for(i in 1:N){
	sum1=0;
	for(t in 1:k){

	b=S[t];
 	b = matrix(unlist(b),ncol = 2, byrow = TRUE);
sum1=sum1 +pk[t,]*(  ((2*pi)^(-2/2)) )*(  (det(b)) ^(-0.5) )*exp(-0.5*t(as.vector(dataset[i,]-mean_Ar[t,]))%*%(solve(b))%*%(as.vector(dataset[i,]-mean_Ar[t,])));
	}
	likelihood = likelihood +log(sum1);
}

print(likelihood)

#----------------(2)----------------------------E step. Evaluate the responsibilities using the current parameter values-------

flag=0;
#rg is the responsibility gamma
rg=matrix(nrow=N,ncol=k)

lh<-c(likelihood)
if(likelihood>0 ){
new_likelihood =likelihood-10000000;
}else{
new_likelihood =likelihood+10000000000
}

while(abs(new_likelihood-likelihood)>1){
if(flag==0){
flag=1;
new_likelihood =likelihood;
}

likelihood=new_likelihood;

for(i in 1:N){
for(t in 1:k){
		sum1=0;

		for(j in 1:k){

			b=S[[j]];
 			b = matrix(unlist(b),ncol=2, byrow=TRUE);
			a=pk[j,1]*dmvnorm(dataset[i,], mean_Ar[j,],b);
			sum1 = sum1 + a;
		}

		b=S[[t]];
 		b = matrix(unlist(b),ncol = 2, byrow = TRUE);
	 a=pk[t,]*dmvnorm(dataset[i,], mean_Ar[t,],b);
	rg[i,t]=a/sum1;
	}
}

#----------------(3)----------M step. Re-estimate the parameters using the current responsibilities------------------------------------

#find new mean
for(t in 1:k){
	sum1=c(0,0);
	for(i in 1:N){
		sum1= sum1+rg[i,t]*dataset[i,]
	}
	mean_Ar[t,]= sum1/Nk[t,1]
}

#find new Nk
for(j in 1:k){
Nk[j,1]=0;
for(i in 1:N){
	Nk[j,1] =  Nk[j,1] + rg[i,j]
}
}

#find new covariance matrix
for(t in 1:k){
	sum1=matrix(c(0,0,0,0),nrow=2,ncol=2);
	for(i in 1:N){
		sum1= sum1+rg[i,t]*(dataset[i,]- mean_Ar[t,])%*%t(dataset[i,]- mean_Ar[t,])
	}
	S[[t]]= sum1/Nk[t,1]
}

#find new mixture coefficient
for(t in 1:k){
pk[t,]=Nk[t,1]/N;
}

#(4)-------------------------Evaluate the log likelihood--------------

#evaluate the likelihood using the formula
new_likelihood=0;
for(i in 1:N){
sum1=0;
	for(t in 1:k){

	b=S[t];
 	b = matrix(unlist(b),ncol = 2, byrow = TRUE);
sum1=sum1 +pk[t,]*(  (  (2*pi)^(-2/2)))* (  (det(b)) ^(-0.5) )*exp(-0.5*t(as.vector(dataset[i,]-mean_Ar[t,]))%*%(solve(b))%*%(as.vector(dataset[i,]-mean_Ar[t,])));
	}
	new_likelihood = new_likelihood +log(sum1);
}

print(new_likelihood)
lh= c(lh,new_likelihood)

#-----------------plots--------------------------------------------

#---------------------plot classes-----------------------------

plot(0,0,col="white",xlim=c(-3.2,3.2),ylim=c(-3.2,3.2),pch=20,panel.first = grid(),xlab="x",ylab="y",main=toString(likelihood))
for (i in 1:N){

color_=rgb(0.9,0,0,alpha=rg[i,1])
points(dataset[i,1],dataset[i,2],col=color_,pch=20)

color_=rgb(0,0.9,0,alpha=rg[i,2])
points(dataset[i,1],dataset[i,2],col=color_,pch=20)

color_=rgb(0,0,0.9,alpha=rg[i,3])
points(dataset[i,1],dataset[i,2],col=color_,pch=20)

}
color_=rgb(0,0,0,alpha=0.4)
points(mean_Ar[,1],mean_Ar[,2],col=color_,pch=4)

ellipse(mean_Ar[1,], S[[1]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[2,], S[[2]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
ellipse(mean_Ar[3,], S[[3]], alpha = 0.32, npoints = 250,col=color_, newplot = FALSE, draw = TRUE)
}

#plot one-standard deviation
#---------------end of while------if there is convergence in likelihood stop

dev.off()

print(mean_Ar)
print(S)
print(pk)


source("data_Poisson.r")

library(npowerPrioR)

po.data <- list(
  N0 = N_0,
  y0 = y_0,
  alpha0 = alpha_0,
  beta0 = beta_0,
  a_0 = NA
)
###
get_l_a0_poisson <- function(y0, n0, alpha0, beta0, a_0){
  logPprime <- sum(lfactorial(y0))
  S <- sum(y0)
  ans <- -a_0 * logPprime + lgamma(a_0 * S + alpha0) - (a_0 * S + alpha0)* log(a_0 *n0 + beta0) + (alpha0*log(beta0) - lgamma(alpha0))
  return(ans)
}
############
l_a0 <- function(x) {
  get_l_a0_poisson(
    y0 = po.data$y0,
    n0 = po.data$N0,
    alpha0 = po.data$alpha0,
    beta0 = po.data$beta0,
    a_0 = x
  )
}
l_a0 <- Vectorize(l_a0)
###
l_a0_p <- function(x) numDeriv::grad(l_a0, x)
l_a0_p <- Vectorize(l_a0_p)
l_a0_pp <- function(x) numDeriv::hessian(l_a0, x)
l_a0_pp <- Vectorize(l_a0_pp)

analytical_l_p <- function(x){
  logPprime <- sum(lfactorial(y_0))
  S <- sum(y_0)
  tt <- alpha_0 + S*x
  gg <- beta_0 + N_0 * x
  result <- -logPprime -N_0 *tt/gg - S*log(gg) + S * digamma(tt)
  return(result)
}
####################
J <- 20
maxA <- 1

adaptive.ca0.estimates <- read.csv(paste("../../data/constant_data/Poisson_logCA0_adaptive_J=", J, ".csv", sep = ""))

curve(l_a0_p, 0, maxA, lwd = 2, lty = 2, col = 2,  ylab = "", xlab = expression(a[0]), ylim = c(-200, 200))
abline(h = 0 , lwd = 2 , lty = 3)
curve(l_a0, 0, maxA, lwd = 2, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$lc_a0)
curve(l_a0_pp, 0, maxA, lwd = 2, col = 3, add = TRUE)
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$second_deriv_lc, col = 3)
legend(x = "bottomright", legend = c("l(a_0)", "l'(a_0)", "l''(a_0)"), col = 1:3, lwd = 2, bty = 'n')
points(adaptive.ca0.estimates$a0, adaptive.ca0.estimates$deriv_lc, col = 2)

######################################
midpoint_integrate_la0 <- function(x_preds, fit){
  ## takes a grid of values for the input and a fit object that gives predictions (GLM, GAM, etc) and
  ## Gives the integrated function
  n <- length(x_preds)
  delta <- (x_preds[2]-x_preds[1])
  midpoints <- 0.5*(x_preds[2:n] + x_preds[1:(n-1)])
  ans <-  cumsum(predict(fit, newdata = data.frame(a0 = midpoints))) * delta
  ans <- c(0, ans)
  return(ans)
}

fit.gam <- mgcv::gam(lc_a0 ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)
deriv.gam.fit <- mgcv::gam(deriv_lc ~ s(a0, k = J + 1), data = adaptive.ca0.estimates)

K <- 20000
pred_a0s <- seq(0, maxA, length.out = K)

preds.gam  <- get_band(fit.gam, xpred = pred_a0s)
deriv.preds <- midpoint_integrate_la0(pred_a0s, deriv.gam.fit)

true.lca0s <- l_a0(pred_a0s)

gam.preds.list <- list(
  gam = data.frame (a0 = pred_a0s, lca0 = preds.gam$mean, dev = preds.gam$mean - true.lca0s, lwr = preds.gam$lwr,
                     upr = preds.gam$upr, approximating_function = "gam", design = "adaptive"),
  derivative = data.frame (a0 = pred_a0s, lca0 = deriv.preds, dev = deriv.preds - true.lca0s, lwr = NA, upr = NA,
                           approximating_function = "gam-derivative", design = "adaptive_numerical")
)

## RMSE
lapply(gam.preds.list, function(pred) sqrt(mean( (pred$lca0 - true.lca0s)^2 )) )
## MAD
lapply(gam.preds.list, function(pred) mean( abs(pred$lca0 - true.lca0s) ))

## RMSE, a0 < 1
lapply(gam.preds.list, function(pred) sqrt(mean( (pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1])^2 )) )
## MAD, a0 < 1
lapply(gam.preds.list, function(pred) mean( abs(pred[pred$a0 < 1, ]$lca0 - true.lca0s[pred_a0s < 1]) ))

### Exporting

forplot_ca0 <- do.call(rbind, gam.preds.list)

write.csv(forplot_ca0, file = paste("../../data/constant_data/fitted_predictions_lca0_Poisson_J=", J, ".csv", sep = ""),
          row.names = FALSE)

library(ggplot2)

dev_plot <- ggplot(data = forplot_ca0, aes(x = a0, y = dev, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  scale_x_continuous(expression(a[0])) +
  theme_bw(base_size = 16)
dev_plot

p0 <- ggplot(data = forplot_ca0, aes(x = a0, y = lca0, colour = approximating_function, fill = approximating_function)) +
  geom_line() +
  geom_ribbon(aes(min = lwr, max = upr), alpha = .4) +
  geom_point(data = adaptive.ca0.estimates,
             mapping = aes(x = a0, y = lc_a0), colour = "black", alpha = .4, size = 5, inherit.aes = FALSE) +
  stat_function(fun = l_a0, linetype = "dashed", size = 1.2, colour = "black") +
  scale_x_continuous(expression(a[0])) +
  scale_y_continuous(expression(log(c(a[0])))) +
  theme_bw(base_size = 20) +
  theme(legend.position = "bottom",
        legend.justification = "centre",
        legend.title = element_blank(),
        strip.background = element_blank(),
        strip.text.y = element_blank(),
        legend.margin = margin(0, 0, 0, 0),
        legend.box.margin = margin(0, 0, 0, 0))
p0

ggsave(p0, filename = paste("../../figures/estimates_log_ca0_Poisson_J=", J, ".pdf", sep = ""), dpi = 300)


library(tidyverse)
library(R0)
library(scales)
library(incidence)
library(EpiDynamics)

# https://cran.r-project.org/web/packages/earlyR/earlyR.pdf
## example: onsets on days 1, 5, 6 and 12; estimation on day 24

# https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7014672/
weibull_mean = 6.4
weibull_sd = 2.3

e = exp(1)
r0=3.765201
incubation_period = 5
infection_rate = r0/incubation_period
t = 0:65
n0=1
e = exp(1)
n_t = n0*e^(infection_rate*t)
par(mfrow = c(1,1))
plot(t, n_t)

n_t2 = 0.007900 * r0^(t/incubation_period)
plot(n_t2, n_t)

##### pull in data ####
johns_hopkins_cases = read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv') %>%
  pivot_longer(cols = matches('^([0-9])'), names_to = 'date', values_to = 'cases')

names(johns_hopkins_cases) = names(johns_hopkins_cases) %>% tolower() %>% str_replace('[\\/]', '_')

us_jh_cases = filter(johns_hopkins_cases, country_region == 'US') %>%
  mutate(date = as.Date(date, format = '%m/%d/%y')) %>%
  arrange(date) %>%
  mutate(
    lag_cases = lag(cases, 1),
    new_cases = cases - lag_cases,
    new_cases = ifelse(is.na(new_cases), 1, new_cases),
    t = as.numeric(date - min(date))
  ) %>%
  filter(
    date <= as.Date('2020-03-26')
  )

# fit a simple exponnetial model using non-linear least squares
exponential_model_long_incubation = nls(cases ~  case_networks * r0^(t/6.4), data = us_jh_cases,
                               start = list(case_networks = 1, r0 = 2.5))
summary(exponential_model_long_incubation)

exponential_model_short_incubation = nls(cases ~  case_networks * r0^(t/5), data = us_jh_cases,
                                       start = list(case_networks = 1, r0 = 2.5))
summary(exponential_model_short_incubation)

mGT_weibull <- generation.time("weibull", c(6.4, 2.3))
mGT_gamma <- generation.time("gamma", c(5, 1.5))

par(mfrow = c(2, 1))
plot(mGT_weibull$time, mGT_weibull$GT)
lines(mGT_weibull$time, mGT_weibull$GT)
plot(mGT_gamma$time, mGT_gamma$GT)
lines(mGT_gamma$time, mGT_gamma$GT)

est.R0.EG(us_jh_cases$new_cases, mGT_weibull, begin=as.integer(1), end=as.integer(length(us_jh_cases$new_cases)))
est.R0.EG(us_jh_cases$new_cases, mGT_gamma, begin=as.integer(1), end=as.integer(length(us_jh_cases$new_cases)))

# https://web.stanford.edu/~jhj1/teachingdocs/Jones-Epidemics050308.pdf
# λ(t) = λ(0)e^(Λt)
# Λ = ν(R0 − 1)

# Formula: cases ~ case_networks * r0^(t/6.4)
#
# Parameters:
#   Estimate Std. Error t value Pr(>|t|)
# case_networks  9.14908    2.09934   4.358 4.17e-05 ***
#   r0             2.48856    0.05072  49.063  < 2e-16 ***
#   ---
#   Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
#
# Residual standard error: 8936 on 74 degrees of freedom
#
# Number of iterations to convergence: 9
# Achieved convergence tolerance: 7.431e-06

# Formula: cases ~ case_networks * r0^(t/5)
#
# Parameters:
#   Estimate Std. Error t value Pr(>|t|)
# case_networks 0.004309   0.001168   3.691 0.000474 ***
#   r0            3.729612   0.082046  45.457  < 2e-16 ***
#   ---
#   Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
#
# Residual standard error: 887.8 on 62 degrees of freedom
#
# Number of iterations to convergence: 23
# Achieved convergence tolerance: 4.429e-06

# fit using existing R package, R0

# this is the generation time or incubation period
# https://annals.org/aim/fullarticle/2762808/incubation-period-coronavirus-disease-2019-covid-19-from-publicly-reported

# https://www.ncbi.nlm.nih.gov/pmc/articles/PMC7014672/
# mGT <- generation.time("gamma", c(6.5, 2.6))

# Reproduction number estimate using  Exponential Growth  method.
# R :  3.836266[ 3.799067 , 3.873994 ]

### plot confirmed vs. predicted ###
us_jh_cases$simple_exp_prediction = predict(simple_exponential_model)
us_jh_cases_long = pivot_longer(us_jh_cases, cols = c('simple_exp_prediction', 'cases'))

ggplot(us_jh_cases_long, aes(date, value, colour = name)) +
  geom_line() +
  scale_colour_hue(name = 'Estimate', labels = c('cases' = 'Confirmed Cases', 'simple_exp_prediction' = 'Modeled Cases')) +
  scale_y_continuous(labels = comma) +
  labs(x = 'Date', y = 'Cases', title = 'Exponential Growth Model vs. Confirmed Cases')
ggsave('exp_growth_vs_cases.png', height = 6, width = 6, units = 'in', dpi = 600)

# get shape/scale for weibull distribution
fit_weibull = function(pars) {
  shape = pars[1]
  scale = pars[2]
  the_dist = rweibull(10000, shape, scale)
  the_sd = abs(sd(the_dist) - 2.3)
  the_mean =  abs(mean(the_dist) - 6.4)
  return(
    the_sd * the_mean
  )
}
the_solution = optim(par = c(3, 7), fn = fit_weibull)
#
# > the_solution$par
# [1] 3.005484 7.201339
the_weibull = rweibull(1000, the_solution$par[1], the_solution$par[2])
#
# r0_dist = map_dbl(the_weibull, function(gen_time){
#   return_val = NA
#   tryCatch({
#     simple_exponential_model = nls(cases ~  case_networks * r0^(t/gen_time), data = us_jh_cases,
#                                    start = list(case_networks = 1, r0 = 2.5))
#
#     return_val = coef(simple_exponential_model)[2]
#   }, error = function(e){
#     return(return_val)
#   })
#
#   return(return_val)
# })
summary(r0_dist)

cumulative_dist = tibble(
  time = mGT$time,
  proportion = mGT$GT,
  cum_prop = cumsum(proportion)
)

?SIR

# covid
parameters <- c(beta = 2.5/5, gamma = 1/5)
initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))

covid_sir <- SIR(pars = parameters, init = initials, time = 0:180)

# flu
parameters <- c(beta = 1.3/5, gamma = 1/5)
initials <- c(S = 1 - 1e-06, I = 1e-06, R = 1 - (1 - 1e-06 - 1e-06))

# Solve and plot.
flu_sir <- SIR(pars = parameters, init = initials, time = 0:180)
# PlotMods(sir)

distancing_effect = 0.6

comb_sirs = tibble(
  time = covid_sir$time,
  covid_s = covid_sir$results$S * 15e6,
  new_cases = round(lag(covid_s, 1) - covid_s),
  covid_i = covid_sir$results$I,
  flu_i = flu_sir$results$I
) %>%
  mutate(
    new_cases = ifelse(is.na(new_cases), 0, new_cases),
    deaths = rbinom(length(comb_sirs$new_cases), comb_sirs$new_cases, prob = 0.004)
  )

comb_sirs$deaths
sum(comb_sirs$new_cases, na.rm = T) / 60e6
sum(comb_sirs$deaths, na.rm = T)

filter(comb_sirs, time <= 42) %>% pull(deaths) %>% sum(na.rm=T)

ggplot(comb_sirs, aes(time, deaths)) +
  geom_point()

sum(comb_sirs$covid_i * 19e6)

sum(comb_sirs$flu_deaths)
sum(comb_sirs$covid_deaths)

ggplot(comb_sirs, aes(time)) +
  geom_line(aes(y = covid_i)) +
  geom_line(aes(y = flu_i))
sum(comb_sirs$covid_i)

# http://rstudio-pubs-static.s3.amazonaws.com/6852_c59c5a2e8ea3456abbeb017185de603e.html

# simulate proportion of deaths
# x1 = 1:(30*6)
#
# z = 0.15 + 0.015*x1
# pr = 1/(1+exp(-z))         # pass through an inv-logit function
# y = rbinom(length(x1),1,pr)      # bernoulli response variable
#
# #now feed it to glm:
# df = data.frame(y=y,x1=x1)
# mod = glm( y~x1,data=df,family="binomial")
#
# plot(x1, predict(mod, type = 'response'))
# summary(pr)
#
#


# 4. faza: Analiza podatkov

#############################################################
#REGRESIJSKA PREMICA ZA ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH V NASLEDNJIH LETIH

grup <- group_by(umrli, Leto)
umrli_slo <- summarise(grup, Stevilo=(sum(Umrli, na.rm = TRUE)))
umrli_slo <- transform(umrli_slo, Stevilo = (Stevilo / 12))
umrli_slo$Stevilo <- round(umrli_slo$Stevilo, digits=2)
prileg <- lm(data = umrli_slo, Stevilo ~ Leto )
m <- data_frame(Leto=seq(2018,2022,1))
napoved <- mutate(m, Stevilo=predict(prileg,m))
napoved$Stevilo <- round(napoved$Stevilo, digits = 2)

graf_regresija_umrli <- ggplot(umrli_slo, aes(x=Leto, y=Stevilo)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved, aes(x=Leto, y=Stevilo), color='red', size=2) +
  geom_point() +
  labs(title='Napoved števila smrti v prometu v naslednjih letih', y="Stevilo")

# REGRESIJSKA PREMICA ZA ŠTEVILO OSEBNIH AVTOMOBILOV NA 1000 PREBIVALCEV V PRIHODNOSTI
avti <- group_by(avtomobili,Leto)
avti1 <- summarise(avti, Stevilo=sum(Avtomobili, na.rm=TRUE))
avti_regije <- transform(avti1, Stevilo = Stevilo / 12)
avti_regije$Stevilo <- round(avti_regije$Stevilo, digits=2)
prileg <- lm(data = avti_regije, Stevilo ~ Leto )
napoved_avti <- mutate(m, Stevilo=predict(prileg, m))

graf_regresija_avti <- ggplot(avti_regije, aes(x=Leto, y=Stevilo)) +
  geom_smooth(method=lm, fullrange = TRUE, color = 'blue') +
  geom_point(data=napoved_avti, aes(x=Leto, y=Stevilo), color='red', size=2) +
  geom_point() +
  labs(title='Napoved števila osebnih avtomobilov na 1000 prebivalcev v prometu v naslednjih letih', y="Stevilo")

##################################################################################
# CLUSTER REGIJ ŠTEVILO UMRLIH V CESTNOPROMETNIH NESREČAH

# umrli
grp <- group_by(umrli, Regija)
umrli_sum <- summarise(grp, vsote=sum(Umrli, na.rm = TRUE))

umrli_e <- dcast(umrli, Regija~Leto, value.var = 'Umrli' )
umrli_e <- left_join(umrli_e, umrli_sum, by = 'Regija')
umrli_e <- umrli_e[order(umrli_e$vsote, decreasing = FALSE),]
umrli_b <- umrli_e[,-19]
umrli_b <- umrli_b[,-1]

n <- 5
fit <- hclust(dist(scale(umrli_b)))
skupine4 <- cutree(fit, n)

cluster4 <- mutate(umrli_e, skupine4)
cluster4 <- cluster4[,-2:-19]
colnames(cluster4) <- c("Regija", "Umrli")
# zemljevid

regije <- unique(zemljevid$NAME_1)
regije <- as.data.frame(regije, stringsAsFactors=FALSE)
names(regije) <- "Regija"
skupaj <- left_join(regije, cluster4, by="Regija")

zemljevid_cluster_umrli <- ggplot() + geom_polygon(data=left_join(zemljevid, skupaj, by=c("NAME_1"="Regija")),
                                              aes(x=long, y=lat, group=group,
                                                  fill=factor(Umrli))) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  guides(fill=guide_colorbar(title="Skupine")) +
  ggtitle('Razvrstitev regij v skupine glede na število umrlih v cestnoprometnih nesrečah') +
  labs(x = " ") +
  labs(y = " ") +
  scale_fill_brewer(palette="YlOrRd", na.value = "#e0e0d1")

###################################################################################
# SHINY

graf.regije <- function(regija){
  ggplot(umrli %>% filter(Regija %in% regija)) + aes(x=Leto, y=Umrli, group=Regija, color=Regija) +
    geom_line() + geom_point()+ xlab("Leto") + ylab("Število umrlih") +
    theme(axis.text.x = element_text(angle = 90, vjust = 0.3, hjust=1))
}

graf_avto <- function(cifra) {
  ggplot(avtomobili %>% filter(Leto==cifra), aes(x=Regija, y=Avtomobili, fill=factor(Regija))) +
    ylim(0, 650) + geom_bar(stat = "identity") +
    xlab("Regija") + ylab("Število avtomobilov") +
    theme(axis.text.x = element_text(angle = 90, size = 8)) +
    labs(fill='Regija')

}

#==================================================================================


y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500

alpha=0.05
tstar=qt(1-alpha/2,df=25)
MSError=0.0153
LSD=tstar*sqrt((2*MSError)/6)
print(LSD)

#  the 95% confidence interval for y3bar-y1bar
left_i=(y3bar-y1bar)-LSD
right_i=(y3bar-y1bar)+LSD
print("Confidence interval is")
print(left_i)
print(right_i)


#########################################
# A toy example of Gibbs sampling
# author: Alberto Lumbreras
#########################################
library(mvtnorm)
library(coda)

# Parameters of a multivarite gaussian
mu1 <- 0
mu2 <- 0
cov12 <- 0.5 # same than cov21

# Plot the target distribution
dugly <- function(xy) {
  x <- xy[1]
  y <- xy[2]
  covariance <- matrix(c(1, cov12, cov12, 1), nrow=2)
  mvtnorm::dmvnorm(c(x,y), mean = c(mu1,mu2), sigma=covariance)
}
x <- seq(-3, 3, length.out=100)
y <- seq(-3, 3, length.out=100)
z <- matrix(NA, nrow=100, ncol=100)
i <- 1
for (n in 1:length(x)){
  for(m in 1:length(y)){
    z[n,m] <- dugly(c(x[n],y[m]))
    i <- i+1
  }
}
contour(x,y,z)
title("Gibbs sampling")

# Gibbs sampler
nsamples <-1000
samples <- matrix(NA,nsamples, 2)
samples[1,] <-c(0,0) # init
for(i in 2:nsamples){
  # Sample x1 given last x2
  samples[i,1] <- rnorm(1, mu1 + cov12*(samples[i-1,2]-mu2), sqrt(1-cov12^2)) # easy!
  # Sample x2 given last x1
  samples[i,2] <- rnorm(1, mu2 + cov12*(samples[i,1]-mu1), sqrt(1-cov12^2)) # easy!
}

# Plot samples showing the unidimensional steps at each iteration
steps.x1 <- rep(samples[,1], each=2)
steps.x2 <- rep(samples[,2], each=2)
lines(steps.x1[1:(length(steps.x1)-1)], steps.x2[2:(length(steps.x2))], col="green")
lines(samples, col='yellow')
points(samples, col='red', pch=19, cex=0.5)

# Check the MCMC traces
plot(mcmc(samples))


# Example : 2   Chapter : 6.6     Page No: 356
# Similar matrices  with repeated eigen values
A<-matrix(c(0,0,1,0),ncol=2)
Aev<-eigen(A)$values
A1<-matrix(c(1,1,-1,-1),ncol=2)
A1ev<-round(eigen(A1)$values)
print("Both th egiven matrices are similar because their eigen values are same")
print(Aev)
print(A1ev)
#The  answer may slightly vary due to  rounding off values


#The naïve Bayes classifier is one of the simplest approaches to the
#classification task that is still capable of providing reasonable accuracy

#It is superior for certain specific application domains, with text classification
#being the most prominent example. Its simplicity—conceptual, implementational, and
#computational—makes it easy and inexpensive to try besides or before more
#sophisticated classifiers.

library(dmr.stats)
library(dmr.util)
data(weather, package="dmr.data")
data(weatherc, package="dmr.data")

## calculate the posterior probability given prior and inverse probabilities
bayes.rule <- function(prior, inv)
{
  prior*inv/sum(prior*inv)
}

# posterior probabilities
bayes.rule(c(0.2, 0.3, 0.5), c(0.9, 0.9, 0.5))

  # let P(burglery)=0.001,
  # P(alarm|burglery)=0.95,
  # P(alarm|not burglery)=0.005
  # calculate P(burglery|alarm)
bayes.rule(c(0.001, 0.999), c(0.95, 0.005))[1]


#!/usr/bin/env Rscript

############################################################
### Least squares estimation
### y = beta0 + beta1*x --> Y = (1, X)beta
### Y = XB ---> X 不一定可逆
### t(X)Y = t(X)XB -->  inverse(t(X)X)t(X)Y = B
############################################################

X = cbind(rep(1, 5), c(1.00, 2.00, 3.00, 4.00, 5.00))
Y = c(3.70, 4.20, 4.90, 5.70, 6.00)

beta.hat = solve(t(X) %*% X) %*% t(X) %*% Y


##' @title
##' Cohen’s Kappa
##'
##' @description
##'
##' \code{mtr_cohen_kappa} computes Kappa statistic which measures inter-rater
##' agreement for categorical items.
##'
##' The form of Kappa statistic is: \eqn{Kappa = (O - E) / (1 - E)} where O is
##' the observed accuracy and E is the expected accuracy based on the marginal
##' total of the confusion matrix. The statistic can take on values between -1
##' and 1; a value of 0 means there is no agreement between the actual and the
##' predicted, while a value of 1 indicates perfect concordance of the model
##' prediction and the observed classes.
##'
##' @references
##'
##' \itemize{
##'   \item Max Kuhn and Kjell Johnson, Applied Predictive Modeling (New York: Springer-Verlag, 2013)
##'   \item \href{https://stats.stackexchange.com/questions/82162/cohens-kappa-in-plain-english}{"Classification - Cohen’s Kappa in Plain English, Cross Validated"}
##' }
##'
##'
##' @inheritParams classification_params
##' @return A numeric scalar output
##' @author An Chu
##' @include helper-functions.r
##' @export
##' @examples
##'
##' act <- c(1, 0, 1, 0, 1)
##' pred <- c(0.1, 0.9, 0.3, 0.5, 0.2)
##' mtr_cohen_kappa(act, pred)
##'
##'
##' set.seed(2093)
##' pred <- runif(1000)
##' act <- round(pred)
##' pred[sample(1000, 300)] <- runif(300) # noises
##' mtr_cohen_kappa(act, pred)
##'
mtr_cohen_kappa <- function(actual, predicted, cutoff = 0.5) {

    check_equal_length(actual, predicted)
    check_cutoff_range(cutoff)
    check_binary(actual)

    conf_mat <- mtr_confusion_matrix(actual, predicted, cutoff = cutoff)
    n <- sum(conf_mat)

    observed_accuracy <- mtr_accuracy(actual, predicted, cutoff = cutoff)

    expected_accuracy <- sum((rowSums(conf_mat) * colSums(conf_mat)) / n) / n

    kappa <- (observed_accuracy - expected_accuracy) / (1 - expected_accuracy)
    kappa
}