setwd("d:/baidu/tsinghua/courses/quantii/week04")
library(foreign)
dat <- read.dta("./slides/week04/wdi.dta")
summary(dat)
dat <- dat[,c(-1,-2)]

n <- dim(dat)[1]
corMat <- cor(dat, use = "pairwise.complete.obs") #correlation matrix
#covMat <- cov(dat, use = "pairwise.complete.obs") #covariance matrix
#install.packages("corrplot")
library(corrplot)
res <- cor.mtest(dat, conf.level = 0.95)

corrplot(corMat, method = "ellipse", type = "lower", p.mat = res$p, sig.level = 0.05, order = "hclust")

library(psych)
# bartlett test
cortest.bartlett(corMat, n=n)

# bartlett test on raw data
#k <- dim(dat)[2]
#nj <- sapply(apply(dat, 2, na.exclude), length)
#N <- sum(nj)
#s2 <- apply(dat, 2, var, na.rm=TRUE)
#S2 <- sum((nj-1)*s2)/(n-k)
#cc <- 1 + (1/3*(k-1))*(sum(1/(nj-1)) - 1/(N-k))
#B <- ((N-k)*log(S2) - sum((nj-1)*log(s2)))/cc
#pchisq(B, df=k-1, lower.tail=FALSE)

# cronbach alpha
alpha(dat)

#raw_alpha: Cronbach’s α (values �? .7 or .8 indicate good reliability; Kline (1999))
#std.alpha: this should be similar to raw_alpha (we only need the raw alpha though)
#G6: Guttman’s lambda 6 (calculated from the squared multiple correlation or ‘smc�?)
#average_r: average inter-item correlation (this is used to calculate std.alpha)
#mean: scale mean (the mean of the means of all individuals)
#sd: scale sd

dat <- dat[,-5]

kmo <- KMO(dat)
print(kmo)
#0.00 to 0.49 unacceptable.
#0.50 to 0.59 miserable.
#0.60 to 0.69 mediocre.
#0.70 to 0.79 middling.
#0.80 to 0.89 meritorious.
#0.90 to 1.00 marvelous.

# anti-image correlation matrix
print(kmo$Image)
print(cov2cor(solve(corMat)))

#corMat <- cor(dat, use = "pairwise.complete.obs") #correlation matrix

# eigen value
ev <- eigen(corMat)
ev$values # find value > 1
sum(ev$values) # sum of eigenvalue = num of variable

# stats
pcafit <- princomp(~., data=dat, cor=TRUE)
summary(pcafit) # print variance accounted for
loadings(pcafit) # pc loadings
plot(pcafit,type="lines") # scree plot
#pcafit$scores # the principal components
#biplot(pcafit)

library(psych)
fit1 <- principal(dat, nfactors=3, rotate="varimax")
print(fit1, digits=2)

M1 <- factanal(~., data=dat, factors=3, scores="regression") # scores = "bartlett"
M2 <- update(M1, factor=3, roation = "varimax")
M2$uniquenesses
print(M2, digits=2, cutoff=.3, sort=TRUE)
loading <- M2$loadings[,1:2]
scores <- M2$scores

coefs <- solve(cor(dat, use = "pairwise.complete.obs")) %*% M2$loadings
factorScores <- scale(dat) %*% coefs

factorScores <- scale(dat)%*% solve(cor(dat, use="pairwise.complete.obs")) %*% M2$loadings


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(glue)
library(gtools)
library(glmnet)
printf <- defmacro(str, expr = {print(glue(str))})

data = read.csv("tecator.csv", fileEncoding="UTF-8-BOM")
data = as.data.frame(scale(data))
data = data[,-match(c("Sample", "Protein","Moisture"), names(data))]
# Split data in to 50/50 train test sets
n = dim(data)[1]
set.seed(12345)
id = sample(1:n, floor(n*0.5))
data.train = data[id,]

id2 = setdiff(1:n,id)
data.test = data[id2,]

# Linear regression
# Linear regression on Fat, with channels as features
model.regression = lm(Fat ~. ,data = data.train)
summary(model.regression) # to get the quality of the model

data.test.chanels = data.test[,-match(c("Fat"), names(data))]

# Prediction using Linear regression model
prediction.regression <- predict(model.regression, data.test.chanels)

#plot prediction vs test data
plot(prediction.regression, col="blue", ylab = "Fat content", xlab = "sample")
points(data.test$Fat , col="red")
legend("topright", c("predciction ", "test "), fill=c("blue", "red"))
title("prediction for fat using linear regression")

printf("train mean square error for linear regression =
        {mean((model.regression$residuals)^2)}")
printf("test mean square error for linear regression =
        {mean((prediction.regression - data.test$Fat)^2)}")

# GET data for lasso and ridge regressions
y <- data.train$Fat
x <- as.matrix(data.train[,-match(c("Fat"), names(data.train))])

# Lasso Regression
# creating a model using Lasso Regression
model.lasso <- glmnet(x, y, alpha=1)
coef(model.lasso)
plot(model.lasso, xvar="lambda") # larger log lambda -> coefficients go to 0
title("LASSO")
summary(model.lasso)

# find were model only has 3 features
print(predict(model.lasso, type="nonzero"))
printf("log lambda for 3 features = {log(model.lasso$lambda[21])}")

# Ridge Regression
# creating a model using Ridge Regression
model.ridge <- glmnet(x, y, alpha=0)
coef(model.ridge)
plot(model.ridge, xvar="lambda")
title("Ridge")
summary(model.ridge)

# try to find were model only has 3 features > some small value
coef.prediction = predict(model.ridge, type="coef")[-1,] # remove intercept
print(apply(coef.prediction, 2, function(x) {
      100 - length(which(abs(x) < 1e-2)) }))
printf("log lambda for 4 features = {log(model.ridge$lambda[39])}")

# Cross Validation LASSO
# creating a model using cross validation and LASSO
model.lasso.cv <- cv.glmnet(x, y, alpha=1)
plot(model.lasso.cv)
title("LASSO dependace of CV socre on log lambda")
printf("cross validation LASSO, lambda min={model.lasso.cv$lambda.min}")
coef(model.lasso.cv, s="lambda.min")

# GET test data for compare of prediction
y.new <- data.test$Fat
x.new <- as.matrix(data.test[,-match(c("Fat"), names(data.test))])

# Prediction
# using cross validation lasso for prediction on test data
prediction.lasso <- predict(model.lasso.cv, newx = x.new)
preciction.lasso.train <- predict(model.lasso.cv, newx = x)

plot(prediction.lasso, col="blue", ylab = "Fat content", xlab = "sample")
points(data.test$Fat , col="red")
legend("topright", c("predciction ", "test "), fill=c("blue", "red"))
title("prediction for fat using CV.LASSO")

# Mean square error for CV LASSO, how good the model is
printf("train mean square error for CV LASSO = {mean((preciction.lasso.train - y)^2)}")
printf("test mean square error for CV LASSO = {mean((prediction.lasso - y.new)^2)}")


library(lmtest)
library(rpart)

data <- read.csv('../data/anorectic.csv', header = TRUE ,sep = ',')

M <- cor(data)

png(filename='../Images/boxplot.png')
pairs(data)
dev.off()

symnum(M)

acp <- prcomp(data, scale=TRUE)

summary(acp)

png(filename='../Images/Pplot.png')
plot(acp)
dev.off()

biplot(acp)

acp$rotation

data.std <- scale(data)

d <- dist(data.std, method='euclidean')

fit <- hclust(d, method = 'complete')

d2 <- as.dendrogram(fit)

png(filename='../Images/Cluster1.png')
plot(fit)
rect.hclust(fit, k=5, border='red')
dev.off()

png(filename='../Images/Cluster2.png')
plot(fit)
rect.hclust(fit, k=6, border='red')
dev.off()

#kmeans

#este es el que empleamos
data.k1 <- kmeans(data.std, 6)

data.k1

#son de prueba de aca hacia abajo

data.k2 <- kmeans(data.std, 2)

data.k2

data.k4 <- kmeans(data.std, 4)

data.k4

data.k12 <- kmeans(data.std, 12)

data.k12

data.k5 <- kmeans(data.std, 5)

data.k5

plot(data.std, col = data.k1$cluster)

# decision tree

l <- length(data[,1])

sub <- sample(1:l, 2*l/3)

diag.tree <- rpart(diag~. ,data = data[sub,], cp=0.01, maxdepth=3)

summary(diag.tree)

png(filename='../Images/Destition_Tree1.png')
plot(diag.tree)
text(diag.tree, use.n = TRUE, pretty=1, xpd=TRUE)
dev.off()

plotcp(diag.tree)
printcp(diag.tree)

diag.pred <- predict(diag.tree, newdata = data[-sub,], type="vector")

tb <- table(diag.pred, data[-sub,]$diag )

error.rpart <- 1-(sum(diag(tb))/sum(tb))
tb
error.rpart


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


df <- iris

df1 <- subset(iris, Species != "setosa")
table(df1$Species)

hist(df1$Sepal.Length)

library(ggplot2)
ggplot(df1, aes(x = Sepal.Length))+
  geom_histogram(fill = 'white', col = 'black', binwidth = 0.4)+
  facet_grid(Species ~ .)

ggplot(df1, aes(x= Sepal.Length, fill = Species))+
  geom_density(alpha = 0.5)

ggplot(df1, aes(x = Species, Sepal.Length))+geom_boxplot()

shapiro.test(df1$Sepal.Length)

shapiro.test(df1$Sepal.Length[df1$Species == "versicolor"])
shapiro.test(df1$Sepal.Length[df1$Species == "virginica"])

bartlett.test(Sepal.Length ~ Species, df1)

t.test(Sepal.Length ~ Species, df1)

test1 <- t.test(Sepal.Length ~ Species, df1)
str(test1)
test1$p.value

t.test(Sepal.Length ~ Species, df1, var.equal = TRUE)

t.test(df1$Sepal.Length, mu = 8)

t.test(df1$Petal.Length, df1$Petal.Width, paired = T)

# trouble №1
str(ToothGrowth)
View(ToothGrowth)
sub1 <- subset(ToothGrowth, supp == "OJ" & dose == 0.5)
sub2 <-  subset(ToothGrowth, supp == "VC" & dose == 2)

tsub <- t.test(sub2$len, sub1$len)
print(tsub$statistic)

# trouble №2

mydata <- read.csv("lekarstva.csv")
t.test(mydata$Pressure_before, mydata$Pressure_after, paired = TRUE)

t.test(Sepal.Length ~ Species, df1, var.equal = TRUE)

install.packages("Hmisc")

ggplot(df1, aes(x = Species, y = Sepal.Length))+
  stat_summary(fun.data = mean_cl_normal, geom ='errorbar', width = 0.1)+
  stat_summary(fun.y = mean, geom = "point", size = 4)

ggplot(df1, aes(x = Species, y = Sepal.Length))+
  stat_summary(fun.data = mean_cl_normal, geom = "pointrange", size = 2)

?wilcox.test()

test2 <- wilcox.test(Petal.Length~Species, df1)
pv <- test2$p.value

ggplot(df1, aes(Species, Petal.Length))+
  geom_boxplot()

wilcox.test(Petal.Length~Species, df1, mu = 6.267)
pairWtest <- wilcox.test(df1$Petal.Length, df1$Petal.Width, paired = TRUE)

#trouble №3

dd <- read.table("dataset_11504_15.txt")

bartlett.test(dd$V1~dd$V2)

tdd <- t.test(dd$V1~dd$V2, var.equal = FALSE)
tdd$p.value

wdd <- wilcox.test(dd$V1~dd$V2)
wdd$p.value

#trouble №4

dd1 <- read.table("dataset_11504_16.txt")
str(dd1)
t.test(dd1$V1, dd1$V2, var.equal = FALSE)


# 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)


getwd()
dir
dir()
read.csv("hw1_data.csv")
quiz1 <- read.csv("hw1_data.csv")
quiz1
summary(quiz1)
str(quiz1)
x <- c(1,3, 5)
y <- c(3, 2, 10)
cbind(x,y)
x <- list(2, "a", "b", TRUE)
x[[2]]
x <- 1:4
y <- 2
x+y
x <- c(3, 5, 1, 10, 12, 6)
x[x <6] <- 0
x
x <- c(3, 5, 1, 10, 12, 6)
x[x %in% 1:5] <- 0
x
names(quiz1)
head(quiz1,2)
str(quiz1)
tail(quiz1,2)
quiz1[47]
head(quiz1,47)
quiz1$Ozone
quiz1$Ozone[NA]
quiz1$Ozone
sum(is.na(quiz1$zone))
sum(is.na(quiz1$Ozone))
summary(quiz1$Ozone)
tapply(flags$animate, flags$landmass, mean)
tapply(quiz1$Ozone, quiz1$Ozone, mean)
ozoneTemp <- c(quiz1$Ozone, quiz1$Temp)
ozoneTemp
ozoneTemp <- list(quiz1$Ozone, quiz1$Temp)
ozoneTemp
x
x <- quiz1(Ozone >31)
quiz1[[Ozone >31]]
quiz1[[Ozone >31, exact =FALSE]]
quiz1[["Ozone" >31, exact =FALSE]]
quiz1
quiz1[["Ozone" >31, exact =FALSE]]
sapply(quiz1, function(row) row$Ozone >31 )
sapply(quiz1, function(row) Ozone >31 )
sapply(quiz1, function(OZone) Ozone >31 )
sapply(quiz1, function(Ozone) Ozone >31 )
sapply(quiz1, function(value) value >31 )
above31 <- sapply(quiz1, function(value) value >31 )
above90 <- sapply(quiz1, function(value value > 90))
above90 <- sapply(quiz1, function(value) value > 90)
above90
quiz1[!above31]
quiz1
subset(quiz1, OZone >31)
subset(quiz1, Ozone >31)
subset(quiz1, Ozone >31& Temp >90)
ozoneTemp <- subset(quiz1, Ozone >31& Temp >90)
summary(ozoneTemp)
subset(quiz1, Month = 6)
subset(quiz1, Month == 6)
summary(subset(quiz1, Month == 6))
summary(subset(quiz1, Month == 5))
x <- 1:4
y <- 2:3
x+y
x
y
head(quiz2)
head(quiz1)
head(quiz1, 2)
tail(quiz1,2)
quiz1[47]
quiz1$Ozone[47]
is.na(quiz1$Ozone)
sum(is.na(quiz1$Ozone))
mean(!is.na(quiz1$Ozone))
!iz.na(quiz1$Ozone)
!is.na(quiz1$Ozone)
mean(quiz1$Ozone)
good <- complete.cases(quiz1)
good
quiz1[good]
quiz1[good,]
summary(quiz1[good,])
subset(quiz1, Ozone>31)
subset(quiz1, Ozone>31 & Temp  >90)
mean(subset(quiz1, Ozone>31 & Temp  >90))
summary(subset(quiz1, Ozone>31 & Temp  >90))
summary(subset(quiz1, Month == 6))
summary(subset(quiz1, Month == 5))
x <- list(2, "a", "b", TRUE)
class(x)
class( x[[1]])
x[[1]]
x <- 1:4
y <- 2:3
class(x+y)
head(quiz1,2)
tail(quiz1, 2)
quiz1$Ozone[47]
is.na(quiz1$Ozone)
sum(is.na(quiz1$Ozone))
good <- complete.cases(quiz1)
quiz1[good,]
nrows(quiz1[good,])
str(quiz1[good,])
mean(quiz1[good,])
summary(quiz1[good,])
subset(quiz1, Ozone>31 & Temp>90)
summary(subset(quiz1, Ozone>31 & Temp>90))
summary(subset(quiz1, Month == 6))
summary(subset(quiz1, Month == 5))


# <-- 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


install.packages("readxl")
library("readxl")
setwd("C:/Users/dimit/Desktop/Ergasia_Statistikis")
data1 <- read_excel("ergasia_12/ergasia_12.xls")
head(data1)

g1diff <- data1$night[data1$group==1] - data1$day[data1$group==1]
g2diff <- data1$night[data1$group==2] - data1$day[data1$group==2]

shapiro.test(g1diff)
shapiro.test(g2diff)

num <- 625
set.seed(num)

xsim <- rnorm(50)
ysim <- rt(50, df=3)
zsim <- rt(50, df=10)

shapiro.test(xsim)
shapiro.test(ysim)
shapiro.test(zsim)

t.test(g1diff,g2diff,var.equal=FALSE,conf.level = 0.95)

t.test(g1diff,g2diff,var.equal=FALSE,conf.level = 0.95,alternative="greater")
t.test(g1diff,g2diff,var.equal=FALSE,conf.level = 0.95,alternative="less")

logx <- log(data1$night[data1$group==1] / data1$day[data1$group==1])
logy <- log(data1$night[data1$group==2] / data1$day[data1$group==2])

shapiro.test(logx)
shapiro.test(logy)

t.test(logx,logy,var.equal=FALSE,conf.level = 0.95)

t.test(logx,logy,var.equal=FALSE,conf.level = 0.95,alternative="greater")


RMS = function(x){
 sqrt(mean(x^2))
}


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)


setwd ("c://R")
SeedData=read.csv ("seeds_dataset.csv", header=TRUE,sep="")
str(SeedData)

names(SeedData) = c('Area', 'Perimeter', 'Compactness', 'LengthK',
  'WidthK','AsymCoef','LengthKG','Seeds')
summary(SeedData)

pairs(SeedData[1:7], cex.axis=0.4,pch=16,cex=0.3,cex.labels = 0.6,tck=-0.1)

R<-cor(SeedData[1:7])
R

PCAObj<-prcomp(SeedData[1:7])
print(PCAObj)

plot(PCAObj, type= "l",cex.axis=0.6,cex.main=0.6,cex.lab=0.6)

SumPCAObj<-summary(PCAObj)

barplot(SumPCAObj$importance[2,])
ScreePlot <- barplot(SumPCAObj$importance[2,]*100,ylim = c(0, 110))
lines(x = ScreePlot, y = SumPCAObj$importance[3,]*100)
points(x = ScreePlot, y = SumPCAObj$importance[3,]*100)

biplot(PCAObj,scale=0, cex=0.6,cex.axis=0.6,cex.lab=0.6)


## 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


library(RUnit)
errMsg <- function(err) print(err)
load('ex1-tests.rda')

# Suppose that you are given some dataset where all variables are
# numeric. Further, assume that you consider a given variable for some
# observation to be an outlier if it is more than 1.5 IQRs from that variable's
# median value. Implement the function "outlierCutoff" that determines the
# min and max value that is not considered an outlier for each variable. your
# function should take the following arguments:
#
# <data>: a data frame consisting of only numeric variables
#
# Your function should return the following:
#
# <outlier.cutoffs>: a 2xnumber.variables matrix giving the lower and upper
# bound for non-outlier values. The first row should be the lower bound and the
# second the upper bound

outlierCutoff <- function(data) {
    # your code here

    outlier.cutoffs <- sapply(data, function(var) {
          var.iqr <- IQR(var)
          cutoff.min <- median(var) - 1.5 * var.iqr
          cutoff.max <- median(var) + 1.5 * var.iqr
          return(c(cutoff.min, cutoff.max))
      })

    return(outlier.cutoffs)
}

tryCatch(checkIdentical(outlier.cutoff.t, outlierCutoff(ex1.test)),
         error=function(err) errMsg(err))

# Again, suppose that you are given some dataset where all variables are numeric
# Further, assume that you are interested in removing outliers as defined in the
# previous part
# Implement a function "removeOutliers" that
# 1) caclulates the number of variables for each observation in the dataset that
# are considered outliers
# 2) removes any observation with more than some specified fraction of its
# variables as outliers. Your function should take the following arguments:
#
# <data>: a data frame where each variable is numeric
# <max.outlier.rate>: a numeric between 0 and 1 specifying the maximum allowable
# fraction of outliers (#outlier.variables / #variables)
#
# Your function should return the follwing:
#

# <subset.data>: a data frame with numeric variables where observations with
# unacceptably high rates of outliers (i.e. greater than <max.outliers>) have
# been removed.

removeOutliers <- function(data, max.outlier.rate) {

    stopifnot(max.outlier.rate>=0 & max.outlier.rate<=1)

    # your code here
    outlier.cutoffs <- outlierCutoff(data)
    high.outliers <- mapply(function(var, cutoff) var > cutoff, data,
                            outlier.cutoffs[2, ])
    low.outliers <- mapply(function(var, cutoff) var < cutoff, data,
                           outlier.cutoffs[1, ])
    outliers <- high.outliers + low.outliers
    num.outliers <- rowSums(outliers)
    removed.idcs <- num.outliers/ncol(data) > max.outlier.rate
    return(data[!removed.idcs, ])
}

tryCatch(checkIdentical(remove.outlier.t, removeOutliers(ex1.test, 0.25)),
         error=function(err) errMsg(err))

#remove.outlier.t.2 = removeOutliers(ex1.test, 0.10)
#save(ex1.test, outlier.cutoff.t, remove.outlier.t, remove.outlier.t.2, file="ex1-tests2.rda")


#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!!


# Kevin P. Keegan - all rights reserved - 11-12-12
# function to perform log2 transformation and standardization persample,
# followed by linear scaling accross all samples
norm_center_scale <<- function(matrix_in) # end inputarguments
{

  if ( nargs() == 0 ){
     writeLines("
     You supplied no arguments

     DESCRIPTION: (norm_center_scale.r):
     This is a script to perform the standard MG-RAST normalization on a matrix.  It assumes that
     columns are samples, and rows are observations (taxa or function counts). This analysis has
     3 steps:
     - All values are transformed with Log2
     - Transformed values within each sample (column) are standardized - values exhibit a mean of 0 and
       standard deviation of 1 after this procedure
     - All values transformed and standardized values, across the whole matrix, are scaled from
       min:max to 0:1

     USAGE:
     my_matrix.norm-stand-scale <- norm_center_scale(my_matrix)

     where my_matrix is an R matrix

     )
     "
                )
   }

###### replace NA's with 0
  matrix_in[ is.na(matrix_in) ]<-0

###### get the diensions of the input object
  number_entries = (dim(matrix_in)[1]) # number rows
  number_samples = (dim(matrix_in)[2]) # number columns

###### perform log transformation
  log2_data = log2(matrix_in + 1)

###### create object to store data that are log transformed and centered
  log2_cent_data <<- matrix(0, number_entries, number_samples)

###### pull column and row names from the input_data
  dimnames(log2_cent_data)[[2]] <<- dimnames(matrix_in)[[2]] # colnames #edited 6-15-10
  dimnames(log2_cent_data)[[1]] <<- dimnames(matrix_in)[[1]] # rownames #edited 6-15-10

###### center data from each sample (column)
  for (i in 1:number_samples){
    sample = log2_data[,i]
    mean_sample = mean(sample)
    stdev_sample = sd(sample)
    for (j in 1:number_entries){
      log2_cent_data[j,i] <<- ((log2_data[j,i] - mean_sample)/stdev_sample)
    }
  }

###### scale values from 0 to 1
  min_value = min(log2_cent_data)
  max_value = max(log2_cent_data)
  for (i in 1:number_samples){
    for (j in 1:number_entries){
      log2_cent_data[j,i] <<- (  (log2_cent_data[j,i] + abs(min_value))/(max_value + abs(min_value)))
    }
  }

####### return norm_center_scaled matrix
  return(log2_cent_data)

}

  ## max_value= max(log2_cent_data)
  ## for (i in 1:number_samples){
  ##   for (j in 1:number_entries){
  ##     if (log2_cent_data[j,i] == 0){
  ##     }else{
  ##       log2_cent_data[j,i] <<- ((log2_cent_data[j,i]/max_value))
  ##     }
  ##   }
  ## }

  ## min_value = min(log2_cent_data)
  ## for (i in 1:number_samples){
  ##   for (j in 1:number_entries){
  ##     log2_cent_data[j,i] <<- (log2_cent_data[j,i] + abs(min_value))
  ##   }
  ## }
  ## max_value= max(log2_cent_data)
  ## for (i in 1:number_samples){
  ##   for (j in 1:number_entries){
  ##     if (log2_cent_data[j,i] == 0){
  ##     }else{
  ##       log2_cent_data[j,i] <<- ((log2_cent_data[j,i]/max_value))
  ##     }
  ##   }
  ## }


## 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 = cor(c(15,  12,  8,   8,  7,   7,   7,   6,   5,   3), c(10,  25,  17,  11,  13,  17,  20,  13,  9,   15))
res = format(round(x, 3), nsmall = 3)

physics_scores = c(15,  12,  8,   8,  7,   7,   7,   6,   5,   3)
history_scores = c(10,  25,  17,  11,  13,  17,  20,  13,  9,   15)
dF = data.frame(physics_scores, history_scores)

# http://stackoverflow.com/questions/3443687/formatting-decimal-places-in-r
printDecimal <- function(x, k) cat(format(round(x, k), nsmall=k))

cor.sp = cor(physics_scores, history_scores)
printDecimal(cor.sp, 3)

fit.lin  = lm(history_scores~physics_scores, data = dF)
coef = coef(fit.lin)[2]
printDecimal(coef, 3)

new <- data.frame(physics_scores = 10)
res = predict(fit.lin, newdata = new)
printDecimal(res, 1)

AI/MEDIUM/Correlation and Regression Lines - A Quick Recap/Correlation and Regression Lines - A Quick Recap.r


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)


rm(list = ls())

data(cars, package = "datasets")
plot(cars$speed, cars$dist)
abline(line(cars$speed, cars$dis))

#
# --- 4.1.1 - PLOT ---------------------------------------------------------------
#

plot(cars$speed, cars$dist,
    main = "Diagrama de dispersión",
    xlab = "Distancia de frenado (pies)", ylab = "Velocidad (millas por hora)",
    pch = 21, col = "blue", bg = "cyan", cex = 1.5
)

radio <- 0:10
area <- pi * radio^2
plot(radio, area,
    type = "b", main = "Áreas de círculos en función del radio",
    xlab = "Radio (r)", ylab = expression(Área == pi * r^2), col = "purple", pch = 20
)

class(AirPassengers)
plot(AirPassengers, main = "Una serie temporal")
title(main = "Una serie temporal")

class(ChickWeight$Diet)
plot(ChickWeight$Diet, main = "Un factor")

class(Titanic)
plot(Titanic, main = "Una tabla cruzada con tres factores de clasificación")

#
# --- 4.1.2 - CURVE --------------------------------------------------------------
#

curve(x^3 - 3 * x, -2, 2, ylab = expression(f(x) == x^3 - 3 * x))

curve(dnorm(x, mean = 10, sd = 2), 4, 16,
    ylab = "densidad",
    main = expression(paste("Normal (", mu == 10, ",", sigma == 2, ")"))
)

curve(x^2, -1, 1,
    ylab = "",
    main = expression(paste(
        f(x) == x^2,
        "y", f(x) == x^4,
        sep = " "
    ))
)
curve(x^4, -1, 1, col = 2, add = TRUE)

# --------------------------------------------------------------------------------
# Ejercicio 1

curve(dnorm(x, 0, 1), col = 1, xlim = c(-3, 7), ylim = c(0, 0.8))
curve(dnorm(x, 0, 0.5), add = T, col = 2)
curve(dnorm(x, 3, 1), add = T, col = 3)
title(main = "Funciones de densidad")

#
# --- 4.1.3 SYMBOLS --------------------------------------------------------------
#

n <- 10
set.seed(1)
x <- runif(n)
colores <- rainbow(n)
symbols(1:n, x, circles = x, bg = colores, ylim = c(0, 1.5), xlim = c(0, 11))

#
# --- 4.1.4 AÑADIR ELEMENTOS A GRÁFICO. LOW LEVEL PLOTTING ------------------------
#

# points
set.seed(123)
plot(rnorm(10),
    main = "Cuatro muestras de una Normal estándar",
    pch = 17, ylim = c(-3, 3)
)
points(rnorm(10), pch = 17, col = 2)
points(rnorm(10), pch = 17, col = 3)
points(rnorm(10), pch = 17, col = 4)

# --------------------------------------------------------------------------------
# lines, abline
set.seed(123)
x <- rnorm(10)
plot(x,
    main = "Muestra de una Normal estándar",
    ylim = c(-3, 3), pch = 19
)
lines(x, col = 4, lwd = 2)
abline(h = 0, col = 1)
abline(h = -3, col = 2, lty = 3, lwd = 2)
abline(h = 3, col = 2, lty = 3, lwd = 2)

# --------------------------------------------------------------------------------
# text
plot(x,
    main = "Muestra de una Normal estándar",
    ylim = c(-4, 4), xlim = c(0, 10), pch = 19
)
abline(h = -3, col = 2, lty = 3, lwd = 2)
abline(h = 3, col = 2, lty = 3, lwd = 2)
pr3 <- round(pnorm(-3), 5) # P[X < -3] para X<-N(0,1)
text(5, 3.5, paste0("probabilidad=", pr3), col = 2, pos = 3)
text(0.2, 0, paste0("probabilidad=", 1 - 2 * pr3), pos = 3, srt = 90)
text(5, -3.5, paste0("probabilidad=", pr3), col = 2)

# --------------------------------------------------------------------------------
# Legend
# Eg1
x <- seq(0, 2 * pi, length = 100)
y1 <- cos(x)
y2 <- sin(x)
plot(x, y1,
    type = "l", col = 2, lwd = 3,
    xlab = expression(group("[", list(0, 2 * pi), "]")),
    ylab = "", main = "Seno y Coseno"
)
lines(x, y2, col = 3, lwd = 3, lty = 2)
points(pi, 0, pch = 17, col = 4)
legend(0, -0.5, c("Coseno", "Seno"), col = 2:3, lty = 1:2, lwd = 3)
abline(v = pi, lty = 3)
abline(h = 0, lty = 3)
text(pi, 0, expression(group("(", list(pi, 0), ")")),
    adj = c(0, 0)
)
# Eg2
radio <- seq(0, 5, by = 0.1)
area <- pi * radio^2
perimetro <- 2 * pi * radio
plot(radio, area, type = "o", ylab = "", pch = 19, col = 2)
lines(radio, perimetro, type = "o", pch = 17, col = 4)
legend("topleft",
    legend = c("Área", "Perímetro"),
    lty = 1, pch = c(19, 17), col = c(2, 4), bt = "n"
)

# --------------------------------------------------------------------------------
# Añadir leyenda a gráfica del ejercicio 1

curve(dnorm(x, 0, 1), col = 1, xlim = c(-3, 7), ylim = c(0, 0.8), lwd = 2)
curve(dnorm(x, 0, 0.5), add = T, col = 2, lwd = 2)
curve(dnorm(x, 3, 1), add = T, col = 3, lwd = 2)
title(main = "Funciones de densidad")
legend("topright",
    legend = c("N(0, 1)", "N(0, 0.5)", "N(3, 1)"),
    col = 1:3,
    lty = 1,
    lwd = 2
)
graphics.off()

# --------------------------------------------------------------------------------
# Otras funciones

# Ejemplo con polygon() y segments()
plot(1:9,
    type = "n", xlab = "", ylab = "", axes = FALSE,
    main = "Ejemplos polygon(), segments()"
)
polygon(c(4, 6, 6, 4, NA, 6, 8, 7), c(2, 2, 4, 4, NA, 6, 6, 8),
    density = c(10, 20), angle = c(-45, 45), col = c("red", "darkblue")
)
segments(
    x0 = c(3, 2), y0 = c(6, 7), x1 = c(3, 4), y1 = c(8, 7),
    lwd = 2, col = "green"
)
# Ejemplo con axis() y title()
plot(Orange$circumference, Orange$age,
    xaxt = "n",
    xlab = "", ylab = ""
)
x <- quantile(Orange$circumference, probs = c(0.01, 0.25, 0.5, 0.75, 0.99))
xcm <- x / 10 ## x está en milímetros, xcm en centímetros
axis(1, at = x, labels = round(xcm, 1))
abline(v = x, lty = 3, lwd = 3, col = "lightgray")
title(
    main = "Ejemplo de axis() y grid()",
    sub = "Datos Orange",
    xlab = "x = circunferencia (cm)",
    ylab = "y = edad (días desde 1968/12/31)"
)

#
# --- 4.1.5 OPCIONES. FUNCIÓN `par` -------------------------------------------------
#

par(mfrow = c(2, 2)) # matriz de 2x2 gráficos (se rellenan por filas)
curve(dnorm(x), -3, 3, main = "Gráfico 1: Normal estándar")
curve(dt(x, df = 10), -3, 3, main = "Gráfico 2: t de Student")
curve(dchisq(x, df = 5), 0, 20, main = "Gráfico 3: chi-cuadrado")
curve(df(x, df1 = 20, df2 = 10), 0, 5, main = "Gráfico 4: F de Snedecor")

par(
    mar = c(3.5, 3.5, 2.5, 1.5), oma = c(1, 1, 1, 1), mgp = c(1.5, 0.5, 0),
    cex.axis = 0.8, cex.lab = 0.8, cex.main = 1, col.lab = "blue", bty = "n"
)

par(mfrow = c(2, 2)) # matriz de 2x2 gráficos (se rellenan por filas)
curve(dnorm(x), -3, 3, main = "Gráfico 1: Normal estándar")
curve(dt(x, df = 10), -3, 3, main = "Gráfico 2: t de Student")
curve(dchisq(x, df = 5), 0, 20, main = "Gráfico 3: chi-cuadrado")
curve(df(x, df1 = 20, df2 = 10), 0, 5, main = "Gráfico 4: F de Snedecor")


#
# 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")

}


### クラスタ分析の例
### - おむすびに関するアンケートデータ

## パッケージの読み込み
require(cluster)
require(tidyverse)
require(reshape2)
require(ggfortify)
require(GGally)
require(ggdendro)

## データの読み込み("omusubi.csv"を用いる)
raw <- read.csv(file="data/omusubi.csv",row.names=1)   # データの読み込み
scan(file="data/omusubi.txt",what=character(),sep=";") # データの説明の表示

## データの内容を表示
## print(raw)    # 全データの表示
head(raw,n=4) # 最初の4県を表示
tail(raw,n=4) # 最後の4県を表示

## 1つだと処理が難しいので北海道は東北に含める
areaname <- c("tohoku","kanto","chubu",
              "kinki","chugoku","chikoku","kyushu")
area <- rep(areaname,c(7,7,9,7,5,4,8))
## データの散布図: 図(a)
ggpairs(data.frame(raw,area),
        columns=1:ncol(raw), mapping=aes(colour=area)) +
    labs(title="おむすびの具 県別人気アンケート (2009)") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 県別の人気比率: 図(b)
mydata <- mutate(raw,perfecture=rownames(raw)) %>%
    melt(id.vars="perfecture")
ggplot(mydata,aes(x=perfecture,y=value,fill=variable)) +
    geom_bar(stat="identity",position="fill") + coord_flip() +
    scale_x_discrete(limits=rev(rownames(raw))) +
    labs(title="おむすびの具 県別人気アンケート (2009)",
         x="県名",y="人気比率") +
    theme(legend.position="top",
          text=element_text(family="HiraMaruProN-W4"))

## 距離計算
dst <- daisy(sqrt(raw)) # Hellinger距離
## その他の距離の計算方法の例
## dst <- dist(raw) # ユークリッド距離
## dst <- daisy(raw) # ユークリッド距離 (cluster package の距離)
## dst <- daisy(raw,stand=TRUE) # ユークリッド距離
## dst <- as.dist(acos(cor(t(raw)))) # 別の距離

## 階層的クラスタリング: 図(c)
hclst <- agnes(dst) # dianaという関数もある
ggdendrogram(as.dendrogram(hclst),
             rotate=TRUE, theme_dendro=FALSE) +
    labs(title="おむすびの具人気アンケートによるクラスタ分析",
         x="県名",y="距離") +
    theme(text=element_text(family="HiraMaruProN-W4"))
## ggdendrogram(as.dendrogram(hclst), rotate=TRUE) # 白地
## バナープロット: 図(d)
plot(hclst, which.plot=1) # banner plot
## plot(hclst, which.plot=2) # dendrogram

## 非階層的クラスタリング (クラスタ数を指定すること)
nhclst <- pam(raw,k=3)
## nhclst <- pam(dst,k=3) # 距離行列を使うこともできる
## nhclst <- clara(rawt,k=3) # claraはデータフレームを使う
## 非階層的クラスタリングによる散布図: 図(e)
autoplot(nhclst, frame=TRUE)
## plot(nhclst, which.plot=1) # 散布図
## シルエットプロット: 図(f)
plot(nhclst, which.plot=2) # silhouette plot
## ## 他の方法でも同様な表示は可能
## autoplot(pam(raw,3), frame=TRUE, frame.type='norm')
## autoplot(clara(raw,3), frame=TRUE, frame.type="norm")
## autoplot(fanny(raw,3), frame=TRUE, frame.type='norm')


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


# setup enviroment
library(tidyverse)

# load data
ds <- diamonds

# scatterplot of price vs x
ggplot(data = ds, aes(y = price, x = x)) +
  geom_point()

# correlations between price and x/y/z
cor.test(ds$price, ds$x)
cor.test(ds$price, ds$y)
cor.test(ds$price, ds$z)

# scatterplot of price vs depth
ggplot(data = ds, aes(y = price, x = depth)) +
  geom_point(alpha = 1/100) +
  scale_x_continuous(breaks = 2)

# correlation between price and depth
cor.test(ds$price, ds$depth)

# scatterpolt between price and carat without top 1%
ggplot(data = ds, aes(y = price, x = carat)) +
  geom_point() +
  scale_x_continuous(limits = c(0, quantile(ds$carat, 0.99))) +
  scale_y_continuous(limits = c(0, quantile(ds$price, 0.99))) +
  labs(title = "Price vs Carat", x = "Carat", y = "Price")

# create volume variable
ds$volume <- (ds$x * ds$y * ds$z)

# scatterplot of price vs volume
ggplot(data = ds, aes(y = price, x = volume)) +
  geom_point()

# correlation between price and volume without diamonds with volume = 0 or >= 800
ds_subset <- subset(ds, volume > 0 & volume < 800)
cor.test(ds_subset$price, ds_subset$volume)

# scatterplot of price vs volume on ds subset
ggplot(data = ds_subset, aes(y = price, x = volume)) +
  geom_point(alpha = 1/100) +
  geom_smooth(method = "lm")

# create new data frame with summary statistics of ds
diamondsByClarity <- ds %>%
  group_by(clarity) %>%
  summarise(mean_price = mean(price),
            median_price = median(price),
            min_price = min(price),
            max_price = max(price),
            n = n())

# create new dataframe by clarity
diamonds_by_clarity <- group_by(ds, clarity)
diamonds_mp_by_clarity <- summarise(diamonds_by_clarity, mean_price = mean(price))

# create new dataframe by color
diamonds_by_color <- group_by(ds, color)
diamonds_mp_by_color <- summarise(diamonds_by_color, mean_price = mean(price))

# barplots of mean diamond prices by clarity and color
bp_by_clarity <- ggplot(data = diamonds_mp_by_clarity, aes(x = clarity, y = mean_price)) + geom_boxplot()
bp_by_color <- ggplot(data = diamonds_mp_by_color, aes(x = color, y = mean_price)) + geom_boxplot()

# display barplots on single canvas
library(gridExtra)
grid.arrange(bp_by_clarity, bp_by_color)

# work with gapminder data
gm <- readxl::read_excel("./lesson3/gapminder.xlsx")


# Refer my jupyter notebook for more details:
# http://nbviewer.jupyter.org/github/ajhalthor/statistical-learning-with-R/blob/master/Chapter%202/notebooks/question%2010.ipynb

library(MASS)
head(Boston)
# ?Boston for information

dim(Boston)

pairs(Boston)

corr_matrix = cor(Boston, method="pearson") # Generate Correlation Matrix
corr_matrix

#heatmap(corr_matrix, col=heat.colors(256))

hist(Boston$crim, breaks=20, xlab="Crime Rate", main="Histogram of Crime Rates")

hist(Boston$tax, breaks=20, xlab="Tax Rate", main="Histogram of Tax Rates")

hist(Boston$ptratio, breaks=20, xlab="Pupil Teacher Ratio", main="Histogram of Pupil Teacher Ratios")

length(Boston$ptratio[20 < Boston$ptratio & Boston$ptratio < 20.5])

length(Boston$chas[Boston$chas == 1])

median(Boston$ptratio)

index = which.min(Boston$medv) #Get index  minimum medv
Boston[index,] #Access this row.

percentile = ecdf(Boston$crim) #ecdf takes a vector and returns function for computing percentile.
print(paste("Crime Rate = ", percentile(Boston[index,'crim'])))#We can now compute the "percentile" of a value

fields = names(Boston)
for (field in 1:length(fields)){
    percentile = ecdf(Boston[[field]])
    print(paste(fields[field], " = ", percentile(Boston[index,'crim'])))
}

length(Boston$rm[Boston$rm > 7])

length(Boston$rm[Boston$rm > 8])

Boston[Boston$rm > 8,]

summary( Boston[Boston$rm > 8,] )

summary(Boston)


# 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


data <- read.csv("pima-indians-diabetes.csv")

colnames(data) <- c(
  "npregnant", "pgc", "dbp",
  "tst","insulin","bmi",
  "dpf","age","diabetes"
)

par(mfrow= c(1,1))

#Plot the data
plot(x = data$pgc, y = data$age,
     pch = 16, col = data$diabetes+1,
     xlab = "Plasma glucose concentration",
     ylab = "Age", main = "Pgc vs Age")
legend("topleft",
       inset = 0.05, title="Diabetes",
       c("Diabetes", "Not Diabetes"),
       pch = 16, col = c(2,1))

set.seed(12345)
n=dim(data)[1]
id=sample(1:n, floor(n*0.7))
train=data[id,]
test=data[-id,]

# create model
model = glm(diabetes ~ age + pgc, data=train, family = "binomial")
probabilities <- predict(model,test, type = "response");
r <- 0.5
predictions = ifelse(probabilities > r, 1, 0)

missclassificationerror = 1-sum(predictions == test$diabetes)/length(test$diabetes)
sprintf("Missclassification error: %f", missclassificationerror)

x1 = test$pgc
x2 = test$age

plot(x = x1,
     y = x2,
     pch = ifelse(predictions == test$diabetes, 16,4),
     col = predictions + 1, xlab = "Plasma glucose concentration",
     ylab = "Age", main = "Prediction Diabetes ~ Pgc + Age")

legend("topleft",
       inset = 0.05,
       title="Prediction",
       c("Diabetes correctly","Not diabetes correctly",
         "Diabetes incorrectly", "Not diabetes incorrectly"),
       pch = c(16,16,4,4),
       col = c(2,1,2,1))

bound = coef(model)

slope = -bound[3]/bound[2]
intercept = -bound[1]/bound[2]

plot(x = x1,
     y = x2,
     pch = ifelse(predictions == test$diabetes, 16,4),
     col = predictions + 1,
     xlab = "Plasma glucose concentration",
     ylab = "Age",
     main = "Prediction Diabetes ~ Pgc + Age")

legend("topleft",
       inset = 0.05,
       title="Prediction",
       c("Diabetes correctly","Not diabetes correctly",
         "Diabetes incorrectly", "Not diabetes incorrectly"),
       pch = c(16,16,4,4), col = c(2,1,2,1))

lines(x = 0:300,
      y = intercept + (0:300 * slope),
      type = "l", lty = 1, col = 4, lwd = 3)

r <- 0.2
predictions.2 = ifelse(probabilities > r, 1, 0)

# Threshold 0.8
r <- 0.8
predictions.8 = ifelse(probabilities > r, 1, 0)

# Plot the graphs
par(mfrow= c(1,2))
plot(x = x1,
     y = x2,
     pch = ifelse(predictions.2 == test$diabetes, 16,4),
     col = predictions.2 + 1,
     xlab = "Plasma glucose concentration",
     ylab = "Age", main = "Threshold 0.2")
plot(x = x1, y = x2,
     pch = ifelse(predictions.8 == test$diabetes, 16,4),
     col = predictions.8 + 1,
     xlab = "Plasma glucose concentration",
     ylab = "Age", main = "Threshold 0.8")

new.train = data.frame(y = train$diabetes,
                       x1 = train$pgc,
                       x2 = train$age)

new.train$z1 = new.train$x1 ^ 4
new.train$z2 = new.train$x1 ^ 3 * new.train$x2
new.train$z3 = new.train$x1 ^ 2 * new.train$x2 ^ 2
new.train$z4 = new.train$x1 * new.train$x2 ^ 3
new.train$z4 = new.train$x2 ^ 4

# Train the model
new.model = glm(y ~ ., data=new.train, family = "binomial")

# Prepare new testing data
new.test= data.frame(y  = test$diabetes,
                     x1 = test$pgc, x2 = test$age)
new.test$z1 = new.test$x1 ^ 4
new.test$z2 = new.test$x1 ^ 3 * new.test$x2
new.test$z3 = new.test$x1 ^ 2 * new.test$x2 ^ 2
new.test$z4 = new.test$x1 * new.test$x2 ^ 3
new.test$z4 = new.test$x2 ^ 4

new.probabilities <- predict(new.model,new.test, type = "response");
r <- 0.5
new.predictions = ifelse(new.probabilities > r, 1, 0)

par(mfrow= c(1,1))
plot(x = new.test$x1,
     y = new.test$x2,
     pch = ifelse(new.predictions == new.test$y, 16,4),
     col = new.predictions + 1,
     xlab = "Plasma glucose concentration",
     ylab = "Age",
     main = "Prediction Diabetes ~ Pgc + Age, r =.2")

legend("topleft", inset = 0.05, title="Prediction",
       c("Diabetes correctly","Not diabetes correctly",
         "Diabetes incorrectly", "Not diabetes incorrectly"),
       pch = c(16,16,4,4),
       col = c(2,1,2,1))

# Print missclassifaicationerror
new.missclassificationerror = 1-sum(new.predictions == new.test$y)/length(new.test$y)
sprintf("New missclassification error: %f", new.missclassificationerror)