variance <- function(X){
    mean(X^2) - mean(X)^2
}

standard_deviation <- function(X){
    variance(X)^(1/2)
}

mu <- mean
sigma <- standard_deviation
sigma.2 <- var

skewness <- function(X){
    mean(((X - mu(X)) / sigma(X))^3)
}

kurtosis <- function(X){
    mean(((X - mu(X)) / sigma(X))^4)
}


#plot likelihood curve----
n<-10 #set total trials
x<-0 #set successes
theta<- seq(0,1,len=100) #create theta variable, from 0 to 1
like <- dbinom(x,n,theta) #create likelihood function
plot(theta,like,type='l',xlab=expression(theta), ylab='Likelihood', main="Likelihood Curve")

#? Daniel Lakens, 2016.
# This work is licensed under a Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License. https://creativecommons.org/licenses/by-nc-sa/4.0/

# Addition to calculate binomial probability given n, x and p
n<-10
x<-8
p<-0.5
r<- choose(n, x) * p^x * (1-p)^(n-x)
r
# Wallace Hobbes, 2019.


#####################################################################
# CS638: Applied Machine Learning
# Copyright 2016 Pejman Ghorbanzade <pejman@ghorbanzade.com>
# More info: https://github.com/ghorbanzade/beacon
#####################################################################

# clear workspace
rm(list = ls())

# enable traceback on error messages
options(error=traceback)

# remove all plots if there are any
if (!is.null(dev.list())) trash <- dev.off()

args = commandArgs(trailingOnly=TRUE)
if (0 == length(args)) {
  stop("expected path to root directory of course", call.=FALSE)
}
pngdir <- args[1]
courseNameFull <- "umb-cs638-2016s"

# ---------------------------------------------------------
# function declarations
# ---------------------------------------------------------

# function to compute sigmoid for logistic regression
sigmoid <- function(z) {
	sigmoid <- 1 / (1 + exp(-z))
	return(sigmoid)
}

# function to compute cost for logistic regression
cost <- function(x, y, theta, lambda=0) {
	m <- nrow(x)
	hx <- sigmoid(x %*% theta)
	r <- (lambda / (2 * m)) * t(theta) %*% theta
	cost <- (1 / m) * sum(-y * log(hx) - (1 - y) * log(1 - hx)) + r
	return(cost)
}

# function to implement gradient descent algorithm
gradient_descent <- function(x, y, theta, alpha, iters, lambda=0) {
	m <- dim(x)[1]
	costs <- rep(NA, iters)
	for(i in 1:iters) {
		hx <- sigmoid(x %*% theta)
		theta[1,1] <- theta[1,1] - alpha * ((1 / m) * t(t(hx - y) %*% x[, 1]))
		theta[-1,1] <- theta[-1,1] - alpha * ((1 / m) * t(t(hx - y) %*% x[, -1]) + (lambda / m) * theta[-1, 1])
		costs[i] <- cost(x, y, theta, lambda=lambda)
	}
	out <- list(costs=costs, params=theta)
	return(out)
}

# function to map features into polynomial terms up to the nth power
build_features <- function(f1, f2, degree) {
	out <- matrix(rep(1, length(f1)))
	for (i in 1:degree) {
		for (j in 0:i) {
			out <- cbind(out, f1^(i-j) * f2^j)
		}
	}
	return(out)
}

# ---------------------------------------------------------
# loading datasets
# ---------------------------------------------------------

# load dataset 1
data1 = read.table("dat/hw04/data1.txt", sep=",")
colnames(data1) <- c('exam1', 'exam2', 'status')
data11 <- data1[data1[, "status"] == 1, , drop=FALSE]
data12 <- data1[data1[, "status"] == 0, , drop=FALSE]

# load dataset 2
data2 = read.table("dat/hw04/data2.txt", sep=",")
colnames(data2) <- c('test1', 'test2', 'status')
data21 <- data2[data2[, "status"] == 1, , drop=FALSE]
data22 <- data2[data2[, "status"] == 0, , drop=FALSE]

# ---------------------------------------------------------
# visualize dataset 1
# ---------------------------------------------------------

png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-11", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

xrange <- seq(floor(min(data1$exam1)/5)*5,
	ceiling(max(data1$exam1)/5)*5,
	length.out=5
	)
yrange <- seq(floor(min(data1$exam2)/5)*5,
	ceiling(max(data1$exam2)/5)*5,
	length.out=5
	)
plot(0, 0, type="n", axes=F, ann=F,
	xlim=range(xrange), ylim=range(yrange))
points(data11$exam1, data11$exam2, type="p", col="blue", pch=3)
points(data12$exam1, data12$exam2, type="p", col="red", pch=1)
axis(1, at=xrange, labels=round(xrange, 3))
axis(2, at=yrange, labels=round(yrange, 3))

legend("topright",
	inset=0.01,
	legend = c(expression("admitted"), expression("rejected")),
	col = c("blue", "red"),
	pch = c(3, 1),
	cex = 0.8
	);
grid(10, 10)
box()
title(main="Student Admission Results Based on Exam Scores", font.main=1)
title(xlab="Score in Exam 1", col.lab='black')
title(ylab="Score in Exam 2", col.lab='black')
trash <- dev.off()

# ---------------------------------------------------------
# minimize cost function using gradient descent w/o scaling
# ---------------------------------------------------------

iters <- 1e6
alpha <- 1e-3
x <- cbind(1, data1$exam1, data1$exam2)
y <- data1$status
theta <- matrix(0, nrow=ncol(x), ncol=1)
fit <- gradient_descent(x, y, theta, alpha, iters)

# report final theta coefficients
paste("final theta coefficients:")
fit$params

# plot cost function based on number of iterations of gradient descent
# without feature scaling
png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-12", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

xrange <- seq(0, iters, length.out=6)
yrange <- seq(0, 1, length.out=5)
plot(0, 0, type="n", axes=F, ann=F, xlim=range(xrange), ylim=range(yrange))
lines(fit$costs, col="blue", lty=1)
axis(1, at=xrange, labels=round(xrange, 3))
axis(2, at=yrange, labels=round(yrange, 3))

legend("topright", inset=0.01,
	legend = as.expression(bquote(alpha == .(alpha))),
	col = c("blue"),
	lty = c(1),
	cex = 0.8
	);
grid(10, 10)
box()
title(main=paste("Minimizing Cost Function using Gradient Descent Algorithm\n",
	"Without Feature Scaling"), font.main=1)
title(xlab="Number of Iterations", col.lab='black')
title(ylab="Cost Function", col.lab='black')
trash <- dev.off()

# ---------------------------------------------------------
# plot decision boundary
# ---------------------------------------------------------

theta <- fit$params
slope <- - theta[2] / theta[3]
intercept <- - theta[1] / theta[3]

png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-13", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

xrange <- seq(floor(min(data1$exam1)/5)*5,
	ceiling(max(data1$exam1)/5)*5,
	length.out=5
	)
yrange <- seq(floor(min(data1$exam2)/5)*5,
	ceiling(max(data1$exam2)/5)*5,
	length.out=5
	)
plot(0, 0, type="n", axes=F, ann=F,
	xlim=range(xrange), ylim=range(yrange))
points(data11$exam1, data11$exam2, type="p", col="blue", pch=3)
points(data12$exam1, data12$exam2, type="p", col="red", pch=1)
abline(a=intercept, b=slope, col="green")
axis(1, at=xrange, labels=round(xrange, 3))
axis(2, at=yrange, labels=round(yrange, 3))

legend("topright",
	inset=0.01,
	legend = c(
		expression("admitted"),
		expression("rejected"),
		expression("decision boundary")
		),
	col = c("blue", "red", "green"),
	pch = c(3, 1, NA),
	lty = c(NA, NA, 1),
	cex = 0.8
	);
grid(10, 10)
box()
title(main=paste("Learned Decision Boundary for Student Admissions\n",
	"Based on Exam Scores"
	), font.main=1)
title(xlab="Score in Exam 1", col.lab='black')
title(ylab="Score in Exam 2", col.lab='black')
trash <- dev.off()

# ---------------------------------------------------------
# predict result based on learned decision boundary
# ---------------------------------------------------------

# What is the admission probability of a student with score
# 100 on exam1 and score 50 on exam2

student <- setNames(c(100, 50), c('exam1', 'exam2'))

theta <- fit$params
slope <- - theta[2] / theta[3]
intercept <- - theta[1] / theta[3]

probability <- sigmoid(c(1, student) %*% theta)
print(paste("Admission Chance: ", round(probability * 100, 2), "%"))

#
# plot student score relative to decision boundary
#
png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-14", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

xrange <- seq(floor(min(data1$exam1)/5)*5,
	ceiling(max(data1$exam1)/5)*5,
	length.out=5
	)
yrange <- seq(floor(min(data1$exam2)/5)*5,
	ceiling(max(data1$exam2)/5)*5,
	length.out=5
	)
plot(0, 0, type="n", axes=F, ann=F,
	xlim=range(xrange), ylim=range(yrange))
points(data11$exam1, data11$exam2, type="p", col="blue", pch=3)
points(data12$exam1, data12$exam2, type="p", col="red", pch=1)
abline(a=intercept, b=slope, col="green")
points(student['exam1'], student['exam2'], type="p", col="violetred", pch=2)
axis(1, at=xrange, labels=round(xrange, 3))
axis(2, at=yrange, labels=round(yrange, 3))

legend("topright",
	inset=0.01,
	legend = c(
		expression("admitted"),
		expression("rejected"),
		expression("student score"),
		expression("decision boundary")
		),
	col = c("blue", "red", "violetred", "green"),
	pch = c(3, 1, 2, NA),
	lty = c(NA, NA, NA, 1),
	cex = 0.8
	);
grid(10, 10)
box()
title(main=paste("Decision Boundary for Student Admissions\n",
	"Based on Exam Scores"
	), font.main=1)
title(xlab="Score in Exam 1", col.lab='black')
title(ylab="Score in Exam 2", col.lab='black')
trash <- dev.off()

# ---------------------------------------------------------
# visualize dataset 2
# ---------------------------------------------------------

png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-21", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

xrange <- seq(floor(min(data2$test1)*4)/4,
	ceiling(max(data2$test1)*4)/4,
	length.out=4
	)
yrange <- seq(floor(min(data2$test2)*4)/4,
	ceiling(max(data2$test2)*4)/4,
	length.out=4
	)
plot(0, 0, type="n", axes=F, ann=F,
	xlim=range(xrange), ylim=range(yrange))
points(data21$test1, data21$test2, type="p", col="blue", pch=3)
points(data22$test1, data22$test2, type="p", col="red", pch=1)
axis(1, at=xrange, labels=round(xrange, 3))
axis(2, at=yrange, labels=round(yrange, 3))

legend("topright",
	inset=0.01,
	legend = c(
		expression("passed"),
		expression("failed")
		),
	col = c("blue", "red"),
	pch = c(3, 1),
	cex = 0.8
	);
grid(10, 10)
box()
title(main="Acceptance Based on Test Results", font.main=1)
title(xlab="Test 1", col.lab='black')
title(ylab="Test 2", col.lab='black')
trash <- dev.off()

# ---------------------------------------------------------
# calculating costs and thetas for different lambda values
# ---------------------------------------------------------

features <- build_features(data2$test1, data2$test2, degree=7)
m <- dim(features)[1]
features <- cbind(rep(1, m), features)
features <- as.matrix(features)
n <- dim(features)[2]
y <- data2$status
theta <- matrix(0, ncol=1, nrow=n)

alpha <- 5e-1
iters <- 1e3
lambdas <- c(0, 1, 10, 100, 1000)
thetas <- matrix(0, ncol=length(lambdas), nrow=n)
costs <- matrix(0, ncol=length(lambdas), nrow=iters)

for (i in 1:length(lambdas)) {
	fit <- gradient_descent(features, y, theta, alpha, iters, lambdas[i])
	thetas[,i] <- fit$params
	costs[,i] <- fit$costs
}

# ---------------------------------------------------------
# plot cost function for different values of lambda
# ---------------------------------------------------------

# plot cost function based on number of iterations of gradient descent
# without feature scaling
png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-22", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

xrange <- seq(0, iters, length.out=6)
yrange <- seq(0, 1, length.out=5)
plot(0, 0, type="n", axes=F, ann=F, xlim=range(xrange), ylim=range(yrange))
lines(costs[,1], col="blue", lty=1)
lines(costs[,2], col="red", lty=1)
lines(costs[,3], col="green", lty=1)
lines(costs[,4], col="blue", lty=2)
lines(costs[,5], col="red", lty=2)
axis(1, at=xrange, labels=round(xrange, 3))
axis(2, at=yrange, labels=round(yrange, 3))

legend("topright", inset=0.01,
	legend = c(
		as.expression(bquote(lambda == .(lambdas[1]))),
		as.expression(bquote(lambda == .(lambdas[2]))),
		as.expression(bquote(lambda == .(lambdas[3]))),
		as.expression(bquote(lambda == .(lambdas[4]))),
		as.expression(bquote(lambda == .(lambdas[5])))
		),
	col = c("blue", "red", "green", "blue", "red"),
	lty = c(1, 1, 1, 2, 2),
	cex = 0.8
	);
grid(10, 10)
box()
title(main=paste("Effect of lambda values on Cost Function Minimization"),
	font.main=1)
title(xlab="Number of Iterations", col.lab='black')
title(ylab="Cost Function", col.lab='black')
trash <- dev.off()

# ---------------------------------------------------------
# compute decision boundary for different lambda values
# ---------------------------------------------------------

mn1 = mean(data2$test1)
mn2 = mean(data2$test2)
r1 = max(data2$test1) - min(data2$test1)
r2 = max(data2$test2) - min(data2$test2)

num = 200;
u <- seq(mn1 - r1 / 2, mn1 + r1 / 2, len=num)
v <- seq(mn2 - r2 / 2, mn2 + r2 / 2, len=num)

z1 = matrix(0, length(u), length(v))
z2 = matrix(0, length(u), length(v))
z3 = matrix(0, length(u), length(v))
z4 = matrix(0, length(u), length(v))
for (i in 1:length(u)) {
	for (j in 1:length(v)) {
		z1[j, i] <-  cbind(1, build_features(u[i], v[j], 7)) %*% thetas[,1]
		z2[j, i] <-  cbind(1, build_features(u[i], v[j], 7)) %*% thetas[,2]
		z3[j, i] <-  cbind(1, build_features(u[i], v[j], 7)) %*% thetas[,3]
		z4[j, i] <-  cbind(1, build_features(u[i], v[j], 7)) %*% thetas[,4]
	}
}

# ---------------------------------------------------------
# plot decision boundaries for different lambda values
# ---------------------------------------------------------

png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-23", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

contour(u, v, z1, nlevels=0, col="green", lty=2)

points(data21$test1, data21$test2, type="p", col="blue", pch=3)
points(data22$test1, data22$test2, type="p", col="red", pch=1)

legend("topright",
	inset=0.01,
	legend = c(
		expression("passed"),
		expression("failed"),
		as.expression(bquote(lambda == .(lambdas[1])))
		),
	col = c("blue", "red", "green"),
	pch = c(3, 1, NA),
	lty = c(NA, NA, 2),
	cex = 0.8
	);
grid(10, 10)
box()
title(main="Decision Boundary of Acceptance Based on Test Results", font.main=1)
title(xlab="Test 1", col.lab='black')
title(ylab="Test 2", col.lab='black')
trash <- dev.off()

# plot all contours on the same figure for comparison
png(filename=file.path(pngdir, paste(courseNameFull, "-hw04-24", ".png", sep="")),
	height=768, width=1024, res=150, units="px", bg="white")

contour(u, v, z1, nlevels=0, col="green", lty=2)
contour(u, v, z2, nlevels=0, col="orange", lty=2, add=TRUE)
contour(u, v, z3, nlevels=0, col="blue", lty=2, add=TRUE)
contour(u, v, z4, nlevels=0, col="red", lty=2, add=TRUE)

points(data21$test1, data21$test2, type="p", col="blue", pch=3)
points(data22$test1, data22$test2, type="p", col="red", pch=1)

legend("topright",
	inset=0.01,
	legend = c(
		expression("passed"),
		expression("failed"),
		as.expression(bquote(lambda == .(lambdas[1]))),
		as.expression(bquote(lambda == .(lambdas[2]))),
		as.expression(bquote(lambda == .(lambdas[3]))),
		as.expression(bquote(lambda == .(lambdas[4])))
		),
	col = c("blue", "red", "green", "orange", "blue", "red"),
	pch = c(3, 1, NA, NA, NA, NA),
	lty = c(NA, NA, 2, 2, 2, 2),
	cex = 0.8
	);
grid(10, 10)
box()
title(main="Decision Boundary for Acceptance Based on Test Results", font.main=1)
title(xlab="Test 1", col.lab='black')
title(ylab="Test 2", col.lab='black')
trash <- dev.off()


library(pomp)
library(ggplot2)

## Fake data

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(1234)

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.5) 	# Beta geometric walk noise

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

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

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

data <- data.frame(time = 0:T, y = infec_counts)

sir_step <- Csnippet("
    B = exp( log(B) + eta*(log(R0*r/500.0) - log(B)) + rnorm(0, berr) );
	double dS = - B*S*I;
	double dI = B*S*I - r*I;
	double dR = r*I;
	S += dt*dS;
	I += dt*dI;
	R += dt*dR;
")

sir_init <- Csnippet("
	S = 500.0 - I0;
	I = I0;
	R = 0;
	B = R0*r/500.0;
")

dmeas <- Csnippet('
  	lik = dnorm(y, I, sigma, give_log);
  	//Rprintf("%lf %lf, %lf, %lf, %d , %lf, %lf, %lf", lik, y, I, sigma, give_log, S, I, R);
')

rmeas <- Csnippet('
  	y = rnorm(I, sigma);
')

logtrans <- Csnippet("
	TR0 = log(R0);
	Tr = log(r);
	Tsigma = log(sigma);
	Teta = log(eta);
	Tberr = log(berr);
	TI0 = log(I0);
")

exptrans <- Csnippet("
	TR0 = exp(R0);
	Tr = exp(r);
	Tsigma = exp(sigma);
	Teta = exp(eta);
	Tberr = exp(berr);
	TI0 = exp(I0);
")

options(verbose=FALSE)
sir <- pomp(data = data,
            time = "time",
            t0 = 0,
            initializer = sir_init,
            rprocess = euler.sim(step.fun = sir_step,
                                 delta.t = 1.0/steps),
            dmeasure = dmeas,
            rmeasure = rmeas,
            statenames = c("S","I","R","B"),
            paramnames = c("R0","r","I0","sigma","eta","berr"),
            toEstimationScale = logtrans,
            fromEstimationScale = exptrans)

#simStates <- simulate(sir,nsim=1,params=c(R0 = 3.0, r = 0.1, I0 = 5.0, sigma = 10.0, eta = 0.5, berr = 0.3),
#                      states = TRUE, obvs = TRUE, include = FALSE, as = TRUE)

transfun <- function(params,...) {
    params[c("R0","r","I0","sigma","eta", "berr")] <- exp(params[c("R0","r","I0","sigma","eta", "berr")])
    return(params)
}

transfun_inv <- function(params,...) {
    params[c("R0","r","I0","sigma","eta", "berr")] <- log(params[c("R0","r","I0","sigma","eta", "berr")])
    return(params)
}

m1 <- mif2(sir,
	      Nmif = 300,
	      start = c(R0 = 3.0, r = 0.1, I0 = 5.0, sigma = 10.0, eta = 0.5, berr = 0.3),
	      rw.sd = rw.sd(R0 = 0.3, r = 0.01, I0 = 0.5, sigma = 1.0, eta = 0.05, berr = 0.03),
	      cooling.fraction.50 = 0.90,
	      Np = 3000,
	      toEstimationScale = transfun,
          fromEstimationScale = transfun_inv,
	      transform = TRUE
	      )

#plot(m1)
coef(m1)

if2pars <- coef(m1)[-c(grep('sigma', names(coef(m1))),grep('I0', names(coef(m1))))]
if2pars[['N']] <- 500

numtraj <- 100

trajData <- matrix(NA, nrow = numtraj, ncol = (T+1))
for(i in 1:numtraj) {
	sdeout <- StocSIR(true_init_cond, if2pars, T, steps)
	colnames(sdeout) <- c('S','I','R','B')
	trajData[i,] <- sdeout[,'I']
}

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

qplot(1:(T+1), meanTraj, geom = "line", xlab = "Time", ylab = "Infection count") +
	geom_ribbon(aes(ymin = quantTraj[,'025'], ymax=quantTraj[,'975']), alpha=0.1) +
	geom_line(aes(y = infec_counts)) +
	theme_bw()


# clean
rm(list = ls())

#setwd("Desktop/projects/r-projects/")

##########
# Part 1 #  Difference in Difference
##########  ========================

# load csv file
fastfood <- read.csv("fastfood.csv", header = TRUE, row.names = NULL)
fastfood

# linear model, average difference between fast-food restaurants located
# in NJ and Pennsylvania in terms of the number of full-time employees
model1 = lm(formula = empft ~ state, data = fastfood)
summary(model1) #avg diff = -2.6006

# Difference is not significant at 1% level because the p-value is 0.0188 (null hypothesis says
# that this difference is 0) and it's greater than 0.01. So we CAN'T reject the null. But we do at 5%.

# same for partial employees
model2 = lm(formula = emppt ~ state, data = fastfood)
summary(model2)

# same with wages
model3 = lm(formula = wage_st ~ state, data = fastfood)
summary(model3)

# avg starting wage (state=0) = 4.62863
# avg starting wage (state=1) = b_0 + b_1*S = 4.62863 + (-0.02123)*1 = 4.60707
# Can we reject the null hypothesis that the avg starting wage is the same in state=1 and state=0?
#    To be the same, b_1 must be 0. So..
#    No, we CAN'T because the p-value of null hypothesis (when b_1 = 0) is 0.638 (big for typical confidence levels)

# taking into account pa1 y pa2 for full-time employment
model4 = lm(formula = empft ~ state + pa1 + pa2, data = fastfood)
summary(model4) #error, not estimable because state, pa1 and pa2 are collinear

# difference in difference
model5 = lm(formula = empft2 - empft ~ state , data = fastfood)
summary(model5) # DiD = 3.443

##########
# Part 2 #  Regression Discontinuity
##########  ========================

# clean
rm(list = ls())

#install.packages("rdd")
library(rdd)

# load csv file
indiv_final <- read.csv("indiv_final.csv", header = TRUE, row.names = NULL)

#if difshare > 0, then 1. Create dummy.
indiv_final$positive_difshare <- as.numeric(indiv_final$difshare > 0)
mean(indiv_final$positive_difshare)

DCdensity(indiv_final$difshare, ext.out=TRUE)
# Difference in the log estimate in heights at the cutpoint?
#   ext.out=TRUE to see all the calculated values.
#   log estimate = theta = -0.002470001
#
#   p-value = 0.9620681   so we CAN'T reject the null (difference in cutoff is 0)

# keep only the observations within 50 percentage points of the cutoff
#    this means diffshare between -0.5 and 0.5 (cutoff is 0 by default)
subset_indiv_final = subset(indiv_final,  -0.5 < difshare & difshare < 0.5)
DCdensity(subset_indiv_final$difshare, ext.out=TRUE)

# create models to test
model1 = lm(myoutcomenext ~ positive_difshare,
                            data=subset_indiv_final)

model2 = lm(myoutcomenext ~ positive_difshare + difshare,
                            data=subset_indiv_final)

model3 = lm(myoutcomenext ~ positive_difshare + difshare + positive_difshare*difshare,
                            data=subset_indiv_final)

model4 = lm(myoutcomenext ~ positive_difshare + difshare + I(difshare^2),
                            data=subset_indiv_final)

model5 = lm(myoutcomenext ~ positive_difshare + difshare + I(difshare^2) +
                            positive_difshare*difshare + positive_difshare*I(difshare^2),
                            data=subset_indiv_final)

model6 = lm(myoutcomenext ~ positive_difshare +
                            difshare + I(difshare^2)+ I(difshare^3),
                            data=subset_indiv_final)

model7 = lm(myoutcomenext ~ positive_difshare +
                            difshare + I(difshare^2)+ I(difshare^3) +
                            positive_difshare*difshare + positive_difshare*I(difshare^2) + positive_difshare*I(difshare^3),
                            data=subset_indiv_final)

# From model1 to model4 we see the effects of positive_difshare is greater than 0.6
# All the models has a p-value (on positive_difshare) < 0.001 so we can reject the null at 99% level.
#   This means we cannot say there's no effect between positive_difshare and the outcome

# estimate the effect non-parametrically. What is the point estimate?
RDestimate(myoutcomenext ~ difshare, data=subset_indiv_final) #LATE = 0.4707
# also returns estimates of half and double of the optimal bandwidth

# plotting using different bandwith (from smaller to largest)
summary(RDestimate(myoutcomenext ~ difshare, data=subset_indiv_final)) #bandwidth = 0.11982

bandwidth <- 0.11982
m1 <- RDestimate(myoutcomenext ~ difshare, data=indiv_final, subset=abs(indiv_final$difshare) <= 0.5, bw = bandwidth/3) #other option:  kernel="rectangular"
plot(m1)
m2 <- RDestimate(myoutcomenext ~ difshare, data=indiv_final, subset=abs(indiv_final$difshare) <= 0.5)
plot(m2)
m3 <- RDestimate(myoutcomenext ~ difshare, data=indiv_final, subset=abs(indiv_final$difshare) <= 0.5, bw = 3*bandwidth)
plot(m3)


# <-- encoding UTF-8 -->
# mathmematical tools
# ------------------------------------
## DOC STRING
# easy math tools (e.g. Lorenz curve, Gini, Theil-I & II)
#
# all tools were developed by Tianhao Zhao and require less dependencies (actually, no extra package needed);
# MIT license;
# pls acknowledge him when using these functions;
#
# Tianhao Zhao (GitHub: Clpr)
# Dec 2018
# ------------------------------------

# ------------------------------------
## function: given x,y vectors, computes trapezium integral (lower & upper bound decided by x iteself);
# return a real number INT; not support infinite integral; no dependency
TrapeInt <- function(x,y){
    # get length, validation
    N <- if(length(x)==length(y)) length(x) else stop("x,y should have the same length")
    # sort by x
    chk <- sort(x,index.return=TRUE)$ix
    x <- x[chk]; y <- y[chk]
    # loop and compute
    INT <- 0
    for(idx in 1:(N-1)){
        INT <- INT + 0.5 * ( y[idx+1]+y[idx] ) * ( x[idx+1]-x[idx] )
    }
    return(INT)
}

# ------------------------------------
## function: compute y's Lorenz Curve & Gini value, sorted by x, weighted by w (popualtion, default all 1); y must be non-negative
LorenzCurve <- function(y,x=y,w=1+vector(mode="numeric",length=length(y))){
    # input:
    # 1. y: a numeric vector of income (or equivalent value)
    # 2. x: a numeric vector of factor; if y==x, Lorenz Curve & Gini, otherwise, Concentration Curve & Concentration Rate; by default, x == y
    # 3. w: a numeric vector of weights on y (frequencies of each element of y); by default, all 1 (each element of y is an individual but not a representation of a group)
    # output:
    # 1. list:
    #   1.1 LorenzX: X vector to plot Lorenz Curve (or Concentration Curve); in percentile measure, from 0 to 100
    #   1.2 LorenzY: Y vector to plot Lorenz Curve (or Concentration Curve); in percentile measure, from 0 to 100
    #   1.3 GiniIdx: real number in range [0,1]; the Gini index (or concentration index)
    # dependency:
    # 1. TrapeInt(): defined ad hoc, in this module; does trapezium integral for (x,y) pairs
    # -------------------
    # get length
    N <- if(all(y>=0)) length(y) else stop("y >=0 required")
    # sorting & getting index (increasing)
    chk <- sort(x,index.return=TRUE)$ix
    # new y extended by w times
    y <- rep(y[chk],times=w)
    N <- length(y)
    # Lorenz curve (discrete), x in 1:100 (non-constant space), y=1:100(non-constant space)
    LorenzX <- c(0, (1:N)/N * 100)   # add a 0 to make two lines(Lorenz & equality line) meet at 0)
    LorenzY <- c(0, cumsum(y) / sum(y) * 100 )
    # using trapezium integral to compute approximated Gini/concentration index
    GiniIdx <- 1 - TrapeInt(LorenzX,LorenzY)/5000
    # return
    return(list(LorenzX=LorenzX,LorenzY=LorenzY,GiniIdx=GiniIdx))
}

# ------------------------------------
## function: compute non-negative y's Theil-T (a=1) & Theil-L (a=0) index,
Theil <- function(y,w=1+vector(mode="numeric",length=length(y)), Type = "T"  ){
    # input:
    # 1. y: non-negative numeric vector, data to compute Theil index (individual-level data or grouped data with frequency w)
    # 2. w: weight/frequency vector
    # 3. Type: type of Theil index, "T" or "L" allowed (I & II)
    # output:
    # 1. a number, Theil index
    # dependency:
    # 1. NULL
    # ----------------
    # validation
    if(any(y<0)) stop("y>=0 required")
    # expand to micro level data (replicate by population w)
    y <- rep(y,times=w)
    N <- length(y)
    # get Theil index
    ybar <- mean(y)
    if(Type == "T"){
        return( mean(y/ybar * log((1E-12) + y/ybar)) )  # a minor is added to avoid y = 0
    }else if(Type == "L"){
        return( mean( log((1E-12) + ybar / (y+(1E-12))  ) ) )
    }else{
        stop("invalid type of Theil index")
    }
    # nomial return
    return(NULL)
}

# ------------------------------------
## function: regular descriptive statistics for a dataframe (all variables are numeric)
func_DescrStat <- function(tmpdf){
    return(data.frame(
        Variable = names(tmpdf),
        Observations = apply(tmpdf, 2, length ),
        Mean = apply(tmpdf, 2, mean ),
        Stdev = apply(tmpdf, 2, sd ),
        Min = apply(tmpdf, 2, min ),
        Q1 = apply(tmpdf, 2, quantile, probs = 0.25 ),
        Median = apply(tmpdf, 2, quantile, probs = 0.50 ),
        Q3 = apply(tmpdf, 2, quantile, probs = 0.75 ),
        Max = apply(tmpdf, 2, max )
    ))
}

# ------------------------------------
# function: construct formula objects from Y's name and a vector of X candidates
# NOTE: not support complex setting, e.g. instrumental variables
func_GetEq <- function(Yname, Xnames, Intercept = TRUE, KeepStr = TRUE ){
    # input:
    # 1. Yname: a string, indicates Y
    # 2. Xnames: a char vec of X names
    # 3. Intercept: bool, indicates if to keep an intercept
    # 4. KeepStr: bool, if TRUE, returns a string formula, if FALSE, returns a formula instance
    # output：
    # 1. Eq: a formla instance
    # ----------
    Eq <- paste(Yname,"~", paste(collapse=" + ",Xnames) )
    if(Intercept){
        Eq <- Eq
    }else{
        Eq <- paste(Eq,"-1")
    }
    if(KeepStr){
        return(Eq)
    }else{
        return(formula(Eq))
    }

}

# ---------------------------------------
# function: convert class "loadings" to a titled matrix
# NOTE: thanks: https://stackoverflow.com/questions/53825816/convert-a-loadings-object-to-a-dataframe-r
func_Load2Mat <- function( obj ){
    # input
    # 1. obj: a "loadings" instance, usually be pcares$loadings, where pcares is a returned instance by prcomp() or psych::principal()
    # output
    # 1. mat: a numeric matrix (loading matrix), both row & col are named
    # ------------
    df <- data.frame(matrix(as.numeric(obj), attributes(obj)$dim, dimnames=attributes(obj)$dimnames))
    return(df)
}


a <- c( 3.0,  4.0,  5.0)
b <- c( 4.0,  3.0,  5.0)

cross <- function(a, b)
   c(a[2]*b[3] - a[3]*b[2],
     a[3]*b[1] - a[1]*b[3],
     a[1]*b[2] - a[2]*b[1])

cross(a, b)
# [1]  5  5 -7


HaversineDistance=function(lat1,lon1,lat2,lon2)
{

	#returns the distance in km
	REarth<-6371
	lat<-abs(lat1-lat2)*pi/180
	lon<-abs(lon1-lon2)*pi/180
	lat1<-lat1*pi/180
	lat2<-lat2*pi/180
	a<-sin(lat/2)*sin(lat/2)+cos(lat1)*cos(lat2)*sin(lon/2)*sin(lon/2)
	d<-2*atan2(sqrt(a),sqrt(1-a))
	d<-REarth*d

	return(d)

}

RMSE<-function(pre,real)
{
	return(sqrt(mean((pre-real)*(pre-real))))
}

meanHaversineDistance<-function(lat1,lon1,lat2,lon2)
{
	return(mean(HaversineDistance(lat1,lon1,lat2,lon2)))
}

#USAGE
#
#FUNCTION PARAMETERS: @submission,@answers
#@submission: path+filename containing the answers to submit in CSV format
#@answers: path+filename containing the answers to evaluate the submission in CSV format
travelTime.PredictionEvaluation<-function(submission,answers)
{
	dt<-read.csv(submission)
	tt_sub<-dt[,2]
	dt<-read.csv(answers)
	tt_real<-dt[,2]
	return (RMSE(tt_sub,tt_real))
}

#USAGE
#
#FUNCTION PARAMETERS: @submission,@answers
#@submission: path+filename containing the answers to submit in CSV format
#@answers: path+filename containing the answers to evaluate the submission in CSV format
destinationMining.Evaluation<-function(submission,answers)
{
	dt<-read.csv(submission)
	lat_sub<-dt[,2]
	lon_sub<-dt[,3]
	dt<-read.csv(answers)
	lat_real<-dt[,2]
	lon_real<-dt[,3]
	return (meanHaversineDistance(lat_sub,lon_sub,lat_real,lon_real))
}


polylongdiv <- function(n,d) {
  gd <- length(d)
  pv <- vector("numeric", length(n))
  pv[1:gd] <- d
  if ( length(n) >= gd ) {
    q <- c()
    while ( length(n) >= gd ) {
      q <- c(q, n[1]/pv[1])
      n <- n - pv * (n[1]/pv[1])
      n <- n[2:length(n)]
      pv <- pv[1:(length(pv)-1)]
    }
    list(q=q, r=n)
  } else {
    list(q=c(0), r=n)
  }
}

# an utility function to print polynomial
print.polynomial <- function(p) {
  i <- length(p)-1
  for(a in p) {
    if ( i == 0 ) {
      cat(a, "\n")
    } else {
      cat(a, "x^", i, " + ", sep="")
    }
    i <- i - 1
  }
}

r <- polylongdiv(c(1,-12,0,-42), c(1,-3))
print.polynomial(r$q)
print.polynomial(r$r)


## Sample size for equality of means
## H_0: mu1=mu2
## two normally distributed samples
## of equal size (two-sided test)

mu1 = 132.85
s1 = 15.34
mu2 = 127.44
s2 = 18.23
alpha = 0.05
power = 0.8

zalpha = qnorm(1-alpha/2,0,1)
zbeta = qnorm(power,0,1)
n = ((s1*s1 + s2*s2)*(zalpha+zbeta)^2)/(mu2-mu1)^2

## -----------------------------------------------
## Sample size needed to compare two binomial proportions
## using a two-sided test where one sample is k times
## as large as the other sample (independent samples)

p1 = 0.0015
p2 = 0.0012
alpha = 0.05
power = 0.8
k = 1

q1 = 1-p1
q2 = 1-p2
zalpha = qnorm(1-alpha/2,0,1)
zbeta = qnorm(power,0,1)
p = (p1+k*p2)/(1+k)
q = 1-p

num = sqrt(p*q*(1+1/k))*zalpha + sqrt(p1*q1+p2*q2/k)*zbeta
n = num^2 / (p1-p2)^2

## ------------------------------------------
## Sample size estimation for the comparison of survival curves between
## two groups under the Cox Proportional-Hazards Model
## the ratio of participants in the experimental group to control is k

hr = 0.7 ## hazards ratio
k = 1
pE = 0.3707
pC = 0.4890
alpha = 0.05
power = 0.8

zalpha = qnorm(1-alpha/2,0,1)
zbeta = qnorm(power,0,1)
m = (1/k)*((k*hr+1)/(hr-1))^2*(zalpha+zbeta)^2
n = m/(k*pE + pC)


# 4.2 b) Use R and plot {ψj, j = 0, . . . , 50} when the parameteres are given by (4.12) (X_t= MA(INF))
#Consider a causal ARMA(2, 3)

library(itsmr)
phi = c(1.7,-.9)
theta = c(-1.4,.8,.1)
sigma2 = 1
#Using a function to check for invertibility and causality
check(list(phi=phi, theta=theta, sigma2 = sigma2))
## Causal
## Invertible
#Checking roots of AR-polynomial
Mod(polyroot(c(1,-phi)))
## [1] 1.054093 1.054093
#Checking roots of MA-polynomial
Mod(polyroot(c(1,theta)))
## [1] 1.022124 1.022124 9.571780

psi = numeric(51)
psi[1] = 1
psi[2] = phi[1]+theta[1]
psi[3] = phi[1]*psi[2]+phi[2]*psi[1]+theta[2]
psi[4] = phi[1]*psi[3]+phi[2]*psi[2]+theta[3]
for(k in 5:51){
    psi[k] = phi[1]*psi[k-1]+phi[2]*psi[k-2]
}
plot(0:50,psi, xlab = "k", ylab = expression(psi[k]), type= "b")

#4.3 c)
#Implement the results in R, compute and plotf
#(h); h = 0; : : : ; 50g with parameter
#values given by (3). Check your calculations with help of an R-function.

m = 50
M = matrix(0, ncol=m+1,nrow=m+1)
diag(M) = 1
M[2,2] = 1-phi[2]; M[1,2:3] = -phi; M[m+1,m] = -phi[1]
for(i in 1:(m-1)){
    M[seq(i+1,i+2),i] = -phi
}

M[1:5,1:5]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1.0 -1.7 0.9 0.0 0
## [2,] -1.7 1.9 0.0 0.0 0
## [3,] 0.9 -1.7 1.0 0.0 0
## [4,] 0.0 0.9 -1.7 1.0 0
## [5,] 0.0 0.0 0.9 -1.7 1
M[(m-3):(m+1),(m-3):(m+1)]
## [,1] [,2] [,3] [,4] [,5]
## [1,] 1.0 0.0 0.0 0.0 0
## [2,] -1.7 1.0 0.0 0.0 0
## [3,] 0.9 -1.7 1.0 0.0 0
## [4,] 0.0 0.9 -1.7 1.0 0
## [5,] 0.0 0.0 0.9 -1.7 1
s = c(1+theta[1]*psi[2]+theta[2]*psi[3]+theta[3]*psi[4],
theta[1]+theta[2]*psi[2]+theta[3]*psi[3],
theta[2]+theta[3]*psi[2],theta[3],rep(0,nrow(M)-4))
gamma.h = solve(M,s)
plot(0:m,gamma.h, col = 4, type = "h", xlab= "h", ylab = "Autocovariance")

#4.5
# Use R and draw the rectangle defined by (4.11) in a φ1φ2-coordinate system
phi1 = seq(from = -2.5, to = 2.5, length = 51)
plot(phi1,1+phi1,lty="dashed",type="l",xlab="",ylab="",cex.axis=.8,ylim=c(-1.5,1.5))
abline(a = -1, b = 0, lty="dashed")
abline(a = 1, b = -1, lty="dashed")
title(ylab=expression(phi[2]),xlab=expression(phi[1]),cex.lab=.8)
polygon(x = phi1[6:46], y = 1-abs(phi1[6:46]), col="gray")
lines(phi1,-phi1^2/4)
text(0,-.5,expression(phi[2]<phi[1]^2/4),cex=.7)
text(1.2,.5,expression(phi[2]>1-phi[1]),cex=.7)
text(-1.75,.5,expression(phi[2]>1+phi[1]),cex=.7)

# 4.9 a)
theta = c(1.8, 0.9)
Mod(polyroot(c(1,theta)))
#[1] 1.054093 1.054093
# Hence invertible as roots larger than 1


#Preliminaries
rm(list=ls())

#At an auction, bidders make offers to buy the goods,
#and a bidder's valuation is how much the bidder offers to pay for the good.

#Uniform Valuations
number_of_bidders <- 2
number_of_simulations <- 1000

set.seed(1)
valuations1 <- matrix(runif(
  number_of_bidders * number_of_simulations, min=0, max=1),
  nrow = number_of_simulations
)

# Defining a price
#
# expected profit = price * P(Valuation_bidder >= price for at least one bidder)
# P(V_bidder >= price) = 1 - CDF nth order statistic from U[0,1] evaluated at price
# CDF of uniform [0,1] = price^number_of_bidders

# expected_profit = price * (1 - price^number_of_bidders)
# optimal price: derivative of expected_profit, setting equal to 0 and solving for price
optimal_price <- (1/(number_of_bidders + 1))^(1/number_of_bidders)

# So expected, optimal profit will be
expected_optimal_profit = (number_of_bidders/(number_of_bidders + 1)) * optimal_price

###############
# Another way # (posted price)
###############

N <- number_of_bidders
V <- 1000

set.seed(5) #use another random seed
valuations<- matrix(runif(
  N * V, min=0, max=1),
  nrow = V
)

maximum_valuation <- apply(valuations, 1, max)
optimal_price <- 1/((N+1)^(1/N))
expected_revenue_posted <- (N/(N+1) * optimal_price)

revenue <- optimal_price * (maximum_valuation >= optimal_price)
mean(revenue)
expected_revenue_posted

###################
# English Auction #
###################

# last person wins the auction, so n-1st order statistic from U[0,1]
# f(x) = N*(N-1)*(1-x)*x^(N-2) and with integral of f(x) we obtain
expected_profit_auction <- (N-1)/(N+1)

####################
#    Comparison    #
####################
rank_of_valuations <- apply(valuations, 1, rank)
price_auction <- apply(valuations, 1, function(x)
(x[rank(x) == N - 1]))|
expected_revenue_auction <- (N-1)/(N+1)

mean(price_auction)
expected_revenue_auction
# IF N > 2, expected_profit_auction does better!!


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

rm(list = ls())

observed <- c(1.5, 2.3, 4.2, 7.1, 10.4, 8.4, 9.3, 6.5, 2.5, 4.6)

(k <- length(observed))
# 10

(lambda.hat <-1 / mean(observed))
# 0.176056338028169

test <- ks.test(observed, pexp, rate = lambda.hat)

(D <- test$statistic[[1]])
# 0.232976217289659

(criticvalue <- quantile(replicate(1000, ks.test(rexp(k, lambda.hat), pexp, rate = lambda.hat)$statistic), 0.95))
# 0.4109577865723

D > criticvalue
# FALSE (H0 no refused)


x=c(11.0,11.2,11.2,11.2,11.4,11.5,11.6,11.7,11.8,11.9,11.9,12.1,10.2,10.3,10.4,10.6,10.6,10.7,10.8,10.8,10.9,11.1,11.1,11.3)
y=rank(x)
cbind(x,y)
rep(table(y), table(y))
n1=12
n2=12
mut=n1*(n1+n2+1)/2
s=((n1*n2)/12)*((n1+n2+1)-(48/((n1+n2)*(n1+n2-1))))
sigmat=sqrt(s)
T=216 # sum of ranks of before clean up values
Z=(T-mut)/sigmat
Z
# This value exceeds 1.645, so we reject H0 and conclude that the distribution of before-cleanup measurements is shifted to the right of the corresponding distribution of after-cleanup measurements
# part b
si=(n1*n2*(n1+n2+1))/n1
sqrt(si)


#acceptance ratio = g(u)/q(u*|ui-1) / g(ui-1)/q(ui-1|u*)

#q = candidate drawing function

# g(u) = posterior distribution
#log(g(u)) = likeyhood*prior
lg = function(yBar,n,mu){
    mu2 = mu^2
    n*(yBar*mu - mu2/2) - log (1+mu2)
}

mh = function(n, yBar, nIter, muInit, candSd){
    muOut = numeric(nIter)
    accept = 0
    muNow = muInit
    lgNow = lg(mu=muNow, n=n, yBar=yBar)

    for (i in 1:nIter){
        #draw candidate from proposal distribution
        #q(u*|ui-1), using a normal distribution
        muCand = rnorm(1,mean=muNow,sd=candSd)

        #norm(mean=muNow,sd=candSd)/#norm(mean=muCand|sd=nowSd) -> cancles
        lgCand = lg(yBar=yBar,n=n,mu=muCand)
        lgNow = lg(yBar=yBar,n=n,mu=muNow)

        logAlpha = lgCand - lgNow

        alpha = exp(logAlpha)

        u = runif(1)
        #accept wiht proability alpha, rejects with probability 1-alpha
        if (u < alpha){
            muNow = muCand
            accept = accept + 1
            lgNow = lgCand
        }

        muOut[i] = muNow

    }
    list(mu=muOut,acceptRate=accept/nIter)
}

## Set up
# y = c(1.2, 1.4, -0.5, 0.3, 0.9, 2.3, 1.0, 0.1, 1.3, 1.9)
y = c(-0.2, -1.5, -5.3, 0.3, -0.8, -2.2)

yBar = mean(y)
n= length(y)

hist(y, freq=FALSE, xlim=c(-1.0, 3.0))
points(y, rep(0.0, n))
points(yBar, 0.0, pch=19)
curve(dt(x, df=1), lty=2, add=TRUE)

### posterior sampling
set.seed(43)
#want acceptance rate between .23 and .5 with randomwalk MH
post = mh(n=n, yBar=yBar, nIter=1e3, muInit=1, candSd=1.5)
str(post) #find what's in object

library("coda")

traceplot(as.mcmc(post$mu))

### post analysis
post$muKeep = post$mu[-c(1:100)]
plot(density(post$muKeep), xlim=c(-1.0,3.0))
mean(post$mu)
plot(density(post$mu))


# Time series

data=read.csv(file="http://eric.univ-lyon2.fr/~jjacques/Download/DataSet/varicelle.csv")
plot(data$x)
# We indicate to R the specificity of the timeseries (ts) object
varicelle<-ts(data$x,start=c(1931,1),end=c(1972,6),freq=12)
plot(varicelle)

install.packages("forecast")
install.packages("ggplot2")
install.packages("ffp")
install.packages("ffp2")
library(forecast)
library(ggplot2)
autoplot(varicelle) +
  ggtitle('Number of varicella per months')+ xlab('year')+
  ylab('Number of varicella')

ggseasonplot(varicelle,year.labels= TRUE,year.labels.left=TRUE)

ggseasonplot(varicelle,polar=TRUE)

mean(varicelle)
var(varicelle)

tmp=acf(varicelle,type="cov",plot = FALSE)
tmp$acf[1:3,1,1]

plot(tmp)

tmp=acf(varicelle,type="cor",plot = FALSE)
tmp$acf[1:3,1,1]

plot(tmp)

serie=2*(1:100)+4
par(mfrow=c(1,2))
plot(ts(serie))
acf(serie)

serie=cos(2*pi/12*(1:100))
par(mfrow=c(1,2))
plot(ts(serie))
acf(serie)

tmp=pacf(varicelle,type="cor",plot = FALSE)
tmp$acf[1:3,1,1]

plot(tmp)

x=rep(0,41)
for (i in 0:40)
  x[i+1]<-sum(varicelle[(1+12*i):(12*(i+1))])
plot(x,type='l',xaxt='n',xlab='')
axis(1,at = 0:40,labels = 1931:1971)

#ex2
plot.ts(co2)

sanfran <-read.csv(file="http://eric.univ-lyon2.fr/~jjacques/Download/DataSet/sanfran.dat", skip=1)
View(sanfran)
sanfran <- scan(file="http://eric.univ-lyon2.fr/~jjacques/Download/DataSet/sanfran.dat", skip=1)

plot(sanfran)

plot(sanfran,type='l',xlim=c(1,120),ylim=c(1,80),xlab='time',ylab='')

data("AirPassengers")
autoplot(AirPassengers, series="Data") +
  autolayer(ma(AirPassengers,6), series="6-MA") +
  autolayer(ma(AirPassengers,12), series="12-MA") +
  xlab("Year") +
  ylab("AirPassengers concentration") +
  ggtitle("AirPassengers") +
  scale_colour_manual(values=c("Data"="grey50","6-MA"="red","12-MA"="blue"), breaks=c("Data","6-MA","12-MA"))

autoplot(decompose(AirPassengers,type="additive"))+ xlab('Year')

autoplot(decompose(AirPassengers,type="multiplicative"))+ xlab('Year')

# we can see that there is a dependancy in residuals (trend)

tmp = decompose(co2)
plot(tmp)

# how to know there is a correlation between residuals? let's see autocorrelation

acf(tmp$random[-which(is.na(tmp$random))])

#there is a correlation in residuals

pacf(tmp$random[-which(is.na(tmp$random))])

#still we can see there is autocorrelation if order 1, 3,4,5 etc

air = decompose(AirPassengers)
plot(air)
acf(air$random[-which(is.na(air$random))])
pacf(air$random[-which(is.na(air$random))])
#there is autocorrelation in residuals too

a= decompose(AirPassengers, type='multi')

acf(a$random[-which(is.na(a$random))])
pacf(a$random[-which(is.na(a$random))])

data("AirPassengers")

par(mfrow=c(2,1))
plot(AirPassengers)
plot(diff(AirPassengers,differences=1))

par(mfrow=c(2,1))
plot(AirPassengers)
plot(diff(AirPassengers,differences=2))

par(mfrow=c(2,1))
plot(AirPassengers)
plot(diff(AirPassengers,lag=12,differences=1))

par(mfrow=c(3,1))
plot(AirPassengers)
plot(diff(AirPassengers,lag=12,differences=1))
plot(diff(diff(AirPassengers,lag=12)))

Box.test(diff(AirPassengers,lag=12,differences=1),lag=10,type="Ljung-Box")

install('fpp2')
library(fpp2)
plot(goog200)

#simulate an AR(p) AutoRegression of order p
par(mfrow=c(3,1))
model<-list(ar=c(0.8))
ar1<-arima.sim(model,5000)
plot.ts(ar1)
acf(ar1)
pacf(ar1)

#simulate an MAq. Observe the auto-correlations (partial or not)
modele<-list(ma=c(2))
ma1<-arima.sim(modele,1000)
plot.ts(ma1)
acf(ma1)
pacf(ma1)

autoplot(uschange[,c("Income","Unemployment")])

Arima(uschange[,"Income"],order=c(2,0,2))
Arima(uschange[,"Unemployment"],order=c(2,0,2))

auto.arima(uschange[,"Income"])
auto.arima(uschange[,"Unemployment"])

autoplot(uschange[,"Income"]) +
  xlab("Year") + ylab("Quarterly percentage change")

ggAcf(uschange[,"Income"])
ggPacf(uschange[,"Income"])

Arima(uschange[,"Income"],order=c(0,0,0))

Arima(uschange[,"Income"],order=c(0,0,3))

Arima(uschange[,"Unemployment"],order=c(2,0,0))
Arima(uschange[,"Unemployment"],order=c(1,0,2))

fit=Arima(uschange[,"Income"],order=c(0,0,0))
autoplot(forecast(fit,h=10))

fit=Arima(uschange[,"Unemployment"],order=c(1,0,2))
autoplot(forecast(fit,h=10))


#1 ¿Qué es Estadística?

# calculo de n_5
0.0603*7614
# 459.1242

# calculo de n_7
7614 - 145 - 2415 - 3456 - 852 - 459 - 157
# 130

# Frecuencias absolutas
nj <- c(145, 2415, 3456, 852, 459, 157, 130)

# Tamaño de la muestra
n <- 7614

# Sumar de las frecuencias absolutas
sum(nj)

# Numero de categorias
m <- length(nj)

# Frecuencias relativas
hj <- nj/n

# Nombres para la lista nj
names(nj) <- 0:6

# grafico de barras de frecuencias absolutas
# windows() Ejecución en RStudio (En RStudio server genera error)
barplot(
  height = nj,
  col = "lightblue",
  xlab = "No. de piezas defectuosas",
  ylab = "Frecuencia absoluta",
  main = "Ejemplo 1",
  border = "blue"
  )

# grafico de frecuencias relativas
hj <- prop.table(nj)
barplot(
  height = hj,
  col = "lightblue",
  xlab = "No. de piezas defectuosas",
  ylab = "Frecuencia relativa",
  main = "Ejemplo 2",
  border = "blue"
  )

# EJEMPLO 2
# datos
edu <- c("B", "D", "M", "B", "B", "P", "B", "M", "B", "B", "B", "P", "B", "M",
         "B", "B", "M", "B", "M", "B", "B", "B", "B", "B", "B", "B", "P", "B",
         "B", "B", "B", "M", "B", "P", "B", "B", "M", "B", "B", "B", "D", "B",
         "M", "B", "P", "B", "B", "B", "P", "P")
# tamaño de la muestra
n <- length(edu)
print(n)

# frecuencias absolutas
nj <- table(edu)
nj <- nj[c(1, 4, 3, 2)]
print(nj)

# Suma de las frecuencias absolutas
sum(nj)

# recuencias relativas
hj <- nj/n
print(hj)

# frecuencias asolutas acumuladas
Nj <- cumsum(nj)
print(Nj)

# frecuencias relativas acumuladas
Hj <- cumsum(hj)
print(Hj)


# Chapter 10 Lab 1: Principal Components Analysis

# This code is quoted from
# http://faculty.marshall.usc.edu/gareth-james/ISL/code.html

states=row.names(USArrests)
states
names(USArrests)
apply(USArrests, 2, mean)
apply(USArrests, 2, var)
pr.out=prcomp(USArrests, scale=TRUE)
names(pr.out)
pr.out$center
pr.out$scale
pr.out$rotation
dim(pr.out$x)
biplot(pr.out, scale=0)
pr.out$rotation=-pr.out$rotation
pr.out$x=-pr.out$x
biplot(pr.out, scale=0)
pr.out$sdev
pr.var=pr.out$sdev^2
pr.var
pve=pr.var/sum(pr.var)
pve
plot(pve, xlab="Principal Component", ylab="Proportion of Variance Explained", ylim=c(0,1),type='b')
plot(cumsum(pve), xlab="Principal Component", ylab="Cumulative Proportion of Variance Explained", ylim=c(0,1),type='b')
a=c(1,2,8,-3)
cumsum(a)

# Chapter 10 Lab 2: Clustering

# K-Means Clustering

set.seed(2)
x=matrix(rnorm(50*2), ncol=2)
x[1:25,1]=x[1:25,1]+3
x[1:25,2]=x[1:25,2]-4
km.out=kmeans(x,2,nstart=20)
km.out$cluster
plot(x, col=(km.out$cluster+1), main="K-Means Clustering Results with K=2", xlab="", ylab="", pch=20, cex=2)
set.seed(4)
km.out=kmeans(x,3,nstart=20)
km.out
plot(x, col=(km.out$cluster+1), main="K-Means Clustering Results with K=3", xlab="", ylab="", pch=20, cex=2)
set.seed(3)
km.out=kmeans(x,3,nstart=1)
km.out$tot.withinss
km.out=kmeans(x,3,nstart=20)
km.out$tot.withinss

# Hierarchical Clustering

hc.complete=hclust(dist(x), method="complete")
hc.average=hclust(dist(x), method="average")
hc.single=hclust(dist(x), method="single")
par(mfrow=c(1,3))
plot(hc.complete,main="Complete Linkage", xlab="", sub="", cex=.9)
plot(hc.average, main="Average Linkage", xlab="", sub="", cex=.9)
plot(hc.single, main="Single Linkage", xlab="", sub="", cex=.9)
cutree(hc.complete, 2)
cutree(hc.average, 2)
cutree(hc.single, 2)
cutree(hc.single, 4)
xsc=scale(x)
plot(hclust(dist(xsc), method="complete"), main="Hierarchical Clustering with Scaled Features")
x=matrix(rnorm(30*3), ncol=3)
dd=as.dist(1-cor(t(x)))
plot(hclust(dd, method="complete"), main="Complete Linkage with Correlation-Based Distance", xlab="", sub="")

# Chapter 10 Lab 3: NCI60 Data Example

# The NCI60 data

library(ISLR)
nci.labs=NCI60$labs
nci.data=NCI60$data
dim(nci.data)
nci.labs[1:4]
table(nci.labs)

# PCA on the NCI60 Data

pr.out=prcomp(nci.data, scale=TRUE)
Cols=function(vec){
    cols=rainbow(length(unique(vec)))
    return(cols[as.numeric(as.factor(vec))])
  }
par(mfrow=c(1,2))
plot(pr.out$x[,1:2], col=Cols(nci.labs), pch=19,xlab="Z1",ylab="Z2")
plot(pr.out$x[,c(1,3)], col=Cols(nci.labs), pch=19,xlab="Z1",ylab="Z3")
summary(pr.out)
plot(pr.out)
pve=100*pr.out$sdev^2/sum(pr.out$sdev^2)
par(mfrow=c(1,2))
plot(pve,  type="o", ylab="PVE", xlab="Principal Component", col="blue")
plot(cumsum(pve), type="o", ylab="Cumulative PVE", xlab="Principal Component", col="brown3")

# Clustering the Observations of the NCI60 Data

sd.data=scale(nci.data)
par(mfrow=c(1,3))
data.dist=dist(sd.data)
plot(hclust(data.dist), labels=nci.labs, main="Complete Linkage", xlab="", sub="",ylab="")
plot(hclust(data.dist, method="average"), labels=nci.labs, main="Average Linkage", xlab="", sub="",ylab="")
plot(hclust(data.dist, method="single"), labels=nci.labs,  main="Single Linkage", xlab="", sub="",ylab="")
hc.out=hclust(dist(sd.data))
hc.clusters=cutree(hc.out,4)
table(hc.clusters,nci.labs)
par(mfrow=c(1,1))
plot(hc.out, labels=nci.labs)
abline(h=139, col="red")
hc.out
set.seed(2)
km.out=kmeans(sd.data, 4, nstart=20)
km.clusters=km.out$cluster
table(km.clusters,hc.clusters)
hc.out=hclust(dist(pr.out$x[,1:5]))
plot(hc.out, labels=nci.labs, main="Hier. Clust. on First Five Score Vectors")
table(cutree(hc.out,4), nci.labs)


#
# Exemplo 1
#

# serie de maclaurin como função
# que desenvolverá a série até ter
# erro menor do que 0.001
maclaurin <- function(x) {
    n <- 0
    mac <- 0
    valor <- exp(x)
    while (abs(valor - mac) > 0.001) {
        termo <- (x^n) / factorial(n)
        mac <- mac + termo
        n <- n + 1
    }
    cat("Maclaurin=", mac, "Numero de interacoes=", n, "\n")
}

# ponto 1
b <- 1
# exponencial em b=1
exp(b)
# serie maclaurin em b=1
maclaurin(b)


# Example : 3   Chapter : 2.5   Pageno : 83
# Inverse of product of matrices
E<-matrix(c(1,-5,0,0,1,0,0,0,1),ncol=3)
E1<-solve(E)
F<-matrix(c(1,0,0,0,1,-4,0,0,1),ncol=3)
F1<-solve(F)
print(F1)
FE<-F%*%E
print(FE)
print("Inverse of FE ")
FE1<-solve(FE)
print(FE1)
print("Inverse of FE can also be E-1*F-1 ")
print(E1%*%F1)


##########################################################################
# github : https://github.com/jiankaiwang/DetailScience
# classification : math
# description : functions related to the combination of elements
#
# function description :
# - getAllCombinationNumber
#   count all combinations without the permutation
#
# - getCombination :
#   return the combination set based on the order of the set
#   for example: the 3rd combination order from vector c(1,2,3,4,5)
#                as three elements in the set
#   1st order : 1,2,3
#   2nd order : 1,2,4
#   3rd order : 1,2,5
#   the function would return c(1,2,5)
#   when the input collection is c('a','b','c','d','e'),
#   return would be c('a','b','e')
#
# - getRandomSet :
#   return a matrix conserving all combination set
#
# function usage :
# - numeric getAllCombinationNumber(numeric cntEles, numeric eleInSet)
#   (1) cntEles (as integer) : count of total elements
#   (2) eleInSet (as integer) : count of elements selected in the set
#
# - vector getCombination(vector eleColl, numeric eleInSet, numeric setOrd)
#   (1) eleColl (as vector) : a collection with all elements
#   (2) eleInSet (as integer) : count of elements selected in the set
#   (3) setOrd (as integer) : the combination order
#
# - matrix getRandomSet(vector eleColl, numeric eleCountInSet, numeric getTtlSetNum, logical retByIndex)
#   (1) eleColl (as vector) : a collection with all elements
#   (2) eleCountInSet (as integer) : count of elements selected in the set
#   (3) getTtlSetNum (as integer) : total set count
#   (4) retByIndex (as bool) : return by index or name in the set
#
# function example :
# - allCombNumber <- getAllCombinationNumber(80,4)
#   return 1581580
#
# - getEleSet <- getCombination(c('a','b','c','d','e'),3,7)
#   return c("b" "c" "d")
#
# - getRandomSet(c('a','b','c','d','e'),3,2,FALSE)
#        [,1] [,2] [,3]
#   [1,] "b"  "c"  "e"
#   [2,] "b"  "c"  "d"
##########################################################################

getAllCombinationNumber <- function(setNum, selectedNum) {
  leftNum <- min(setNum - selectedNum, selectedNum)
  res <- 1
  divNum <- 1
  for(i in setNum:(max(setNum - selectedNum, selectedNum)+1)) {
    res <- res * i
    if(res %% divNum == 0) {
      res <- res / divNum
      divNum <- divNum + 1
    }
  }
  divLeftNum <- 1
  if(divNum < leftNum) {
    for(i in divNum : leftNum) {
      divLeftNum <- divLeftNum * i
    }
  }
  return(res/divLeftNum)
}

getCombination <- function(getSet, getNum, getWhichCombination) {
  # initial
  # as stack
  retList <- 1:getNum
  count <- 1
  countLast <- 0

  # others
  while(count < getWhichCombination) {
    # pop the last one
    popValue <- retList[length(retList)]
    retList <- retList[1:length(retList)-1]

    # get new value
    if(popValue + 1 <= length(getSet)) {
      if(countLast == 0) {
        retList <- c(retList,popValue + 1)
      } else {
        if(popValue + 1 == length(getSet)) {
          countLast <- countLast + 1
          next
        }
        retList <- c(retList, (popValue + 1) : (popValue + 1 + countLast))
      }

      # initial for next multiple pops
      countLast <- 0
    } else {
      countLast <- countLast + 1
      next
    }

    # count add 1
    count <- count + 1
  }

  return(getSet[retList])
}

getRandomSet <- function(getSet, eleCountInSet, getTtlSetNum, retByIndex) {
  # check parameters
  if(getTtlSetNum > getAllCombinationNumber(length(getSet),eleCountInSet)) {
    return("getTtlSetNum is larger than all combination set count")
  } else if (length(getSet) < eleCountInSet) {
    return("total elements in data set is smaller than the getTtlSetNum value")
  }

  # as return matrix
  retSet <- matrix(c(1:eleCountInSet),nrow=1,ncol=eleCountInSet)

  tmpList <- c()
  tmpCheckFlag <- 0
  setIndex <- 1

  while(setIndex <= getTtlSetNum) {
    # initialization
    tmpList <- sort(sample(c(1:length(getSet)),eleCountInSet))
    tmpCheckFlag <- 0

    # check whether the same combination exists
    for(checkIndex in 1:nrow(retSet)) {
      if(length(which((retSet[checkIndex,] == tmpList) == TRUE)) == eleCountInSet) {
        tmpCheckFlag <- 1
        break
      }
    }

    if(tmpCheckFlag == 1) {
      # there is one combination same with new set
      next
    }

    if(retByIndex == TRUE) {
      retSet <- rbind(retSet, tmpList)
    } else {
      retSet <- rbind(retSet, getSet[tmpList])
    }

    setIndex <- setIndex + 1
  }

  # the first row is self-assigned for rbinding usage
  retSet <- retSet[-1,]

  if(is.numeric(retSet)) {
    return(matrix(retSet,nrow=nrow(retSet),ncol=eleCountInSet))
  } else {
    return(retSet)
  }
}


#R version 3.3.2

total_sum = 0

total_list <- 1:999
# Basic algo with O(n) speed
for (i in total_list) {
    if ((i %% 3 == 0) | (i %% 5 == 0)) {
        total_sum <- total_sum + i
    }
}

print(total_sum)

total_sum <- 0

i <- 0
# Improved algo with O(n/2)
while (i < 997) {
    i <- i + 3
    total_sum <- total_sum + i
}

i <- 0

while (i < 995) {
    i <- i + 5
    if (i %% 3 != 0) {
        total_sum <- total_sum + i
    }
}

print(total_sum)

# O(1) solution
print(((3*333*(333+1))/2) + ((5*199*(199+1))/2) - ((15*66*(66+1))/2))


#################################
# Example of Rejection Sampling
#################################

library(ggplot2)

# Define nasty function
f <- function(x){ x^2/exp(x)}
x <- seq(0,10,0.01)

xmin <- 0
xmax <- 10

C <- 15 # garantees that envelope is always higher than f
# Sample from envelop distribution
renvelope <- function(n){runif(n,xmin,xmax)}
denvelope <- function(x){C*dunif(x,xmin, xmax)}

df <- data.frame(x=x, f=f(x), q=denvelope(x))
gg <- ggplot(df, aes(x=x)) +
      geom_line(aes(y=f, color="real")) +
      geom_line(aes(y=q, color="envelop")) +
      theme(legend.title=element_blank()) +
      ggtitle("real and envelop distribution")
print(gg)

nsamples <- 10000

# Sample from envelop distribution
samples <- renvelope(nsamples)

# Sample from uniform distribution
u <- runif(nsamples)

accept <- u < f(samples)/denvelope(samples)
accept <- as.numeric(accept)

df = data.frame(sample = samples, accept = factor(accept, levels= c(1,0)))

gg<- ggplot(df, aes(x=df$sample)) +
     geom_histogram(aes(fill = accept), binwidth=0.1) +
     ggtitle("Samples")

print(gg)

cat("Acceptance ratio:", sum(accept)/length(accept))


library(deSolve)

seir_ode <- function(t,Y,par){
  S <- Y[1]
  E <- Y[2]
  I <- Y[3]
  R <- Y[4]

  beta  <- par[1]
  sigma <- par[2]
  gamma <- par[3]
  mu    <- par[4]

  dYdt <- vector(length=3)
  dYdt[1] = mu-beta*I*S-mu*S
  dYdt[2] = beta*I*S-(sigma+mu)*E
  dYdt[3] = sigma*E-(gamma+mu)*I

  return(list(dYdt))
}

beta  <- 520/365;
sigma <- 1/60;
gamma <- 1/30;
mu    <- 774835/(65640000*365) # UK birth and population figures 2016
init  <- c(0.8,0.1,0.1)
t     <- seq(0,365)
par   <- c(beta,sigma,gamma,mu)

sol <- lsoda(init,t,seir_ode,par)

# Plot
plot(t,sol[,2],type="l",col="blue",ylim=c(0,1),ylab="Proportion")
lines(t,sol[,3],col="orange")
lines(t,sol[,4],col="red")
lines(t,1-rowSums(sol[,2:4]),col="green")
legend(300,0.7,legend=c("S","E","I","R"),col=c("blue","orange","red","green"), lty=1, cex=0.8)


require(MASS)
rbf=function(a,b,l,s=1)s*exp(-((a-b)^2) / (2*l^2))
cov=function(x1,x2,K)sapply(x2,function(i)sapply(x1,function(j)K(i,j)))

K = function(a,b)rbf(a,b,5)

conditional = function(x1, x2, y2, K){ #x1,x2,y1,u1,u2 are all vectors
	K11 = cov(x1,x1,K)
	K12 = cov(x1,x2,K)
	K22_1 = solve(cov(x2,x2,K))
	K21 = cov(x2,x1,K)
	#mu = u1 + K12 %*% K22_1 %*% (y2 - u2)
	mu = K12 %*% K22_1 %*% (y2)
	sigma = K11 - K12 %*% K22_1 %*% K21
	list(sigma,mu,cbind(x2,y2))
}

rbfGP = function(obs, xs, l, s){
	K = function(a,b)rbf(a,b,l,s)
	x2 = obs[,1]
	y2 = obs[,2]
	conditional(xs,x2,y2,K)

}

plt = function(res,n,title="plt"){
	r2=mvrnorm(n,res[[2]][,1],res[[1]])
	quantiles = apply(r2,2,function(i)quantile(i,probs=c(0.05,0.5,0.95)))
	ylim = c(min(quantiles),max(quantiles))
	plot(quantiles[2,],xlab="GP Dimension",ylab="Y",ylim=ylim,type="l", lty=2, lwd=2,col="red",main=title)
	lines(quantiles[1,],col="blue")
	lines(quantiles[3,],col="blue")
	points(res[[3]],col="black")
}

pltdraws = function(x,rbfk,n,title){
	c1 = cov(x,x,rbfk)
	draws = mvrnorm(n,rep(0,length(x)),c1)
	ylim = c(min(draws),max(draws))
	plot(draws[1,],ylim=ylim,xlab="Dimension",ylab="Y",main=title)
	for(i in 1:nrow(draws)){
		lines(draws[i,])
	}
}

#Plot random GP draws on an RBF kernel
plt4GPs = function(){
	x = 1:50
	rbf1 = function(a,b)rbf(a,b,1)
	rbf5 = function(a,b)rbf(a,b,5)
	rbf10 = function(a,b)rbf(a,b,10)
	rbf20 = function(a,b)rbf(a,b,20)
	par(mfrow=c(2,2))
	pltdraws(x,rbf1,10,"L = 1")
	pltdraws(x,rbf5,10,"L = 5")
	pltdraws(x,rbf10,10,"L = 10")
	pltdraws(x,rbf20,20,"L = 20")
}

#Fit GPs with defined kernels to data
plt4FittedGPs = function(){
	x = 1:50
	obs = cbind(c(5,7,10,15,40),c(3.3,2.1,.5,-1,0))
	par(mfrow=c(2,2))
	plt(rbfGP(obs,1:50,1,5),10000,title="L = 1")
	plt(rbfGP(obs,1:50,5,5),10000,"L = 5")
	plt(rbfGP(obs,1:50,10,5),10000, "L = 15")
	plt(rbfGP(obs,1:50,20,5),10000, "L = 20")

}


sample_size=c(5,4,6,5)
#l1=y1bar-y3bar
#l2=y1bar+y2bar+y3bar-3*y4bar
# We can rewrite the contrasts in the following form:
#l1=y1bar+0*y2bar-y3bar+0*y4bar
#l2=l2=y1bar+y2bar+y3bar-3*y4bar
# thus we identify a1 = 1, a2 = 0, a3 =-1, a4 = 0 and b1 =0, b2 = 1, b3 =0, b4 =-1
a=c(1,0,-1,0)
b=c(1,1,1,-3)
test=0
i=1
while(i<=length(sample_size)){
  test=test+(a[i]*b[1])/sample_size[i]
  i=i+1
}
print(test)
if(test==0){
  print("hence the contrasts are orthogonal.")
}else{
  print("hence the contrasts are not orthogonal")
}
# part b
sample_size=5
a=c(1,0,-1,0)
b=c(1,1,1,-3)
test=0
i=1
while(i<=4){
  test=test+(a[i]*b[1])/sample_size
  i=i+1
}
print(test)
if(test==0){
  print("hence the contrasts are orthogonal.")
}else{
  print("hence the contrasts are not orthogonal")
}


# nice but not suitable for big samples!
monteCarloPi <- function(samples) {
  x <- runif(samples, -1, 1) # for big samples, you need a lot of memory!
  y <- runif(samples, -1, 1)
  l <- sqrt(x*x + y*y)
  return(4*sum(l<=1)/samples)
}

# this second function changes the samples number to be
# multiple of group parameter (default 100).
monteCarlo2Pi <- function(samples, group=100) {
  lim <- ceiling(samples/group)
  olim <- lim
  c <- 0
  while(lim > 0) {
    x <- runif(group, -1, 1)
    y <- runif(group, -1, 1)
    l <- sqrt(x*x + y*y)
    c <- c + sum(l <= 1)
    lim <- lim - 1
  }
  return(4*c/(olim*group))
}

print(monteCarloPi(1e4))
print(monteCarloPi(1e5))
print(monteCarlo2Pi(1e7))


## 2. Calculating expected values ##

males_over50k <- .67 * .241 * 32561
males_under50k <- .67 * .759 * 32561
females_over50k <- .33 * .241 * 32561
females_under50k <- .33 * .759 * 32561

## 3. Calculating the chi-squared statistic ##

chisq_gender_income <- 0
observed <- c(6662, 1179, 15128, 9592)
expected <- c(5257.6, 2589.6, 16558.2, 8155.6)

for (i in 1:length(observed)) {
    O <- observed[i]
    E <- expected[i]
    chisq_gender_income <- chisq_gender_income + (O - E)^2 / E
}

## 4. Calculating degrees of freedom ##

r <- 2
c <- 2
df <- (r - 1) * (c - 1)

## 5. Calculating p-value ##

pvalue <- 1 - pchisq(1517, 1)
reject_null <- TRUE

## 6. R's built-in chi-squared test function ##

library(readr)
income <- read.csv("income.csv")
race_education_table <- table(income$race, income$education)
chisq.test(race_education_table)
reject_null <- TRUE

Data Analyst in R/Step 5 - Probability and Statistics/5. Hypothesis Testing in R/4. Multi category chi-squared tests.r


# Binomial logistic regression simulation code

# Raymond Viviano
# rayviviano@gmail.com
# March 23, 2020

#' Inverse Logit Function
inv.logit <- function(p){
    return(exp(p)/(1+exp(p)))
}

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of modell where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

# Ensure reproducible results
set.seed(10000)

# Set logistic regression parameters (Can be calculated as log(oddsRatio))
b0 <- .2        # Set Logistic Regression Intercept True Value
b1 <- .5        # Set Logistic Regression Slope True Value

# Define sample size
n <- 16000

# Define number of simulations
nsims <- 20

# Define matrix to hold simulation data (estimates, std.errors, and pvals)
sim.prms <- matrix(NA, nrow=nsims, ncol=6)

# Loop through simulations
for(i in 1:nsims){
    # Generate independant variable data, uniform random between -1 and 1
    x <- runif(n, -1, 1)

    # Generate true data-generation-process Bernoulli trials
    y <- rbinom(n, 1, inv.logit(b0 + b1*x))

    # Estimate logit model
    model <- glm(y~x, family=binomial(link=logit))

    # Get variance-covariance matrix
    var.covar <- vcov(model)

    # Put model paramters in simulation matrix
    sim.prms[i,1] <- model$coef[1]             # Estimate for b0
    sim.prms[i,2] <- model$coef[2]             # Estimate for b1
    sim.prms[i,3] <- sqrt(diag(var.covar)[1])  # b0 standard error
    sim.prms[i,4] <- sqrt(diag(var.covar)[2])  # b1 standard error
    sim.prms[i,5] <- summary(model)$coefficients[,4][1] # b0 pvalue
    sim.prms[i,6] <- summary(model)$coefficients[,4][2] # b1 pvalue
}

# Get Covarage probabilities for the parameters
b0.coverage <- coverage.prob(sim.prms[,1], sim.prms[,3], b0, .95, n-model$rank)
b1.coverage <- coverage.prob(sim.prms[,2], sim.prms[,4], b1, .95, n-model$rank)

# Print intercept coverage probability and 95% confidence interval
print("Coverage Probability for b0")
print(b0.coverage)

# Print coefficent on x coverage probability and 95% confidence interval
print("Coverage Probability for b1")
print(b1.coverage)

# Power for intercept
cat("Power to detect b0\n")
power.detect.effect(sim.prms[,5])

cat("\nPower to detect b1\n")
# Power for coefficient on x
power.detect.effect(sim.prms[,6])


library(DescTools)
x = c(0.90, 0.37, 1.63, 0.83, 0.95, 0.78, 0.86, 0.61, 0.38, 1.97)
y = c(1.46, 1.45, 1.76 ,1.44, 1.11 ,3.07 ,0.98 ,1.27 ,2.56 ,1.32)

cbind(c(x,y),rank(c(x,y)))

a <- wilcox.test(x,y,correct=FALSE,conf.int = TRUE)
n1 <- length(x)
a$statistic <- a$statistic + n1*(n1+1)/2
names(a$statistic) <- "T.W"
a
# T<83 so  we reject H0 and conclude there is significant evidence that the placebo population has smaller reaction times than the population of alcohol consumers
# p value calculated in book is wrong
# confidence interval for delta (-1.08, -0.25)

#  95% confidence interval   for the placebo population median
MedianCI(x,conf.level = 0.95,na.rm = FALSE, method = "exact",R = 10000)
# #  95% confidence interval   for the alcohol population median
MedianCI(y,conf.level = 0.95,na.rm = FALSE, method = "exact",R = 10000)


########################
# R Script for Class 6 #
########################

# t distribution
x <- seq(-4, 4, length=100)
hx <- dnorm(x)

degf <- c(1, 3, 8, 30)
colors <- c("red", "blue", "darkgreen", "gold", "black")
labels <- c("t df=1", "t df=3", "t df=8", "t df=30", "normal")

plot(x, hx, type="l", lty=2, xlab="x value",
     ylab="Density", main="Comparison of t and normal Distributions")

for (i in 1:4){
  lines(x, dt(x,degf[i]), lwd=2, col=colors[i])
}

legend("topright",
       labels, lwd=2, lty=c(1, 1, 1, 1, 2), col=colors)

# checking p-values
1-pnorm(1.96)
1-pt(1.96, 15)

# loading data
D = read.csv2('shoesize.csv')
D

# exploring height
D$Height
mean(D$Height)
sd(D$Height)
quantile(D$Height)
hist(D$Height)
plot(density(D$Height))

sd(D$Height)/sqrt(408)

# Assumming this data is a random sample of the full school populatio, what is our best estimate of the mean height of all students at this university? Provide a point estimate and 95% confidence interval.

# Assumming this data is a random sample of the full school populatio, what is our best estimate of the mean shoe sizeght of all students at this university? Provide a point estimate and 95% confidence interval.

hist(D$Size)
mean(D$Size)
sd(D$Size)

mean(D$Size)+(2*(sd(D$Size)/sqrt(408)))
mean(D$Size)-(2*(sd(D$Size)/sqrt(408)))

# What is the relationship between height and shoe size?

plot(D$Height, D$Size)
cor(D$Height, D$Size)

M = lm(D$Height~D$Size)
summary(M)

M = lm(D$Height~D$Size+D$Gender)
summary(M)

M = lm(D$Height~D$Size+D$Gender + D$Size*D$Gender )
summary(M)

# family planning data
library(foreign)
library(calibrate)

D = read.dta('effort.dta')
head(D)

plot(change~effort, data=D, ylab="CBR change", xlab="program effort", pch=20, col="#000099dd", cex=2)

M = lm(change~effort, data=D)
summary(M)

M = lm(change~effort+setting, data=D)
summary(M)


                                ############################
                                #FORECASTING AIRLINE DELAYS#
                                ############################
# PROBLEM 1 - LOADING THE DATA
Airlines <- read.csv("AirlineDelay.csv")
set.seed(15071)

spl = sample(nrow(Airlines), 0.7*nrow(Airlines))

AirlinesTrain = Airlines[spl,]

AirlinesTest = Airlines[-spl,]
# How many observations are in the training set AirlinesTrain?
str(AirlinesTrain)
# How many observations are in the testing set AirlinesTest?
str(AirlinesTest)

# PROBLEM 2 - METHOD OF SPLITTING THE DATA
# In this class, we have frequently used the sample.split function to randomly split our data.
#                             Why do we use a different approach here?
# Review help(sample.split) of caTools package to find the answer

# PROBLEM 3 - A LINEAR REGRESSION MODEL
# Build a linear regression model to predict "TotalDelay"
linFit <- lm(TotalDelay ~ ., data=AirlinesTrain)
# What is the model's R-squared?
summary(linFit)

#PROBLEM 4 - CHECKING FOR SIGNIFICANCE
# In your linear regression model, which of the independent variables are significant at the
#                             p=0.05 level (at least one star)?
summary(linFit)

# PROBLEM 5 - CORRELATIONS
# What is the correlation between NumPrevFlights and PrevFlightGap in the training set?
cor(AirlinesTrain$NumPrevFlights,AirlinesTrain$PrevFlightGap)
# What is the correlation between OriginAvgWind and OriginWindGust in the training set?
cor(AirlinesTrain$OriginAvgWind,AirlinesTrain$OriginWindGust)

# PROBLEM 6 - IMPORTANCE OF CORRELATIONS
# Why is it imporant to check for correlations between independent variables? Select all that apply.
# Read article on "multicollinearity" to answer the quiz

# PROBLEM 7 - COEFFICIENTS
# In the model with all of the available independent variables, what is the coefficient for HistoricallyLate?
coef(linFit)

# PROBLEM 8 - UNDERSTANDING THE COEFFICIENTS
# The coefficient for NumPrevFlights is 1.56. What is the interpretation of this coefficient?
# Read article on "Coefficient of determination" to answer the quiz

# PROBLEM 9 - UNDERSTANDING THE MODEL
# In the linear regression model, given two flights that are otherwise identical, what is the absolute
# difference in predicted total delay given that
# -one flight is on Thursday and the other is on Sunday?
# -one flight is on Saturday and the other is on Sunday?
# The absolute difference between the coefficients of two dates is the predicted delay

# PROBLEM 10 - PREDICTIONS ON THE TEST SET
# What is the Sum of Squared Errors (SSE) on the test set?
predictions <- predict(linFit, newdata=AirlinesTest)
# What is the Total Sum of Squares (SST) on the test set?
SSE <- sum((AirlinesTest$TotalDelay - predictions)^2)
# What is the R-squared on the test set?
SST <- sum((AirlinesTest$TotalDelay - mean(AirlinesTrain$TotalDelay))^2)
1-SSE/SST

# PROBLEM 11 - EVALUATING THE MODEL
# Given what you have seen about this model (the R-squared on the training and test sets, the
# significance of the coefficients, etc.), which of the following are true?
# Eliminate wrong choices. Read article on "R-squared" to answer the question

# PROBLEM 12 - A CLASSIFICATION PROBLEM
Airlines$DelayClass = factor(ifelse(Airlines$TotalDelay == 0, "No Delay", ifelse
                                    (Airlines$TotalDelay >= 30, "Major Delay", "Minor Delay")))
# How many flights in the dataset Airlines had no delay, minor delay, major delay respectively?
summary(Airlines$DelayClass)
Airlines$TotalDelay = NULL
# Prepare necessary data for CART model
library(caTools)
set.seed(15071)
split <- sample.split(Airlines$DelayClass, SplitRatio=0.7)
AirlinesNewTrain <- subset(Airlines, split==T)
AirlinesNewTest <- subset(Airlines, split==F)

# PROBLEM 13 - A CART MODEL
library(rpart)
library(rpart.plot)
cart <- rpart(DelayClass ~., data=AirlinesNewTrain, method="class")
# How many split are in the resulting tree?
prp(cart)

# PROBLEM 14 - UNDERSTANDING THE MODEL
# The CART model you just built never predicts one of the three outcomes. Which one?
prp(cart)

# PROBLEM 15 - TRAINING SET ACCURACY
library(caret)
# Make predictions on the training set, and then create a confusion matrix.
# What is the overall accuracy of the model?
cartTrainPredicts <- predict(cart, AirlinesNewTrain, type="class")
confusionMatrix(AirlinesNewTrain$DelayClass, cartTrainPredicts)

# PROBLEM 16 - A BASELINE MODEL
# What is the accuracy on the training set of a baseline model that predicts the most
# frequent outcome (No Delay) for all observations?
obs <- max(table(AirlinesNewTrain$DelayClass))
obs/nrow(AirlinesNewTrain)

# PROBLEM 17 - TESTING SET ACCURACY
# Make predictions on the testing set, and then create a confusion matrix. What is the
# overall accuracy of the model on the testing set?
cartTestPredicts <- predict(cart, newdata=AirlinesNewTest, type="class")
confusionMatrix(AirlinesNewTest$DelayClass, cartTestPredicts)


#install.packages("GA")
library(GA)

# https://cran.r-project.org/web/packages/GA/vignettes/GA.html#constrained-optimisation
# Townsend function (modified)
# https://en.wikipedia.org/wiki/Test_functions_for_optimization
func3d <- function(x)
{
  -(cos((x[1]-0.1)*x[2]))^2-x[1]*sin(3*x+x[2])
}

c1 <- function(x)
{
  t <- atan2(x[1], x[2])
  x[1]^2+x[2]^2-(2*cos(t)-1/2*cos(2*t)-1/4*cos(3*t)-1/8*cos(4*t))^2-(2*sin(t))^2
}

x1LBound <- -2.25
x1RBound <- 2.25
x2LBound <- -2.5
x2RBound <- 1.75

ngrid <- 20 # 250
nLevels <- 5
x1 <- seq(x1LBound, x1RBound, length = ngrid)
x2 <- seq(x2LBound, x2RBound, length = ngrid)
x12 <- expand.grid(x1, x2)
col <- adjustcolor(bl2gr.colors(4)[2:3], alpha = 0.2)
plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)

fitness <- function(x)
{
  f <- -func3d(x)                    # we need to maximise -func3d(x)
  pen <- sqrt(.Machine$double.xmax)  # penalty term
  penalty1 <- max(c1(x),0)*pen       # penalisation for 1st inequality constraint
  f - penalty1                       # fitness function value
}

GA <- ga("real-valued", fitness = fitness,
         lower = c(x1LBound, x2LBound), upper = c(x1RBound, x2RBound),
         # selection = GA:::gareal_lsSelection_R,
         maxiter = 10000, run = 5000) # seed = 123)
summary(GA)
plot(GA)

fitness(GA@solution)
func3d(GA@solution)
c1(GA@solution)

plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)
points(GA@solution[1], GA@solution[2], col = "dodgerblue3", pch = 3)  # GA solution


######################################################################
# Ratfor program to display emirps
######################################################################

######### Test if a number is prime #########
logical function prime(n)
    integer n  # Number to test

    # Deal with numbers <= 3
    if (n < 1) goto 200
    if (n == 2 | n == 3) goto 100

    # Check if divisible by 2 or 3
    if (mod(n,2) == 0) goto 200
    if (mod(n,3) == 0) goto 200

    # See if divisible by 5, 7, ..., up to approx sqrt(n)
    for (i = 5; i < 1000000; i = i + 2) {
        if (I*I > n) goto 100
        if (mod(n,i) == 0) goto 200
    }

 100  prime = .true.
      return
 200  prime = .false.
      return
end

######### Reverse an integer's digits #########
integer function revrse(n)
    integer n  # Number to reverse
    integer m  # Copy of n from which we take digits
    integer r  # Reversed digits
    m = n
    r = 0
    while (m >= 1) {
        # Take last digit from m and append to r
        r = r * 10
        r = r + mod(m, 10)
        m = m / 10
    }
    revrse = r
    return
end

######### Test if an integer is an emirp #########
logical function emirp(n)
    integer n       # Number to test
    integer revrse  # External function
    logical prime   # External function
    integer r       # Reversed digits of n
    r = revrse(n)
    emirp = .false.
    # n and r must both be prime and not the same value
    if (n .ne. r & prime(n) & prime(r)) {
        emirp = .true.
    }
    return
end

######### Display an integer #########
subroutine show(n)
    integer n
    write(6,50) n
50  format(i10)
    return
end

######### Show first 20 emirps #########
subroutine test1
    logical emirp   # External function
    integer i       # Count of emirps found
    integer n       # Number to test
    n = 0
    for (i = 1; i <= 20; i = i + 1) {
        repeat {
            n = n + 1
        } until (emirp(n))
        call show(n)
    }
    return
end

######### Show emirps between 7,700 and 8,000 #########
subroutine test2
    logical emirp   # External function
    integer n       # Number to test
    for (n = 7700; n <= 8000; n = n + 1) {
        if (emirp(n)) {
            call show(n)
        }
    }
    return
end

######### Show 10,000th emirp #########
subroutine test3
    logical emirp   # External function
    integer i       # Count of emirps found
    integer n       # Number to test
    n = 0
    for (i = 1; i <= 10000; i = i + 1) {
        repeat {
            n = n + 1
        } until (emirp(n))
    }
    call show(n)
    return
end

######### Main entry point #########
call test1
call test2
call test3
stop
end


### 線形判別分析(2値判別)の例
### - Biopsy Data on Breast Cancer Patients

## データの読み込み ("MASS::biopsy"を用いる)
require(MASS) # パッケージの読み込み (lda/biopsy)
require(tidyverse)
require(ggfortify)
require(GGally)
require(plotROC)

## データの内容を表示
help(biopsy)  # 内容の詳細を表示
## print(biopsy) # データの表示
head(biopsy)  # 最初の6個を表示
tail(biopsy)  # 最後の6個を表示

## データの散布図: 図(a)
mydata <- na.omit(biopsy)[-1] # NA，および患者のIDを除く
ggpairs(mydata, lower=list(mapping=aes(colour=class)))
## ## ggscatmat でも似たことはできるが数値データの散布図のみ
## ggscatmat(mydata, color="class", alpha=.8) # colour ではない

## 主成分分析による2次元表示: 図(b)
autoplot(prcomp(mydata[-10]), data=mydata, colour="class") +
    theme(legend.position=c(.9,.9))

## 判別分析 (ランダムに選んだ300個のサンプルで分析)
## set.seed(1234) # 実験の再現性を求める場合
idx <- sample(nrow(mydata),300)
train <- mydata[idx,] # 学習に用いるデータを選択
model <- lda(class ~ .,data=train)
print(model) # モデルの概要を表示

## 線形判別関数の値の分布をクラス毎に表示
predict.tr <- predict(model) # 学習データの予測
res.tr <- data.frame(x=as.vector(predict.tr$x), # 学習データの評価用
                    class=train$class,
                    d=c(benign=0,malignant=1)[train$class])
## 判別関数の値の分布 (学習データ): 図(c)
ggplot(res.tr, aes(x)) + xlim(-3,8) + # 値の範囲を指定
    geom_histogram(aes(fill=class)) +
    facet_grid(class ~ .) + theme(legend.position="none")

## AUC (学習データ): 図(d)
gg <- ggplot(res.tr, aes(m=x, d=d)) + geom_roc(colour="red")
gg + annotate("text", x=.9, y=.1,
              label=paste("AUC =", round(calc_auc(gg)$AUC,3)))

## 上記の結果を用いて残りのサンプルを予測
test <- mydata[-idx,] # 予測対象のデータを選択
predict.te <- predict(model,newdata=test[,-10])
table(true=test$class,est=predict.te$class) # 判別結果を表示

## 線形判別関数の値の分布をクラス毎に表示
res.te <- data.frame(x=as.vector(predict.te$x), # 試験データの評価用
                    class=test$class,
                    d=c(benign=0,malignant=1)[test$class])
## 判別関数の値の分布 (試験データ): 図(e)
ggplot(res.te, aes(x)) + xlim(-3,8) + # 値の範囲を指定
    geom_histogram(aes(fill=class)) +
    facet_grid(class ~ .) + theme(legend.position="none")

## AUC (試験データ): 図(f)
gg <- ggplot(res.te, aes(m=x, d=d)) + geom_roc(colour="red")
gg + annotate("text", x=.9, y=.1,
              label=paste("AUC =", round(calc_auc(gg)$AUC,3)))


library(astsa)

# read data to R variable
birth.data<-read.csv("daily-total-female-births-in-cal.csv")

# pull out number of births column
number_of_births<-birth.data$Daily.total.female.births.in.California..1959

# use date format for dates
birth.data$Date <- as.Date(birth.data$Date, "%m/%d/%Y")

plot.ts(number_of_births,main='Daily total female births in california, 1959', ylab = 'Number of births')

# Test for correlation
Box.test(number_of_births, lag = log(length(number_of_births)))

# Plot the differenced data
plot.ts(diff(number_of_births), main='Differenced series', ylab = '')

# Test for correlation in the differenced data
Box.test(diff(number_of_births), lag = log(length(diff(number_of_births))))

# acf and pacf of the differenced data

acf(diff(number_of_births), main='ACF of differenced data', 50)
pacf(diff(number_of_births), main='PACF of differenced data', 50)

# Fit various ARIMA models

model1<-arima(number_of_births, order=c(0,1,1))
SSE1<-sum(model1$residuals^2)
model1.test<-Box.test(model1$residuals, lag = log(length(model1$residuals)))

model2<-arima(number_of_births, order=c(0,1,2))
SSE2<-sum(model2$residuals^2)
model2.test<-Box.test(model2$residuals, lag = log(length(model2$residuals)))

model3<-arima(number_of_births, order=c(7,1,1))
SSE3<-sum(model3$residuals^2)
model3.test<-Box.test(model3$residuals, lag = log(length(model3$residuals)))

model4<-arima(number_of_births, order=c(7,1,2))
SSE4<-sum(model4$residuals^2)
model4.test<-Box.test(model4$residuals, lag = log(length(model4$residuals)))

df<-data.frame(row.names=c('AIC', 'SSE', 'p-value'), c(model1$aic, SSE1, model1.test$p.value),
               c(model2$aic, SSE2, model2.test$p.value), c(model3$aic, SSE3, model3.test$p.value),
               c(model4$aic, SSE4, model4.test$p.value))
colnames(df)<-c('Arima(0,1,1)','Arima(0,1,2)', 'Arima(7,1,1)', 'Arima(7,1,2)')

format(df, scientific=FALSE)

# Fit a SARIMA model

sarima(number_of_births, 0,1,2,0,0,0)


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

rm(list = ls())

observed <- c(9, 11, 4, 6)

(k <- length(observed))
# 4

(n <- sum(observed))
# 30

## test F(x) is poisson(lambda)

LogLikelihood <- function(lambda, y, k) {
  (sum(y[1:(k - 1)] * dpois(0:(k - 2), lambda = lambda, log = TRUE)) +
    y[k] * ppois(k - 2, lambda = lambda, lower.tail = FALSE, log = TRUE))
}

NegativeLogLikelihood <- function(...) {
  - LogLikelihood(...)
}

opt <- optim(1, NegativeLogLikelihood, y = observed, k = k,
             lower = 10e-4, method = 'L-BFGS-B')

(lambda.hat <- opt$par)
# 1.31334181246836

(expected1 <- n * c(dpois(0:(k-2), lambda = lambda.hat), 1 - ppois(k - 2, lambda = lambda.hat)))
# 8.06759619945891 10.5955114148602 6.9577640828109 4.37912830286995

(Q1 <- sum((observed - expected1) ^ 2 / expected1))
# 1.98049899014501

1 - pchisq(Q1, df = (k - 1) - 1)
# 0.371483996032531

## test F(x) is poisson(1.2)
(expected2 <- n * c(dpois(0:(k-2), lambda = 1.2), 1 - ppois(k - 2, lambda = 1.2)))
# 9.03582635736606 10.8429916288393 6.50579497730357 3.61538703649109

(Q2 <- sum((observed - expected2) ^ 2 / expected2))
# 2.54038357961436

1 - pchisq(Q2, df = (k - 1))
# 0.468037053437737

## power:

(null <- n * c(dpois(0:(k-2), lambda = 1.2), 1 - ppois(k - 2, lambda = 1.2)))
# 9.03582635736606 10.8429916288393 6.50579497730357 3.61538703649109

(alternative <- n * c(dnbinom(0:(k-2),size = 2, prob = 2 / 3), 1 - pnbinom(k - 2,size = 2, prob = 2 / 3)))
# 13.3333333333333 8.88888888888889 4.44444444444445 3.33333333333333

(Q <- sum((alternative - null) ^ 2 / alternative))
# 2.79465432822941

(power <- 1 - pchisq(qchisq(0.95, df = k - 1), df = k - 1, Q))
# 0.257468163480735

## sample size power >= 0.8

fn <- function(n) {
  null <- n * c(dpois(0:(k-2), lambda = 1.2), 1 - ppois(k - 2, lambda = 1.2))
  alternative <- n * c(dnbinom(0:(k-2),size = 2, prob = 2 / 3), 1 - pnbinom(k - 2,size = 2, prob = 2 / 3))

  Q <- sum((alternative - null) ^ 2 / alternative)
  power <- 1 - pchisq(qchisq(0.95, df = k - 1), df = k - 1, Q)
}

(n.exact <- uniroot(function(n) {fn(n) - 0.8}, c(1, 500))$root)
# 117.036620884611

ceiling(n.exact)
# 118


N <- 1e6
b <- 10

X <- runif(n = N, min = 0, max = b)
Y <- runif(n = N, min = 0, max = b)

U <- (X-b/2)^2
V <- (Y-b/2)^2
W <- U + V

ecc <- ecdf(W)

hist(W)

F_T <- function(t){
  b <- b + 0i
  t <- t + 0i
  Re(
    (b*sqrt(4*t-b^2) - 4*t*atan(sqrt(4*t-b^2)/b) + 2*pi*t)/(2*b^2)
  )
}

r <- runif(1, 0, b/2)
ecc(r^2)
F_T(r^2)
(pi*r^2)/b^2

thN <- sample(1:N, min(1000, N), replace = FALSE)
plot(X[thN], Y[thN], col = as.numeric(W[thN] <= r^2) + 1)
plotrix::draw.circle(x = b/2, y = b/2, radius = r, lwd = 4)

var_delta <- function(A, u, n){
  sapply(A, function(x) {
    x*(u^2-x)/n
  })
}
# var_delta <- Vectorize(var_delta)
uu <- 1
curve(var_delta(x, u = uu, n = 10), 0, pi*uu^2/4, lwd = 3,
      ylab = expression(Var(delta[1])), xlab = expression(A))
curve(var_delta(x, u = uu, n = 30), 0, pi*uu^2/4,
      lty = 2, lwd = 3, add = TRUE)
curve(var_delta(x, u = uu, n = 100), 0, pi*uu^2/4,
      lwd = 3, lty = 4, add = TRUE)
abline(v = uu^2/2, lwd = 2, lty = 5)
legend(x = "topleft",
       legend = c("n=10", "n=30", "n=100"),
       lwd = 2, lty = 1:4, col = 1, bty = 'n')


#install.packages("GA")
library(GA)

# https://cran.r-project.org/web/packages/GA/vignettes/GA.html#constrained-optimisation
  # Simionescu function
# https://en.wikipedia.org/wiki/Test_functions_for_optimization
func3d <- function(x)
{
  0.1*x[1]*x[2]
}

c1 <- function(x)
{
  r_t <- 1
  r_s <- 0.2
  n <- 8
  x[1]^2+x[2]^2-(r_t+r_s*cos(n*atan(x[1]/x[2])))^2
}

x1LBound <- -1.25
x1RBound <- 1.25
x2LBound <- -1.25
x2RBound <- 1.25

ngrid <- 250 # 250
nLevels <- 21
x1 <- seq(x1LBound, x1RBound, length = ngrid)
x2 <- seq(x2LBound, x2RBound, length = ngrid)
x12 <- expand.grid(x1, x2)
col <- adjustcolor(bl2gr.colors(4)[2:3], alpha = 0.2)
plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)

fitness <- function(x)
{
  f <- -func3d(x)                    # we need to maximise -func3d(x)
  pen <- sqrt(.Machine$double.xmax)  # penalty term
  penalty1 <- max(c1(x),0)*pen       # penalisation for 1st inequality constraint
  f - penalty1                       # fitness function value
}

GA <- ga("real-valued", fitness = fitness,
         lower = c(x1LBound, x2LBound), upper = c(x1RBound, x2RBound),
         # selection = GA:::gareal_lsSelection_R,
         maxiter = 10000, run = 1000) # seed = 123)
summary(GA)
plot(GA)

fitness(GA@solution)
func3d(GA@solution)
c1(GA@solution)

plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = nLevels, add = TRUE)
points(GA@solution[1], GA@solution[2], col = "dodgerblue3", pch = 3)  # GA solution


library(rstudioapi)
library(ellipse)
library(ggplot2)
library(readr)
library(psych)
library(nFactors)
library(polycor)
this.dir <- dirname(rstudioapi::getActiveDocumentContext()$path)
setwd(this.dir)

####### 9.28 ##########
e8_18 <- read_delim("e8_18.txt", " ", escape_double = FALSE, trim_ws = TRUE)
nation = e8_18[,1]
X = as.matrix(e8_18[,2:8])
R = cor(X)
S = cov(X)
# Number of Factor for covariance
ev <- eigen(S) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# Number of Factor for correlation
ev <- eigen(R) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

## Unrotated PC Analysis with S
fit1 <- principal(S, nfactors=2, rotate="none",scores = TRUE,covar = TRUE)
fit1

## Varimax Rotation PC Analysis with S
fit2 <- principal(S, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit2

## Unrotated PC Analysis with R
fit3 <- principal(R, nfactors=2, rotate="none",scores = TRUE,covar = TRUE)
fit3
score <- factor.scores(X,fit3)
score$weights
## Varimax Rotation PC Analysis with R
fit4 <- principal(R, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit4
score <- factor.scores(X,fit4)
score$weights
## Outlier
score <- factor.scores(X,fit4)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = RC1, y = RC2)) + geom_point()+ggtitle("Scatterplot of Factor Score of PC")+
  geom_text(aes(label=nation),hjust=0, vjust=0)
## ML Unrotated PC Analysis with R
fit5 <- factanal(X, 2, rotation="none")
fit5
## ML Varimax Rotation PC Analysis with R
fit6 <- factanal(X, 2, rotation="varimax")
fit6
score <- factor.scores(X,fit6)
score$weights
## Outlier
score <- factor.scores(X,fit6)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = Factor1, y = Factor2)) + geom_point()+ggtitle("Scatterplot of Factor Score of Maximum Likelihood")+
  geom_text(aes(label=nation),hjust=0, vjust=0)

####### 9.34 ##########
T7_7 <- read_delim("T7-7.dat", "\t", escape_double = FALSE, col_names = FALSE, trim_ws = TRUE)
X = T7_7[1:62,1:4]
colnames(X) = c("BL","EM","SF","BS")
X = as.matrix(X)
R = cor(X)
S = cov(X)

# Number of Factor for covariance
ev <- eigen(S) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# Number of Factor for correlation
ev <- eigen(R) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)
## Unrotated PC Analysis with S
fit1 <- principal(S, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit1

fit2 <- principal(R, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit2

fit3 <- factanal(X, 1, rotation="none")
fit3

fit4 <- principal(R, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit4
score <- factor.scores(X,fit4)
score$weights
## Outlier
score <- factor.scores(X,fit4)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = RC1, y = RC2)) + geom_point()+ggtitle("Scatterplot of Factor Score of PC")+
  geom_text(aes(label=c(1:62)),hjust=0, vjust=0)

####### 9.35 ##########
X = T7_7[1:62,5:8]
colnames(X) = c("AFL","LFF","FFF","ZST")
X = as.matrix(X)
R = cor(X)
S = cov(X)

# Number of Factor for covariance
ev <- eigen(S) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

# Number of Factor for correlation
ev <- eigen(R) # get eigenvalues
ap <- parallel(subject=nrow(X),var=ncol(X),
               rep=100,cent=.05)
nS <- nScree(x=ev$values, aparallel=ap$eigen$qevpea)
plotnScree(nS)

## Unrotated PC Analysis with S
fit1 <- principal(S, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit1

fit2 <- principal(R, nfactors=1, rotate="none",scores = TRUE,covar = TRUE)
fit2

fit3 <- factanal(X, 1, rotation="none")
fit3

fit4 <- principal(R, nfactors=2, rotate="varimax",scores = TRUE,covar = TRUE)
fit4
score <- factor.scores(X,fit4)
score$weights
## Outlier
score <- factor.scores(X,fit4)
plotscore = as.data.frame(score$scores)
ggplot(data = plotscore, aes(x = RC1, y = RC2)) + geom_point()+ggtitle("Scatterplot of Factor Score of PC")+
  geom_text(aes(label=c(1:62)),hjust=0, vjust=0)