# Selecting seed to be reproducible
set.seed(42)

# "best" predictor/algorithm
# One can try to modify the denominator inside the cosine to change the complexity of f*
f = function(x){
  y=2+x^(.2)*cos(x/.15)/x^-.45
  return(y)
}
plot(f,0,5)

# Simulating data points: change n and sigma
N=400
#sigma=1.2
sigma=2.0
x=runif(N,0,5); x=sort(x)  # For convenience, the input x is sorted
y=rep(0,times=N)
for (i in 1:N) {
  y[i] = f(x[i]) + rnorm(1,0,sigma)  # rnorm(size, mean, std)
}
plot(x,y)
points(x,f(x), type="l", col=2, lwd=2)

# k-neighbors estimator
# k is number of neighbors and test=TRUE/FALSE tells if you estimate
# over any grid (FALSE) or over the x sampled in test data set (TRUE)
kn = function(k, test){
  if (test=="FALSE") {
    z = seq(0, 5, by=0.01)
    ll = length(z)
  }
  if (test=="TRUE"){
    z = x_test
    ll = length(z)
  }
  nk = rep(0, times=ll)
  for (j in 1:ll) {
    veci = which(abs(z[j]-x_train) %in% sort(abs(z[j]-x_train))[1:k])
    nk[j] = sum(y_train[veci])/k
  }
  return(nk)
}

# Sampling data between train and test
indices = sample(c(1:N), size=300)  # getting indices randmonly
x_train = x[indices]
y_train = y[indices]
x_test = x[-indices]
y_test = y[-indices]

# Plotting train and test data in same figure
plot(x_train, y_train)
points(x_test, y_test, col=2, pch=4)

# MSE computation (test data)
klist = 1:200  # List of k to test
MSE = rep(0, times=length(klist))  # I make a zeroes array with length of ksize to store MSEs
for (ki in klist) {
  y_pred = kn(ki, "TRUE")
  MSEi = mean(sum((y_test - y_pred)^2))
  MSE[ki] = MSEi
}

# Getting best k from MSE
plot(klist, MSE, xlab="k", ylab="MSE", main="MSE as a function of k")
kbest = which.min(MSE)
points(kbest, MSE[kbest], col=2, pch=8, cex=3.0)

# plot for N=600
plot(klist, MSE, xlab="k", ylab="MSE", main="MSE as a function of k (n=600)")

# Plotting best estimator
plot(x,y)
points(x, f(x), type="l", col=2, lwd=2)
points(x_test, kn(kbest,"TRUE"), type="l", col=3, lwd=2)

####### CROSS VALIDATION (4.3) #######

# k-fold cross validation
folds = 10  # ex. folds=10 means 10-fold CV
fold_size = N/10

klist = 1:200  # List of k to test
MSE_complete = list()  # List to store the MSE list of each k-fold iteration
indices = sample(c(1:N), size=400)  # getting indices randmonly
for (iteration in 1:folds){
  metaindices_test = ((iteration-1)*fold_size+1):(iteration*fold_size)  # Parenthesis are really important to separate :
  ss1 = indices[-metaindices_test] # Choosing indices for train (ss1) and test (ss2)
  ss2 = indices[metaindices_test]
  # choosing partition train/test data
  y_train=y[ss1]
  x_train=x[ss1]
  y_test=y[ss2]
  x_test=x[ss2]
  # Plotting train and test data in same figure
  #plot(x_train, y_train)
  #points(x_test, y_test, col=2, pch=4)
  #browser()  # breakpoint
  # MSE computation (test data)
  MSE = rep(0, times=length(klist))  # I make a zeroes array with length of ksize to store MSEs
  for (ki in klist) {
    y_pred = kn(ki, "TRUE")
    MSEi = mean(sum((y_test - y_pred)^2))
    MSE[ki] = MSEi
  }
  MSE_complete[[iteration]] <- MSE  # Store the MSE for this k in the complete MSE list.
}

# Plotting all MSE curves
for (i in 1:folds) {
  if (i==1){
    plot(klist, MSE_complete[[i]])
  }
  else{
    points(klist, MSE_complete[[i]])
  }
}

# Computing mean MSE curve
MSE_mean_10fold = list()
for (i in klist) {
  sum = 0
  for (j in 1:folds) {
    sum = sum + MSE_complete[[j]][i]
  }
  MSE_mean_10fold[i] <- sum/folds
}
# Plotting mean MSE curve
#points(klist, MSE_mean, col=2)
plot(klist, MSE_mean_10fold, xlab="k", ylab="MSE", main="MSE as a function of k for 10-fold CV")
# Taking the best k from mean MSE curve
kbest_10fold = which.min(MSE_mean_10fold)
points(kbest_10fold, MSE_mean_10fold[kbest_10fold], col=2, pch=8, cex=3.0)

# Plotting best estimator
plot(x,y)
points(x, f(x), type="l", col=2, lwd=2)
# Sorting x_test for plotting
x_test = sort(x_test)
points(x_test, kn(k_best,"TRUE"), col=3, pch=17)

#### Leave-one-out cross-validation ###
for (i in 1:N){
  x_train = x[-i]
  y_train = y[-i]
  x_test = x[i]
  y_test = y[i]
  MSE = rep(0, times=length(klist))  # I make a zeroes array with length of ksize to store MSEs
  for (ki in klist) {
    y_pred = kn(ki, "TRUE")
    MSEi = mean(sum((y_test - y_pred)^2))
    MSE[ki] = MSEi
  }
  MSE_complete[[i]] <- MSE  # Store the MSE for this k in the complete MSE list.
}

# Computing mean MSE curve
MSE_mean_loocv = list()
for (i in klist) {
  sum = 0
  for (j in 1:N) {
    sum = sum + MSE_complete[[j]][i]
  }
  MSE_mean_loocv[i] <- sum/folds
}
# Plot MSE curve
plot(klist, MSE_mean_loocv, xlab="k", ylab="MSE", main="MSE as a function of k for LOOCV")
# Taking the best k from mean MSE curve
kbest_LOOCV = which.min(MSE_mean_loocv)
points(kbest_LOOCV, MSE_mean_loocv[kbest_LOOCV], col=2, pch=8, cex=3.0)

# Plotting both mean_MSE curves
plot(klist, MSE_mean_10fold)
points(klist, MSE_mean_loocv, col=2, pch=4)
# adding legend
legend(150,80, legend=c("10-fold CV", "LOOCV"),
       col=c("black", "red"), lty=1:2, cex=1.0,
       box.lty=0)
### ###

####### END OF CROSS-VALIDATION (4.3) #######

####### EFFECT OF IRREDUCIBLE ERROR 4.4 #######

# Effect of irreducible error sigma^2
# The error is related to the sigma somehow...

# Effect of Irreducible error
# Irreducible error is sigma^2 in y = f(x) + sigma
sigma_list = seq(0.1, 4, by=0.1)  # sigma from 1 to 10 in steps of 0.1
kbest_list_10fold = rep(0, times=length(sigma_list))
kbest_list_loocv = rep(0, times=length(sigma_list))
folds=10
fold_size = N/folds
klist = 1:200

for (si in 1:length(sigma_list)) {
  MSE_complete_kfold = list()  # List to store the MSE list of each k-fold iteration
  MSE_complete_loocv = list()  # List to store the MSE list of each k-fold iteration
  y=rep(0,times=N)
  for (i in 1:N) {
    y[i] = f(x[i]) + rnorm(1,0,sigma_list[si])  # rnorm(size, mean, std)
  }
  indices = sample(c(1:N), size=400)  # getting indices randmonly
  ### KNN ###
  for (iteration in 1:folds){
    metaindices_test = ((iteration-1)*fold_size+1):(iteration*fold_size)  # Parenthesis are really important to separate :
    ss1 = indices[-metaindices_test] # Choosing indices for train (ss1) and test (ss2)
    ss2 = indices[metaindices_test]
    # choosing partition train/test data
    y_train=y[ss1]
    x_train=x[ss1]
    y_test=y[ss2]
    x_test=x[ss2]
    # Plotting train and test data in same figure
    #plot(x_train, y_train)
    #points(x_test, y_test, col=2, pch=4)
    #browser()  # breakpoint
    # MSE computation (test data)
    MSE = rep(0, times=length(klist))  # I make a zeroes array with length of ksize to store MSEs
    for (ki in klist) {
      y_pred = kn(ki, "TRUE")
      MSEi = mean(sum((y_test - y_pred)^2))
      MSE[ki] = MSEi
    }
    MSE_complete_kfold[[iteration]] <- MSE  # Store the MSE for this k in the complete MSE list.
  }
  # Computing mean MSE curve
  MSE_mean_10fold = list()
  for (i in klist) {
    sum = 0
    for (j in 1:folds) {
      sum = sum + MSE_complete_kfold[[j]][i]
    }
    MSE_mean_10fold[i] <- sum/folds
  }
  # Taking the best k from mean MSE curve
  kbest_10fold = which.min(MSE_mean_10fold)
  kbest_list_10fold[si] <- kbest_10fold
  ### ###
  #### Leave-one-out cross-validation ###
  for (i in 1:N){
    x_train = x[-i]
    y_train = y[-i]
    x_test = x[i]
    y_test = y[i]
    MSE = rep(0, times=length(klist))  # I make a zeroes array with length of ksize to store MSEs
    for (ki in klist) {
      y_pred = kn(ki, "TRUE")
      MSEi = mean(sum((y_test - y_pred)^2))
      MSE[ki] = MSEi
    }
    MSE_complete_loocv[[i]] <- MSE  # Store the MSE for this k in the complete MSE list.
  }

  # Computing mean MSE curve
  MSE_mean_loocv = list()
  for (i in klist) {
    sum = 0
    for (j in 1:N) {
      sum = sum + MSE_complete_loocv[[j]][i]
    }
    MSE_mean_loocv[i] <- sum/folds
  }
  kbest_LOOCV = which.min(MSE_mean_loocv)
  kbest_list_loocv[si] <- kbest_LOOCV
  ### ###
}

## Plotting results
plot(sigma_list, kbest_list_10fold, xlab="eps", ylab="k_best", main="Best k as a function of irreducible error.")
points(sigma_list, kbest_list_loocv, col="blue", pch=4)
# adding legend
legend(0.25,30, legend=c("10-fold CV", "LOOCV"),
       col=c("black", "blue"), lty=1:2, cex=1.0,
       box.lty=0)

# Doing a linear fit
lmfit = lm(c(kbest_list_10fold, kbest_list_loocv)~c(sigma_list,sigma_list))
abline(lmfit)
summary(lmfit)

####### END OF EFFECT OF IRREDUCIBLE ERROR 4.4 #######


#Copyright (c) 2016 Riccardo Francescato
a <- c(108,124,124,106,115,138,163,159,134,139)
#confidency level
alpha = .01
#type of test: 0 left tail 1 double tail 2 right tail
type = 2
#calculations....
n0 = length(a)		# number of reps for sample 0
xbar0 = mean(a)		# sample 0 mean
mu = 120			# given  mean
s0 = sd(a)			# sample 0 standard deviation
t = (xbar0−mu)/(s0/sqrt(n0))
if(type == 0){
	t.alpha = qt(1−alpha, df=n0−1)
	pval = pt(t, df=n0−1)
	cat("Results of lower tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nt0: ",t))
	cat(paste("\ntalpha: ",−t.alpha))
	cat(paste("\np-value: ",pval))
	if(t<−t.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}else if(type == 1){
	t.half.alpha = qt(1−alpha/2, df=n0−1)
	pval = 2 * pt(t, df=n0−1)
	cat("Results of 2-tail tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nt0: ",t))
	cat(paste("\ntalpha +: ",t.half.alpha))
	cat(paste("\ntalpha -: ",-t.half.alpha))
	cat(paste("\np-value: ",pval))
	if(t<-t.half.alpha || t>t.half.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")

}else if(type == 2){
	t.alpha = qt(1−alpha, df=n0−1)
	pval = pt(t, df=n0−1, lower.tail=FALSE)
	cat("Results of upper tail\n")
	cat("Sample\n")
	cat(paste("# of elements: ", n0, " Mean: ", xbar0, " St Dev: ",s0))
	cat(paste("\nt0: ",t))
	cat(paste("\ntalpha: ",t.alpha))
	cat(paste("\np-value: ",pval))
	if(t>t.alpha) cat("\nREJECT H0\n") else cat("\nACCEPT H0\n")
}


set.seed(32)

m = 10000
a = 2.0
b = 1.0 / 3.0

theta = rgamma(n=m, shape=a, rate=b)

se = sd(theta) / sqrt(m)

hist(theta, freq=FALSE)
curve(dgamma(x,shape=a, rate=b),col="blue",add=TRUE)

# 2 standard errors
mean(theta) + (2 * se)
mean(theta) - (2 * se)

#indicator
ind = theta < 5
mean(ind)
pgamma(5.0, shape=a, rate=b)

se = sd(ind) / sqrt(m)

2*se


weight <-c (150,180,140,128,133,152,131)
height <-c (62,84,55,52,54,63,53)
model <- lm (height ~ weight)
print (model)

test <- data.frame (weight = 165)
result <- predict (model , test)
print (result)

plot ( weight, height, col = "red", main = "Example of Linear Regression" , abline (lm(height~weight)), cex = 1.3, pch = 16, xlab = "Weight" , ylab = "Height")


#### Suponha que x_1, ..., x_n ~ exponencial(theta)
#### A MLE de theta é theta_hat = n/sum(x)
#### Vamos derivar a distribuição amostral de theta_hat
#### Note que a soma de x_i, S, tem distribuição Gamma com parametros n e theta.
#### Depois note que 1/S tem distribuição gama inversa com parametros n e theta.
#### Por ultimo note que se X tem distribuição gama inversa com parametros a e b.
##### cX tem distribuição gama inversa com parametros a e cb.

library(invgamma)

computa_emv <- function(x){
  1/mean(x)
}

theta.vdd <- 2
M <- 10000
n <- 100

amostras <- matrix(NA, ncol = n, nrow = M)
for (j in 1:M){
  amostras[j, ] <- rexp(n = n, rate = theta.vdd)
}

EMVs <- apply(amostras, 1, computa_emv)

hist(EMVs, probability = TRUE)
curve(invgamma::dinvgamma(x, shape = n, rate = n*theta.vdd),
      min(EMVs), max(EMVs), add = TRUE, lwd = 2)


## simulate two clusters of data
x <- c(rnorm(20,0,1), rnorm(20,4,1))
y <- c(rnorm(20,0,1), rnorm(20,4,1))
X <- cbind(x,y)
ones <- matrix(1, dim(X)[1],1)

## set up some parameters for plotting
xlims <- c(min(x), max(x)) * 1.3
ylims <- c(min(y), max(y)) * 1.3

## plot the data
plot(X, xlim = xlims, ylim = ylims)

## And add some very silly seed points
mu1 <- c(0,6)
mu2 <- c(5,-2)
seed <- list(mu1 = mu1, mu2 = mu2)
points(rbind(seed$mu1, seed$mu2), pch = c(2,3),col = c("red", "black"))
legend("topright", pch = c(1,2,3), col = c("black", "red", "black"), legend = c("Data", "Seed 1", "Seed 2" ), cex = 0.5)
##mtext(paste("Seed points: \n Group 1 ", formatC(seed[[1]],2), "Group 2 ", formatC(seed[[2]],2)))

seed <- step(X, seed$mu1, seed$mu2)
seed <- step(X, seed$mu1, seed$mu2)
seed <- step(X, seed$mu1, seed$mu2)

step <- function(X, mu1, mu2){
## classify according to current seed point (expectation step)
one <- sqrt(rowSums((X - t(t(t(mu1)) %*% t(ones)))^2))
two <- sqrt(rowSums((X - t(t(t(mu2)) %*% t(ones)))^2))
plot(x,y, col = 1 + as.numeric(one < two), pch = 16, xlim = xlims, ylim = ylims )
legend("topright", pch = c(16,16,2,3), col = c("red", "black"), legend = c("Group1", "Group2", "Seed 1", "Seed 2" ), cex = 0.5)
points(rbind(seed$mu1, seed$mu2), pch = c(2,3), col = c("red", "black"))
fixed <- (mu1 + mu2)/2
slope <- -(mu1[1] - mu2[1])/(mu1[2] - mu2[2])
abline(c(fixed[2] - slope * fixed[1], slope))

## calculate new seed points (maximisation step)
mu1 <- colMeans(X[one < two,])
mu2 <- colMeans(X[one >= two,])
return(seed = list(mu1 = mu1, mu2 = mu2))
}

perp <- function(x, y) {
   m <- (x+y)/2
   s <- - (x[1] - y[1])/(x[2] - y[2])
   abline(c(m[2] - s*m[1], s))
   invisible()
}


# Make a sequence of 100 x-values going from -4*sigma to 4*sigma
xvals <- seq(from = -4*sigma, to = 4*sigma, length.out = 100)

# Compute the density of a N(mu, sigma^2) distribution at xvals
ndens <- dnorm(xvals, mean = mu, sd = sigma)

# Plot ndens against xvals
plot(xvals, ndens, type="l")

# Compute the 99% VaR and 99% ES of a N(mu, sigma^2) distribution
VaR99 <- qnorm(0.99, mean = mu, sd = sigma)
ES99 <- ESnorm(0.99, mu = mu, sd = sigma)

# Draw vertical lines at VaR99 and ES99 in red and green
abline(v = VaR99, col = "red")
abline(v = ES99, col = "green")

# Plot the risk-factor data
plot.zoo(riskfactors)

# Calculate the log-returns, assign to returns, and plot
returns <- diff(log(riskfactors))[-1, ]
plot.zoo(returns)

# Use apply() to carry out the Jarque-Bera test for all 5 series
apply(returns, 2, jarque.test)

# Make a Q-Q plot against normal for the 5th return series and add a reference line
qqnorm(returns[, 5])
qqline(returns[, 5])

# Make a picture of the sample acfs for returns and their absolute values
acf(returns)
acf(abs(returns))

# Calculate the loss from a log-return of -0.1 for all risk factors
lossop(rep(-0.1, 5))

# Apply lossop() to returns and plot hslosses
hslosses <- lossop(returns)
plot(hslosses)

# Form a Q-Q plot of hslosses against normal
qqnorm(hslosses)

# Plot the sample acf of hslosses and their absolute values
acf(hslosses)
acf(abs(hslosses))

# Estimate the 99th sample percentile of the distribution of hslosses
quantile(hslosses, 0.99)

# Estimate the 99% ES
mean(hslosses[hslosses >= quantile(hslosses, 0.99)])

# Estimate the mean and standard deviation of hslosses
mu <- mean(hslosses)
sigma <- sd(hslosses)

# Compute the 99% quantile of a normal distribution
qnorm(0.99, mean = mu, sd = sigma)

# Compute the 99% ES of a normal distribution
ESnorm(0.99, mu = mu, sd = sigma)


phi = (1+sqrt(5))/2
N = 501
a = (3-sqrt(5))*pi
n = 0:(N-1)
th = n*a
r = sqrt(n)

x = r*cos(th)
y = r*sin(th)
plot(x,y,asp = 1)

thc = seq(0,10*2*pi,length.out = 1000)
rc = sqrt(1/a)*sqrt(thc)
plot(rc*cos(thc),rc*sin(thc),col = "red",asp = 1,type = 'l')
points(x,y)
w = 3
points(x[seq(1,N,w)],y[seq(1,N,w)],col = "green")

fibo = function(n){
  a = c(1,1,rep(0,n-2))
  for(i in 3:n){
    a[i] = a[i-1]+a[i-2]
  }
  return(a)
}

s = fibo(50)

fb = 10#s[6]
#colors = brewer.pal(fb,"Paired")
colors = hsv(seq(0,1,length.out = fb+1),1,1)
plot(x,y,asp = 1)
z = sapply(1:fb,function(s){
  points(x[seq(s,N,fb)],y[seq(s,N,fb)],col = colors[s])
  lines(x[seq(s,N,fb)],y[seq(s,N,fb)],col = colors[s])})

q = sapply(5:25,function(fb){
#fb = 10#s[6]
#colors = brewer.pal(fb,"Paired")
colors = hsv(seq(0,1,length.out = fb+1),1,1)
plot(x,y,asp = 1)
z = sapply(1:fb,function(s){
  points(x[seq(s,N,fb)],y[seq(s,N,fb)],col = colors[s])
  lines(x[seq(s,N,fb)],y[seq(s,N,fb)],col = colors[s])})
})

ss = s[7:10]
plot(x,y,asp = 1)
colors = hsv(seq(0,1,length.out = length(ss)+1),1,1)
q = sapply(ss,function(fb){
  z = sapply(1:fb,function(s){
    lines(x[seq(s,N,fb)],y[seq(s,N,fb)],col = colors[ss == fb])})
})

library(tidyverse)
ds = data.frame(x = x, y= y)
ds$n = seq(1,length(x))

k = s[9]
ds$fb = factor(ds$n %% k)
colors = hsv(seq(0,1,length.out = k + 1),1,1)
ds$colors = factor(colors[ds$fb])

p = ggplot(ds) + geom_path(aes(x = x, y = y,color = colors))+ theme(legend.position = "none")+
 # geom_text(data = ds %>% filter(n <= k ),aes(x = x, y = y, label = n))+
  coord_fixed()+scale_color_manual(values = levels(ds$colors))#+theme_void()
print(p)

k = s[5]
ds$fb = factor(ds$n %% k)
colors = hsv(seq(0,1,length.out = k + 1),1,1)
ds$colors = factor(colors[ds$fb])

p = ggplot(ds) + geom_path(aes(x = x, y = y,color = fb),size = 0.2)+ theme(legend.position = "none")+
  # geom_text(data = ds %>% filter(n <= k ),aes(x = x, y = y, label = n))+
  coord_fixed()+scale_color_manual(values = levels(ds$colors))#+theme_void()
print(p)

fseq= 1:30
z = sapply(ds$n,function(x) x %% fseq) %>% t()  #%>% add_column(x = x, y = y)
colnames(z) = paste0("fn_",fseq)
z = as.data.frame(z)
dm = data.frame(x = x, y = y, n = 1:length(x),z)
tdm = gather(dm,key = "fn",value = "track",starts_with("fn"))
tdm$ff = as.numeric(sub("fn_","",tdm$fn))
tdm$colors = hsv(h = tdm$track/(tdm$ff+1))

tdm$fn = factor(tdm$fn,levels = paste0("fn_",fseq))
#tdm$track = factor(tdm$track )
p = ggplot(data = tdm) + geom_path(aes(x = x,y = y, color = colors),size = 0.2)+facet_wrap(~fn) +
      coord_fixed()+theme_void()+theme(legend.position = "none")
print(p)

p = ggplot(data = tdm) + geom_point(aes(x = x,y = y, color = colors),size = 0.2)+facet_wrap(~fn) +
  coord_fixed()+theme_void()+theme(legend.position = "none")
print(p)

k = s[9]
ds$fb = factor(ds$n %% k)
colors = hsv(seq(0,1,length.out = k + 1),1,1)
ds$colors = factor(colors[ds$fb])

d0 = data.frame(x = rep(0,k),y = rep(0,k),n = rep(0,k),fb = seq(0,k-1),colors = colors[1:k])

p = ggplot() +geom_path(data = rbind(d0,ds),aes(x = x, y = y,color = colors))+ theme(legend.position = "none")+
        coord_fixed()+scale_color_manual(values =levels(ds$colors))#+theme_void()
print(p)

N = 1501
a = (3-sqrt(5))*pi #137.5/180*pi
n = 0:(N-1)
th = n*a
r = sqrt(n)

x = r*cos(th)
y = r*sin(th)

thc = seq(0,500*2*pi,length.out = 6000)
rc = sqrt(1/a)*sqrt(thc)

w = 55    #34   #21     #13    #8   #5    # 3 #2
l = -1/2584 #1/987#-1/377 #-1/144#1/55#1/21 #1/8#1/3
plot(x,y,asp = 1,col = "gray")
#lines(rc*cos(thc),rc*sin(thc),col = "lightblue")
points(x[seq(1,N,w)],y[seq(1,N,w)],col = "red")
lines(rc*cos(thc*l),-rc*sin(thc*l),col = "black")
print(s)
#text(x[w+1],y[w+1],toString(w))

w = 55    #34   #21     #13    #8   #5    # 3 #2
l = -1/2584 #1/987#-1/377 #-1/144#1/55#1/21 #1/8#1/3
plot(x,y,asp = 1,col = "gray")
#lines(rc*cos(thc),rc*sin(thc),col = "lightblue")
points(x[seq(2,N,w)],y[seq(2,N,w)],col = "red")
lines(rc*cos(thc*l-a),-rc*sin(thc*l-a),col = "black")
print(s)
#text(x[w+1],y[w+1],toString(w))

w = 13    #34   #21     #13    #8   #5    # 3 #2
l = 1/144 #1/987#-1/377 #-1/144#1/55#1/21 #1/8#1/3
plot(x,y,asp = 1,col = "gray")
#lines(rc*cos(thc),rc*sin(thc),col = "lightblue")
points(x[seq(3,N,w)],y[seq(3,N,w)],col = "red")
lines(rc*cos(thc*l-2*a),-rc*sin(thc*l-2*a),col = "black")
print(s)
#text(x[w+1],y[w+1],toString(w))

s = fibo(50)
k = seq(0,1000)
ss = 5
theta = pi*(3-sqrt(5))*(ss + s[9]*k)
rho = sqrt(ss+s[3]*k)
xt = rho*cos(theta)
yt = rho*sin(theta)
plot(x,y,asp = 1, col = "gray")
points(xt,yt,col = "red")

N = 1501
a = (3-sqrt(5))*pi #137.5/180*pi
n = 0:(N-1)
th = n*a

ii = seq(2,20)
k = length(ii)
colors = hsv(h = seq(0,1,length.out = k +1))
for(j in seq(1,k)){
  ind = seq(1,N,ii[j])
  plot(th %% (2*pi),col = "gray",main = toString(ii[j]))
  points(ind, th[ind] %%(2*pi),col = colors[j],pch = 3)
  lines(ind,th[ind] %% (2*pi),col= colors[j])
  #points(ind, th[ind+1] %%(2*pi),col = colors[j],pch = 3)
}

j = 19
ind = seq(1,N,ii[j])
plot(th %% (2*pi),col = "gray",main = toString(ii[j]))
points(ind, th[ind] %%(2*pi),col = colors[j],pch = 3)
lines(ind, th[ind] %%(2*pi),col = colors[j])

w = 21
ind = seq(1,N,w)
plot(x,y,asp = 1, col = "gray",main = toString(w))
lines(x[ind],y[ind],pch = 3)
plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")

w = s[7:10]
k = length(w)
colors = hsv(h = seq(0,1,length.out = k +1))
plot(th %% (2*pi),col = "gray")
for(j in 1:k ){
  ind = seq(1,N,w[j])
  lines(ind, th[ind] %%(2*pi),col = colors[j])
  cat(w[j])
  cat(" => ")
  print(diff(th[ind[1:3]] %% (2*pi)) %% (2*pi))
}

w = 55
ind = seq(1,N,w)
h = diff(th[ind[1:2]] %% (2*pi)) %% (2*pi)
if(h > 1) h = h - 2*pi
h = h/w

t = seq(0,N,length.out = 1e4)
thc = h*t
rc = sqrt(t)

plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t,thc,col = "red")

plot(x,y,asp = 1,col = "gray")
points(x[ind],y[ind],col = "red")
lines(rc*cos(thc),rc*sin(thc),col = "black")

w = 55
st = 44
ind = seq(st,N,w)
h = diff(th[ind[1:2]] %% (2*pi)) %% (2*pi)
if(h > 1) h = h - 2*pi
h = h/w
b = th[st] %% (2*pi)
t = seq(0,N,length.out = 1e4)
thc = h*(t-ind[1]) + b #t = ind[1] => thc = b with slop h
rc = sqrt(t)

plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t,thc,col = "red")

plot(x,y,asp = 1,col = "gray")
points(0,0,pch=3)
points(x[ind],y[ind],col = "red")
lines(rc*cos(thc),rc*sin(thc),col = "black")

w = 55
plot(x,y,asp = 1,col = "gray")
points(0,0,pch=3)
t = seq(0,N,length.out = 1e4)
colors = hsv(h = seq(0,1,length.out = w+1))
for(st in seq(1,w)){
  ind = seq(st,N,w)
  h = diff(th[ind[1:2]] %% (2*pi)) %% (2*pi)
  if(h > 1) h = h - 2*pi
  h = h/w
  print(paste0(st," => ", h))
  thc = h*(t-ind[1]) + th[st] %% (2*pi) #t = ind[1] => thc = b with slop h
  rc = sqrt(t)

  points(x[ind],y[ind],col = colors[st])
  lines(rc*cos(thc),rc*sin(thc),col = colors[st])
  #print(paste0(c("done with ",toString(st))))
}

u = 3-sqrt(5)
uu = u*seq(1,1000)
plot(uu %% 2,col = "gray")#,pch =20)
ind = seq(1,1000,11)
points(ind,uu[ind] %% 2,pch = 3)
lines(ind,uu[ind] %% 2,col = "blue")

phi = (1-sqrt(5))/2
phiz = phi %% 1
u = phi*seq(0,1000)
w = 17
ind = seq(1,1000,w)
plot(u %% 1,col = "gray",main = toString(w))
points(ind,u[ind] %% 1,pch = 3)
lines(ind,u[ind] %% 1,col = "blue")
h = diff(u[ind[1:5]]) %% 1
print(1 %/% h + 1)
if(h[1] > phiz) h = h - 1

phi = (1-sqrt(5))/2
phiz = phi %% 1
u = phi*seq(0,1000)
for(w in seq(2:60)){
  ind = seq(1,1000,w)
  plot(u %% 1,col = "gray",main = toString(w))
  points(ind,u[ind] %% 1,pch = 3)
  lines(ind,u[ind] %% 1,col = "blue")
  h = diff(u[ind[1:5]]) %% 1
  if(h[1] > phiz) h = h - 1
  hw = 1+ 1 %/% h
  if(h[1] <0 ) hw = (1 - 1 %/% h )
  if(hw[1] > 0){
    cat(paste0(w," => "))
    print(hw)
  }

}

N = 1000
u = seq(1,N)
plot(u,(phi*u) %% 1,col = "gray")
uu = seq(3,N,s[9])
points(uu,(phi*uu) %% 1,pch = 3)
v = (phi*u) %% 1
vs = sort(v,index.return=TRUE)

w = 3*55
st = 44
ind = seq(st,N,w)
h = diff(th[ind[1:2]] %% (2*pi)) %% (2*pi)
if(h > 1) h = h - 2*pi
h = h/w
b = th[st] %% (2*pi)
t = seq(0,N,length.out = 1e4)
thc = h*(t-ind[1]) + b #t = ind[1] => thc = b with slop h
rc = sqrt(t)

plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t,thc,col = "red")

plot(x,y,asp = 1,col = "gray")
points(0,0,pch=3)
points(x[ind],y[ind],col = "red")
lines(rc*cos(thc),rc*sin(thc),col = "black")

w = 11
st = 1
l = 10
ind = seq(st,N,w)
h = diff(th[ind],l) %% (2*pi)
h = h[1]
if(h > pi) h = h - 2*pi
h = h/w/l
b = th[st] %% (2*pi)
t = seq(0,N,length.out = 1e4)
thc = h*(t-ind[1]) + b #t = ind[1] => thc = b with slop h
rc = sqrt(t)

plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t+ind[2],thc+th[ind[2]] %% (2*pi),col = "red")

plot(x,y,asp = 1,col = "gray")
points(0,0,pch=3)
points(x[ind],y[ind],col = "red")
lines(rc*cos(thc),rc*sin(thc),col = "black")

w = 33
st = 3
ind = seq(st,N,w)
zl = min((w-1),length(ind)-1)
zm = sapply(1:zl, function(l){
  h = diff(th[ind],l) %% (2*pi)
  h = h[1]
  if(h > pi) h = h - 2*pi
  return(h)
})

hi = which.min(abs(zm)/(1:zl))
cat("# of branches:")
print(hi)
h = zm[hi]
h = h/w/hi
b = th[st] %% (2*pi)
t = seq(0,N,length.out = 1e4)
thc = h*(t-ind[1]) + b #t = ind[1] => thc = b with slop h
rc = sqrt(t)

plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t+ind[2],(-b+thc+th[ind[2]] )%% (2*pi),col = "red")

plot(x,y,asp = 1,col = "gray")
points(0,0,pch=3)
points(x[ind],y[ind],col = "red")
lines(rc*cos(thc),rc*sin(thc),col = "black")

plot(zm/(1:zl))

library(numbers)
primeFactors(610)

w = 61
N = 100*w + 10
a = (3-sqrt(5))*pi
n = 0:(N-1)
th = n*a
r = sqrt(n)

x = r*cos(th)
y = r*sin(th)
#plot(x,y,asp = 1)

w = 33
st = 1
l = 5
ind = seq(st,N,w)
h = diff(th[ind],l) %% (2*pi)
h = h[1]
if(h > pi) h = h - 2*pi
h = h/w/l
b = th[st] %% (2*pi)
t = seq(0,N,length.out = 1e4)
thc = h*(t-ind[1]) + b #t = ind[1] => thc = b with slop h
rc = sqrt(t)

plot(th %% (2*pi),col = "gray",main = toString(w))
points(ind, th[ind] %%(2*pi),pch = 3)
lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t+ind[2],(-b+thc+th[ind[2]] )%% (2*pi),col = "red")

plot(x,y,asp = 1,col = "gray")
points(0,0,pch=3)
points(x[ind],y[ind],col = "red")

lines(rc*cos(thc),rc*sin(thc),col = "black")

w = 8*18
st = 3
ind = seq(st,N,w)
zl = min((w-1),length(ind)-1)
zm = sapply(1:zl, function(l){
  h = diff(th[ind],l) %% (2*pi)
  h = h[1]
  if(h > pi) h = h - 2*pi
  return(h)
})
plot(x[ind],y[ind],col = "red",asp = 1)

w =18
st = 3
ind = seq(st,N,w)
plot(x[ind],y[ind],col = "red",asp = 1,main = toString(w))
w =8
ind = seq(st,N,w)
points(x[ind],y[ind],pch = 3,col = "gray")
w =8*18
ind = seq(st,N,w)
points(x[ind],y[ind],pch = 2,col = "blue")

sprintf("%.50f",phi*8*18) #144
sprintf("%.50f",phi*233)

ps = c(2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, 79, 83, 89, 97)

w = 377
sth = function(w){
  N = 30*w + 10
  #print(N)
  a = (3-sqrt(5))*pi
  n = 0:(N-1)
  th = n*a
  r = sqrt(n)

st = 1
ind = seq(st,N,w)
h = diff(th[ind[1:2]] %% (2*pi)) %% (2*pi)
if(h > pi) h = h - 2*pi
h = h/w
b = th[st] %% (2*pi)
t = seq(0,N,length.out = 1e4)
thc = h*(t-ind[1]) + b #t = ind[1] => thc = b with slop h
rc = sqrt(t)
x = r*cos(th)
y = r*sin(th)

#plot(th %% (2*pi),col = "gray",main = toString(w))
#points(ind, th[ind] %%(2*pi),pch = 3)
plot(ind, th[ind] %%(2*pi),pch = 3,main = toString(w))
#lines(ind, th[ind] %%(2*pi),col = "gray")
lines(t,thc %% (2*pi),col = "red")

#plot(x,y,asp = 1,col = "gray")
#points(0,0,pch=3)
#points(x[ind],y[ind],col = "red")
plot(x[ind],y[ind],col = "red",main = toString(w),asp = 1)
lines(rc*cos(thc),rc*sin(thc),col = "black")
}


# y denote the number of successes in the n sample trials,
# sample proportion
y=330
n=870
pie=y/n
sigma=sqrt((pie*(1-pie))/n)

alpha=0.05
z.alpha=qnorm(1-alpha)
error=z.alpha*sigma
#  the 90% confidence interval on the proportion of cancer
#patients who will survive at least 5 years
left_i=pie-error
right_i=pie+error
print(left_i)
print(right_i)


# Goal: Experiment with fitting nonlinear functional forms in
#       OLS, using orthogonal polynomials to avoid difficulties with
#       near-singular design matrices that occur with ordinary polynomials.
#       Shriya Anand, Gabor Grothendieck, Ajay Shah, March 2006.

# We will deal with noisy data from the d.g.p. y = sin(x) + e
x <- seq(0, 2*pi, length.out=50)
set.seed(101)
y <- sin(x) + 0.3*rnorm(50)
basicplot <- function(x, y, minx=0, maxx=3*pi, title="") {
  plot(x, y, xlim=c(minx,maxx), ylim=c(-2,2), main=title)
  lines(x, sin(x), col="blue", lty=2, lwd=2)
  abline(h=0, v=0)
}
x.outsample <- seq(0, 3*pi, length.out=100)

# Severe multicollinearity with ordinary polynomials
x2 <- x*x
x3 <- x2*x
x4 <- x3*x
cor(cbind(x, x2, x3, x4))
# and a perfect design matrix using orthogonal polynomials
m <- poly(x, 4)
all.equal(cor(m), diag(4))              # Correlation matrix is I.

par(mfrow=c(2,2))
# Ordinary polynomial regression --
  p <- lm(y ~ x + I(x^2) + I(x^3) + I(x^4))
  summary(p)
  basicplot(x, y, title="Polynomial, insample") # Data
  lines(x, fitted(p), col="red", lwd=3)  # In-sample
  basicplot(x, y, title="Polynomial, out-of-sample")
  predictions.p <- predict(p, list(x = x.outsample))    # Out-of-sample
  lines(x.outsample, predictions.p, type="l", col="red", lwd=3)
  lines(x.outsample, sin(x.outsample), type="l", col="blue", lwd=2, lty=2)
  # As expected, polynomial fitting gives terrible results out of sample.

# These IDENTICAL things using orthogonal polynomials
  d <- lm(y ~ poly(x, 4))
  summary(d)
  basicplot(x, y, title="Orth. poly., insample") # Data
  lines(x, fitted(d), col="red", lwd=3)  # In-sample
  basicplot(x, y, title="Orth. poly., out-of-sample")
  predictions.op <- predict(d, list(x = x.outsample))    # Out-of-sample
  lines(x.outsample, predictions.op, type="l", col="red", lwd=3)
  lines(x.outsample, sin(x.outsample), type="l", col="blue", lwd=2, lty=2)

# predict(d) is magical! See ?SafePrediction
# The story runs at two levels. First, when you do an OLS model,
# predict()ion requires applying coefficients to an appropriate
# X matrix. But one level deeper, the polynomial or orthogonal-polynomial
# needs to be utilised for computing the X matrix based on the
# supplied x.outsample data.
# If you say p <- poly(x, n)
# then you can say predict(p, new) where predict.poly() gets invoked.
# And when you say predict(lm()), the full steps are worked out for
# you automatically: predict.poly() is used to make an X matrix and
# then prediction based on the regression results is done.

all.equal(predictions.p, predictions.op) # Both paths are identical for this
                                         # (tame) problem.

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/o9.r


## Dale W.R. Rosenthal, 2018
## You are free to distribute and use this code so long as you attribute
## it to me or cite the text.
## The legal disclaimer in _A Quantitative Primer on Investments with R_
## applies to this code.  Use or distribution without these comment lines
## is forbidden.

x <- seq(-5,5, 0.01)  # sequence of values to plot a standardized distribution

# Plot normal, logistic, and standardized t_5 densities; add a legend to look nice.
plot(x, dnorm(x), type='l', ylim=c(0,0.5), lty=1, lwd=2, col="cyan", xlab="", ylab="", main="")
lines(x, dlogis(x, scale=sqrt(3)/pi), lty=2, lwd=2)
lines(x, dt(x/sqrt((5-2)/5), df=5)/sqrt((5-2)/5), lty=4, lwd=2, col="red")
legend.text <- c(expression(paste('t'[5], "  ", kappa, "=9")),
                 expression(paste("logistic  ", kappa,"=4.2")),
                 expression(paste("normal  ", kappa, "=3")))
legend("topright", legend.text, lty=c(4,2,1), lwd=2, col=c("red", "black", "cyan"))

# Then plot logs of densities to show the tail behavior
plot(x, log(dnorm(x)), type='l', lty=1, lwd=2, col="cyan", xlab="", ylab="", main="")
lines(x, log(dlogis(x, scale=sqrt(3)/pi)), type='l', lty=2, lwd=2)
lines(x, log(dt(x/sqrt((5-2)/5), df=5)/sqrt((5-2)/5)), type='l', lty=4, lwd=2, col="red")
legend.text <- c(expression(paste('t'[5], "  ", kappa, "=9")),
                 expression(paste("logistic  ", kappa,"=4.2")),
                 expression(paste("normal  ", kappa, "=3")))
legend("topright", legend.text, lty=c(4,2,1), lwd=2, col=c("red", "black", "cyan"))


# [Contoh | Langkah 1: Standarisasi Data](https://academy.dqlab.id/main/livecode/89/173/839)
library(openxlsx)
df <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet="3varb")
# standarisasi variabel (centering dan scaling)
df <- scale(df, center = TRUE, scale = TRUE)
head(df, 3)

# [Contoh | Langkah 2: Menghitung Matrik Korelasi Data](https://academy.dqlab.id/main/livecode/89/173/840)
library(openxlsx)

df <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet="3varb")
df <- scale(df, center = TRUE, scale = TRUE)

cormat <- cor(df)
cormat

# [Contoh | Langkah 3: Menghitung Nilai Eigen dan Vektor Eigen](https://academy.dqlab.id/main/livecode/89/173/841)
library(openxlsx)

df <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet="3varb")
df <- scale(df, center = TRUE, scale = TRUE)

cormat <- cor(df)

eig <- eigen(cormat)
eig

# [Contoh | Langkah 4: Memilih Banyaknya Principal Component](https://academy.dqlab.id/main/livecode/89/173/842)
library(openxlsx)

df <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet="3varb")
df <- scale(df, center = TRUE, scale = TRUE)

cormat <- cor(df)
eig <- eigen(cormat)

round(eig$values/ncol(df),3)
round(cumsum(eig$values/ncol(df)),3)

pr.out <- prcomp(df, scale. = TRUE, center = TRUE)
pr.out
summary(pr.out)

library(factoextra)

fviz_eig(pr.out, addlabels = TRUE)

screeplot(pr.out, type = "line")
abline(h = 1, lty = 3, col = "red")

# [Contoh | Langkah 5: Visualisasi dengan Biplot](https://academy.dqlab.id/main/livecode/89/173/843)
library(openxlsx)

df <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet="3varb")
df <- scale(df, center = TRUE, scale = TRUE)

pr.out <- prcomp(df, scale. = TRUE, center = TRUE)

pr.out$rotation
biplot(pr.out, scale = 0)

# [Contoh | Langkah 6: Menghitung Skor Baru](https://academy.dqlab.id/main/livecode/89/173/844)
library(openxlsx)

df <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet="3varb")
df <- scale(df, center = TRUE, scale = TRUE)

pr.out <- prcomp(df, scale. = TRUE, center = TRUE)

head(df)

df_new <- df %*% pr.out$rotation
df_new[1:6,1:2]

# [Tugas Praktik](https://academy.dqlab.id/main/livecode/89/173/845)
# Panggil library openxlsx untuk membaca file data Excel
library(openxlsx)
# Baca data pada sheet "3varb" dalam file https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx
# dan simpan data dengan nama df_raw
df_raw <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet = "3varb")
# Tampilkan struktur data
str(df_raw)
# Tampilkan beberapa baris observasi dengan fungsi head()
head(df_raw)
# Lakukan analisa PCA dengan fungsi prcomp()
# simpan output dengan nama pr.out
pr.out <- prcomp(df_raw, center = TRUE, scale = TRUE, retx = TRUE)
# Tampilkan komponen output fungsi prcomp()
names(pr.out)
# Tampilkan output PCA
pr.out
# Tampilkan summary dari output PCA
summary(pr.out)
# Gambarkan scree plot
screeplot(pr.out, type = "line")
# Tambahkan garis horizontal sebagai panduan untuk menggunakan kriteria Kaiser
abline(h = 1, col = "red", lty = 3)
# Gambarkan biplot dengan menggunakan fungsi biplot()
biplot(pr.out, scale = 0)

# [Tugas Praktik: 4 Variabel](https://academy.dqlab.id/main/livecode/89/174/852)
# Panggil library openxlsx untuk membaca file data Excel
# [1]
library(openxlsx)
# Baca data pada sheet "csdata" dalam file "https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx"
# dan simpan data dengan nama "csdat_raw"
# [2]
csdat_raw <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet = "csdata")
# Tampilkan struktur data
# [3]
str(csdat_raw)
# Tampilkan beberapa baris observasi dengan fungsi head()
# [4]
head(csdat_raw)
# Tampilkan statistika deskriptif untuk semua variabel dalam data.
# [5]
summary(csdat_raw)
# Gambarkan distribusi Income berdasarkan Dependents
library(ggplot2)
ggplot(csdat_raw, aes(as.factor(dependents), income)) +
  geom_boxplot() + xlab("Dependents") + ggtitle("Boxplot Income Berdasarkan Dependents")
# Pisahkan data untuk traning set dan testing set
# untuk tiap-tiap risk rating
# Catat indeks/ nomor baris untuk tiap-tiap risk rating
index1 <- which(csdat_raw$riskrating == 1)
index2 <- which(csdat_raw$riskrating == 2)
# Lakukan pencatatan indeks untuk risk rating berikutnya
# [6]
index3 <- which(csdat_raw$riskrating == 3)
index4 <- which(csdat_raw$riskrating == 4)
index5 <- which(csdat_raw$riskrating == 5)
# 80% data akan digunakan sebagai traning set.
# [7]
ntrain1 <- round(0.8 * length(index1))
ntrain2 <- round(0.8 * length(index2))
ntrain3 <- round(0.8 * length(index3))
ntrain4 <- round(0.8 * length(index4))
ntrain5 <- round(0.8 * length(index5))
# set seed agar sampling ini bisa direproduksi
set.seed(100)
# sampling data masing-masing rating untuk training set
# [8]
train1_index <- sample(index1, ntrain1)
train2_index <- sample(index2, ntrain2)
train3_index <- sample(index3, ntrain3)
train4_index <- sample(index4, ntrain4)
train5_index <- sample(index5, ntrain5)
# menyimpan data ke dalam testing set
# [9]
test1_index <- setdiff(index1, train1_index)
test2_index <- setdiff(index2, train2_index)
test3_index <- setdiff(index3, train3_index)
test4_index <- setdiff(index4, train4_index)
test5_index <- setdiff(index5, train5_index)
# Menggabungkan hasil sampling masing-masing risk rating ke dalam training set
csdattrain <- do.call("rbind", list(csdat_raw[train1_index,],
                                    csdat_raw[train2_index,], csdat_raw[train3_index,],
                                    csdat_raw[train4_index,], csdat_raw[train5_index,]))
cstrain <- subset(csdattrain, select =
                    -c(contractcode,riskrating))
# Menggabungkan hasil sampling masing-masing risk rating ke dalam testing set
csdattest <- do.call("rbind", list(csdat_raw[test1_index,],
                                   csdat_raw[test2_index,], csdat_raw[test3_index,],
                                   csdat_raw[test4_index,], csdat_raw[test5_index,])) # [10]
cstest <- subset(csdattest,
                 select = -c(contractcode,riskrating)) # [11]

# Menghitung korelasi antar variabel
cor(cstrain)
# Lakukan analisa PCA dengan fungsi prcomp() dan
# simpan output ke dalam obyek dengan nama pr.out
# [12]
pr.out <- prcomp(cstrain, scale = TRUE, center = TRUE)
# Tampilkan output PCA dengan memanggil obyek pr.out
# [13]
pr.out
# Tampilkan summary dari output PCA
# [14]
summary(pr.out)
# Gambarkan scree plot dengan menggunakan fungsi screeplot()
# [15]
screeplot(pr.out, type = "line", ylim = c(0,2))
# Tambahkan garis horizontal sebagai panduan untuk menggunakan kriteria Kaiser
abline(h = 1, lty = 3, col = "red")
# Gambarkan biplot dengan menggunakan fungsi biplot()
# [16]
biplot(pr.out, scale = 0) # draw first 2 principal components

# [Tugas Praktik: 8 Variabel](https://academy.dqlab.id/main/livecode/89/175/859)
# Panggil library openxlsx untuk membaca file data Excel
library(openxlsx)
# Baca data pada sheet "cslarge" dalam file "https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx"
# dan simpan data dengan nama "cslarge_raw"
cslarge_raw <- read.xlsx("https://academy.dqlab.id/dataset/dqlab_pcadata.xlsx", sheet = "cslarge")
# Tampilkan struktur data
str(cslarge_raw)
# Tampilkan beberapa baris observasi dengan fungsi head()
head(cslarge_raw)
# Tampilkan statistika deskriptif untuk semua variabel dalam data frame.
summary(cslarge_raw)
# Gambarkan distribusi income berdasarkan dependents.
library(ggplot2)
ggplot(cslarge_raw, aes(as.factor(dependents), income)) +
  geom_boxplot() + xlab("Dependents") + ggtitle("Boxplot Income Berdasarkan Dependents")
# Gambarkan distribusi debt berdasarkan dependents.
ggplot(cslarge_raw, aes(as.factor(dependents), debt)) +
  geom_boxplot() + xlab("Dependents") + ggtitle("Boxplot Debt Berdasarkan Dependents")
# Pisahkan data untuk traning set dan testing set
# untuk tiap-tiap risk rating
# Catat indeks/ nomor baris untuk tiap-tiap risk rating
index1 <- which(cslarge_raw$riskrating == 1)
index2 <- which(cslarge_raw$riskrating == 2)
# Lakukan pencatatan indeks untuk risk rating berikutnya
index3 <- which(cslarge_raw$riskrating == 3)
index4 <- which(cslarge_raw$riskrating == 4)
index5 <- which(cslarge_raw$riskrating == 5)
# 80% data akan digunakan sebagai traning set.
ntrain1 <- round(0.8 * length(index1))
ntrain2 <- round(0.8 * length(index2))
ntrain3 <- round(0.8 * length(index3))
ntrain4 <- round(0.8 * length(index4))
ntrain5 <- round(0.8 * length(index5))
# set seed agar sampling ini bisa direproduksi
set.seed(100)
# sampling data masing-masing rating untuk training set
train1_index <- sample(index1, ntrain1)
train2_index <- sample(index2, ntrain2)
train3_index <- sample(index3, ntrain3)
train4_index <- sample(index4, ntrain4)
train5_index <- sample(index5, ntrain5)
# menyimpan data ke dalam testing set
test1_index <- setdiff(index1, train1_index)
test2_index <- setdiff(index2, train2_index)
test3_index <- setdiff(index3, train3_index)
test4_index <- setdiff(index4, train4_index)
test5_index <- setdiff(index5, train5_index)
# Menggabungkan hasil sampling masing-masing risk rating ke dalam training set
cslarge_train <- do.call("rbind", list(cslarge_raw[train1_index,],
                                       cslarge_raw[train2_index,], cslarge_raw[train3_index,],
                                       cslarge_raw[train4_index,], cslarge_raw[train5_index,]))
cstrain <- subset(cslarge_train, select = -c(contractcode,riskrating))
# Menggabungkan hasil sampling masing-masing risk rating ke dalam testing set
cslarge_test <- do.call("rbind", list(cslarge_raw[test1_index,],
                                      cslarge_raw[test2_index,], cslarge_raw[test3_index,],
                                      cslarge_raw[test4_index,], cslarge_raw[test5_index,]))
cstest <- subset(cslarge_test, select = -c(contractcode,riskrating))
# Menghitung korelasi antar variabel
cor(cstrain)
# Menggambarkan matrik korelasi dengan ggcorrplot
library(ggcorrplot)
ggcorrplot(cor(cstrain))
# Lakukan analisa PCA dengan fungsi prcomp() dan
# simpan output ke dalam obyek dengan nama pr.out
pr.out <- prcomp(cstrain, scale = TRUE, center = TRUE)
# Tampilkan output PCA dengan memanggil obyek pr.out
pr.out
# Tampilkan summary dari output PCA
summary(pr.out)
# Gambarkan scree plot dengan menggunakan fungsi screeplot()
screeplot(pr.out, type = "line", ylim = c(0,2))
# Tambahkan garis horizontal sebagai panduan untuk menggunakan kriteria Kaiser
abline(h = 1, lty = 3, col = "red")
# Gambarkan biplot dengan menggunakan fungsi biplot()
biplot(pr.out, scale = 0) #draw first 2 principal components
# Gambarkan Principal Component dan risk rating dengan menggunakan
# fungsi autoplot() dari package ggfortify.
library(ggfortify)
autoplot(pr.out, data = cslarge_train, colour = 'riskrating',
         loadings = TRUE, loadings.label = TRUE, loadings.label.size = 3, scale = 0)
# Gambarkan Principal Component dan risk rating dengan menggunakan
# fungsi fviz_pca_ind() package factoextra.
library(factoextra)
fviz_pca_ind(pr.out, label="none", habillage=cslarge_train$riskrating)

# [Contoh](https://academy.dqlab.id/main/livecode/89/179/874)
(A <- as.matrix(data.frame(c(1,0,1),c(0,1,1),c(1,1,0))))
e <- eigen(A)
str(e)
e

# [Tugas Praktik](https://academy.dqlab.id/main/livecode/89/179/875)
# Ketik perintah berikut ini untuk membaca help tentang matriks
?matrix
# Buatlah matriks 3 x 3 dan simpan dengan nama matriks A.
A <- matrix(c(1, 1, 0, 0, -2, 1, 0, 0, 3), nrow = 3, ncol = 3, byrow = TRUE)
# Tuliskan perintah untuk menampilkan matriks A
A
# Tuliskan perintah R untuk menghitung nilai eigen dan vektor eigen
# dan simpanlah hasilnya dalam variable ev
ev <- eigen(A)
# Tuliskan perintah untuk melihat struktur obyek eigen
str(ev)
# Tuliskan perintah untuk melihat hasil output
ev
# Tuliskan perintah untuk mengakses nilai eigen
ev$values
# Tuliskan perintah untuk mengakses vektor eigen
ev$vectors

R/Kelas Penerapan/Data Science in Finance Dimension Reduction/Data Science in Finance Dimension Reduction.r


options(width=60, keep.source=TRUE, prompt=" ", continue=" ")
set.seed(76543); # recompile will have same random numbers

###################################################
### code chunk number 4: ex (eval = FALSE)
###################################################
#An example with 100 Confidence Intervals (CIs).
#Consider drawing a sample of 25 observations from a normally distributed population with mean 10 and sd 2. Calculate the 95% t-CI. Now do that 100 times. The plot belows reflects the variability of that process. We expect 95 of the 100 CIs to contain the true population mean of 10, that is, on average 5 times out of 100 we draw the incorrect inference that the population mean is in an interval when it does not contain the true value of 10.
library(TeachingDemos)
## # look at examples at bottom of the help page
## ?clt.examp
ci.examp(mean.sim = 10, sd = 2, n = 25
                  , reps = 100, conf.level = 0.95, method = "t")

###################################################
### code chunk number 5: 02_tdist_normal
###################################################
#With higher degrees of freedom, the t distribution gets closer to the normal distribution, as illustrated by this example:
x <- seq(-8, 8, length = 1000)
par(mfrow=c(1,1))
plot(x, dnorm(x), type = "l", lwd = 2, col = "red"
          , main = "Normal (red) vs t-dist with df=1, 2, 6, 12, 30, 100")
points(x, dt(x,  1), type = "l")
points(x, dt(x,  2), type = "l")
points(x, dt(x,  6), type = "l")
points(x, dt(x, 12), type = "l")
points(x, dt(x, 30), type = "l")
points(x, dt(x,100), type = "l")

###################################################
### code chunk number 8: ex
###################################################
#Example data
#Page 13 of ADA1_02_OneSample.pdf
# enter data as a vector
#Example: Age at First Transplant (Revisited) The ages (in years) at first transplant for a sample of 11 heart transplant patients are as follows: 54, 42, 51, 54, 49, 56, 33, 58, 54, 64, 49.
age <- c(54, 42, 51, 54, 49, 56, 33, 58, 54, 64, 49)

###################################################
### code chunk number 9: 02_age
###################################################
#Let's look at the example data.
par(mfrow=c(2,1))
# Histogram overlaid with kernel density curve
hist(age, freq = FALSE, breaks = 6)
points(density(age), type = "l")
rug(age)

# violin plot
library(vioplot)
vioplot(age, horizontal=TRUE, col="gray")

###################################################
### code chunk number 10: ex
###################################################
#Calculating the critical value from a t distribution:
# t.crit
#qt(desired confidence level, degrees of freedom)
#http://stackoverflow.com/questions/11526041/critical-t-values-in-r
#The graph on page 11 of ADA1_02_OneSample.pdf may help clarify the following.
#95% confidence level for two sided test:
qt(1 - 0.05/2, df = length(age) - 1)
#95% confidence level for one sided test:
qt(1 - 0.05, df = length(age) - 1)
#Note that these are the same:
abs(qt(0.05, df = length(age) - 1))
qt(0.95, df = length(age) - 1)


## Simulate data from Zero Inflated Poisson, NB, Beta Binomial, Beta Negative Binomial, Half Normal##
sample.zero.inflated <- function(n, phi, theta, dist="Poisson") {
  fsample <- function(m) { rpois(m, lambda=theta[1]); };
  if(dist=="Negative Binomial") fsample <- function(m) {rnbinom(m, size=theta[1], prob=1-theta[2])};#size=r, p=p(failure), so our p is (1-p)
  if(dist=="Beta Binomial") fsample <- function(m) {rbbinom(m, theta[1], theta[2], theta[3])} #{extraDistr}
  if(dist=="Beta Negative Binomial") fsample <- function(m) {rbnbinom(m, theta[1], theta[2], theta[3])} #{extraDistr}
  if(dist=="Half Normal") fsample <- function(m) {rhnorm(m, theta[1])}
  if(dist=="Log Normal") fsample <- function(m) {rlnorm(m, theta[1], theta[2])} #theta[2]=sigma, not sig squar
  ans=rbinom(n, size=1, prob=1-phi);
  m=sum(ans==1);
  if(m>0) ans[ans==1]=fsample(m);
  ans;
}
# For examle:
x= sample.zero.inflated(n=300, phi=0.03, theta=0.1, dist="Poission")
x= sample.zero.inflated(n=10000, phi=0.2, theta=c(15,0.3), dist="Negative Binomial")
x= sample.zero.inflated(10000, phi=0.50, theta=c(20, 2,5), dist="Beta Binomial")
x= sample.zero.inflated(50000, phi=0.50, theta=c(5, 1,10), dist="Beta Negative Binomial")
x= sample.zero.inflated(500, phi=0.50, theta=4, dist="Half Normal")
x= sample.zero.inflated(400, phi=0.50, theta=c(1,4), dist="Log Normal")

######### Next: Simulate from Hurdle ditributions####

##### Simulate from Hurdle Poisson###########
rhpois <- function(n, phi, theta) {
  ans=rbinom(n, size=1, prob=1-phi);
  m=sum(ans==1);
  p0=exp(-theta)
  M=ceiling(m+m*p0+3*sqrt(m*p0*(1-p0)))
  z=rpois(M, theta)
  u=z[z>0]
  t=length(u)
  if(t < m ) {
    u1=rep(0, m-t);
    itemp=0;
    while(itemp<(m-t)) {
      temp=rpois(1,theta);
      if(temp>0) {itemp=itemp+1; u1[itemp]=temp; };
    };
    u=c(u,u1);
  };
  ans[ans==1]=u[1:m];
  ans;
}

##### Simulate from Hurdle NB###########
rhnb <- function(n, phi, theta=c(theta[1], theta[2])) { # function(m) {rnbinom(m, size=theta[1], prob=1-theta[2])}
  ans=rbinom(n, size=1, prob=1-phi);
  m=sum(ans==1);
  p0=(1-theta[2])^(theta[1])          #(1-p) ^r
  M=ceiling(m+m*p0+3*sqrt(m*p0*(1-p0)))
  z=rnbinom(M, size=theta[1], prob=1-theta[2])
  u=z[z>0]
  t=length(u)
  if(t < m ) {
    u1=rep(0, m-t);
    itemp=0;
    while(itemp<(m-t)) {
      temp=rnbinom(1,size=theta[1], prob=1-theta[2]);
      if(temp>0) {itemp=itemp+1; u1[itemp]=temp; };
    };
    u=c(u,u1);
  };
  ans[ans==1]=u[1:m];
  ans;
}

##### Simulate from Hurdle Beta Binomial###########
rhbb <- function(n, phi, theta=c(theta[1], theta[2], theta[3])) { # function(m) {rnbinom(m, size=theta[1], prob=1-theta[2])}
  ans=rbinom(n, size=1, prob=1-phi);
  m=sum(ans==1);
  p0=gamma(theta[1]+theta[3])*gamma(theta[2]+theta[3])/(gamma(theta[1]+theta[2]+theta[3])*gamma(theta[3]))
  M=ceiling(m+m*p0+3*sqrt(m*p0*(1-p0)))
  z=rbbinom(M, theta[1], theta[2], theta[3])
  u=z[z>0]
  t=length(u)
  if(t < m ) {
    u1=rep(0, m-t);
    itemp=0;
    while(itemp<(m-t)) {
      temp=rbbinom(1,theta[1], theta[2], theta[3]);
      if(temp>0) {itemp=itemp+1; u1[itemp]=temp; };
    };
    u=c(u,u1);
  };
  ans[ans==1]=u[1:m];
  ans;
}

Simulation from Zero inflated and Hurdle.r


## Code Skeleton for Series 8, task 1

require(ROCR)

d.baby <- read.table("http://stat.ethz.ch/Teaching/Datasets/baby.dat", header=TRUE)

## task a)

fit <- glm(Survival ~ ., family = binomial(link="logit"), data = d.baby)

pred <- prediction(predictions = fit$fitted.values, labels = d.baby$Survival)
perf <- performance(pred, "tpr", "fpr" )
title <- "logist.regr: glm(Survival ~ . , d.baby)  [in-sample]"
plot(perf, main = paste("ROC:  ", title))

perf.cost <- performance(pred, "cost")
plot(perf.cost, main = title)

## task b)

n <- nrow(d.baby)
K <- 10
all.y.true <- all.y.pred <- vector("list", length = K)
set.seed(101)
## define folds
folds <- sample(cut(seq(1, n), breaks = K, labels = FALSE), replace = FALSE)
for (i in 1:K){
  test.ind <- which(folds == i)
  df.train<- d.baby[-test.ind,]
  df.test <- d.baby[test.ind,]
  fit.glm <- glm(formula = Survival ~ ., data = df.train, family = binomial(link="logit"))
  y.true <- df.test$Survival
  y.pred <- predict(fit.glm, newdata = df.test, type = "response")
  all.y.true[[i]] <- y.true
  all.y.pred[[i]] <- y.pred
}

pred.cv <- prediction(predictions = all.y.pred, labels = all.y.true)

perf.cv <- performance(pred.cv, "tpr", "fpr" )
title <- "logist.regr: glm(Survival ~ . , d.baby)  [cross-validated]"
plot(perf.cv, avg = "threshold", main = paste("ROC:  ", title))
## add the in-sample curve
plot(perf, col = 2, add = TRUE)

perf.cv.cost <- performance(pred.cv, "cost")
plot(perf.cv.cost, avg = "vertical", main = title)
## add the in-sample curve
plot(perf.cost, col = 2, add = TRUE)

## task c)

c1 <- seq(0, 2, 0.2)
for (j in 1:length(c1)) {
  ## cost for given cost function
  perf.cv.cost.pen <- performance(pred.cv, "cost", cost.fp = c1[j], cost.fn = 2. - c1[j])
  plot(perf.cv.cost.pen, avg = "vertical", col = j - 6 * (j > 6), lty = 1 + 1 * (j > 6), add = (j > 1),
       ylim = c(0, 1))
}
legend("topleft", legend = paste("c1 =", c1), col = c(rep(1:6, 2)),
       lty =  c(rep(1, 6), rep(2, 5)), ncol = 3)


# 5.2 Generación de números pseudo-aleatorios y distribuciones de probabilidad en R
rnorm(n = 10, mean = 10, sd = 2) # Normal con media 10 y desviación típica 2
runif(10) # Uniforme en (0,1)
rpois(n = 10, lambda = 1) # Poisson con media 1

sample(1:5, 5) # permutación
sample(1:5, 10, replace = TRUE) # muestra con reemplazo
sample(c(0, 1), 5, replace = TRUE, prob = c(0.4, 0.5)) # Bernoulli
sample(cars$speed, 3) # tres valores aleatorios de cars$speed

mx <- numeric()
for (i in 1:10) {
    set.seed(i)
    x <- rnorm(100, mean = 2)
    mx[i] <- mean(x)
}
mean(mx)

dpois(x = 0:10, lambda = 3)
plot(
    dpois(x = 0:10, lambda = 3),
    type = "h",
    xlab = "x",
    ylab = "P(X=x)",
    main = expression(Poisson(lambda == 3))
)

plot(ppois(q = 0:10, lambda = 3),
    type = "s", xlab = "x", ylab = expression(P(X <= x)),
    main = expression(Poisson(lambda == 3))
)
qnorm(0.025, lower.tail = FALSE) # valor crítico (Normal) alpha=0.05

# 5.3 Ley de los grandes números
# Probamos primero algunos lanzamientos (uno, diez):
sample(c(cara = 1, cruz = 0), 1, replace = TRUE, prob = c(0.5, 0.5))
x <- sample(c(cara = 1, cruz = 0), 10, replace = TRUE, prob = c(0.5, 0.5))
x
mean(x) # frecuencia relativa de cara en 10 lanzamientos
x <- sample(c(cara = 1, cruz = 0), 50, replace = TRUE, prob = c(0.5, 0.5))
mean(x) # frecuencia relativa de cara en 50 lanzamientos

# Representamos gráficamente la solución
set.seed(1) # para poder reproducir los resultados de abajo
nsim <- 1000
x <- sample(c(cara = 1, cruz = 0), nsim, replace = TRUE, prob = c(0.5, 0.5))
n <- 1:nsim
plot(n, cumsum(x) / n,
    type = "l", ylab = "Proporción de caras",
    xlab = "Número de lanzaamientos", ylim = c(0, 1)
)
abline(h = 0.5, lty = 2, col = 2)

# alternativamente podríamos haber hecho:
x <- rbinom(nsim, size = 1, prob = 0.5)
head(x)
# ó
x <- runif(nsim) < 0.5
head(x)

# 5.3.2. Detección de problemas de convergencia
# Esperanza no finita
set.seed(1)
nsim <- 10000
x <- rcauchy(nsim)
n <- 1:nsim
plot(n, cumsum(x) / n,
    type = "l", ylab = "Media muestral",
    xlab = "Número de simulaciones",
    main = "Secuencia de medias de una Cauchy"
)
abline(h = 0, lty = 2, col = 2)

# probando con varias semillas
for (i in 2:4) {
    set.seed(i)
    x <- rcauchy(nsim)
    plot(n, cumsum(x) / n,
        type = "l", ylab = "Media muestral",
        xlab = "Número de simulaciones"
    )
    abline(h = 0, lty = 2, col = 2)
}
# cajas para observar cómo se comporta: muchos datos anómalos
for (i in 2:4) {
    set.seed(i)
    x <- rcauchy(nsim)
    boxplot(x, ylab = "Media muestral")
}

# 5.3.3  Precisión de la aproximación

# ~~> intervalos de confianza
# Teorema central del límite: Teorema Central del Límite.
# Dada una secuencia X1, ..., Xn variables aleatorias iid
# con esperanza E[Xi] = µ y varianza V(Xi) = s^2 < 8
# ==> Z_n = (mean(c(X1,...Xn)) - \mu )/(\sigma/sqrt(n))
# para n --> \infty
# ~~> intervalo de confianza
# X_n -+ z_{\alpha/2}S_n/sqrt(n)

set.seed(1)
nsim <- 10000
x <- rnorm(nsim)
# Aproximación de la media:
mean(x)
# error estándar
sd(x) / sqrt(nsim)
# error máximo admisible al nivel de confianza 0.95
qnorm(0.975) * sd(x) / sqrt(nsim)

# representamos con intervalos de confianza
n <- 1:nsim
# medias muestrales para n=1,2,...,nsim
estim <- cumsum(x) / n
# correspondientes errores de estimación
# por simplicidad con varianza muestral en lugar de cuasivarianza
estim.err <- sqrt(cumsum((x - estim)^2)) / n
# gráfico de convergencia
plot(n, estim,
    type = "l", xlab = "Número de simulaciones",
    ylab = "Aproximación de la media y error", ylim = c(-1, 1)
)
# media teórica:
abline(h = 0, col = 2)
# intevalos de confianza (1-alpha=0.95)
z <- qnorm(0.975)
lines(estim - z * estim.err, lty = 3, lwd = 2, col = "blue")
lines(estim + z * estim.err, lty = 3, lwd = 2, col = "blue")

# Ejercicio. Comprueba y visualiza la convergencia en el caso variables con distribución
# uniforme, U(-3, 3).

# --------------------------------------------------------------------------------
# descando
# --------------------------------------------------------------------------------

# 5.3.4. Determinación del número de simulaciones

# En el caso en que la varianza de las X_i, \sigma^2 sea conocida, resolver el problema es
# determinar n tal que z_{\alpha/2} * \sigma / \sqrt(n) < \epsilon
# n = (z_{\alpha/2} \sigma / \epsilon )^2

# Ejercicio. Calcular el número de simulaciones necesario para aproximar la media µ
# de la siguientes distribuciones con un error máximo admisible de 0.1|µ|:
# 1. Normal con media µ = 10 y desviación típica s = 5.
# 2. Chi-cuadrado con 10 grados de libertad (µ = 10, s^2 = 2 * µ).
# 3. Poisson con parámetro <U+03BB> = 10 (µ = 10, s^2 = µ)

determina.n <- function(epsilon, sigma, alpha) {
    z <- qnorm(alpha / 2, lower.tail = F)
    n <- z * sigma / epsilon
    return(n^2)
}
# 1.
determina.n()
# 2.
# 3.

# --------------------------------------------------------------------------------

# En el caso \sigma^2 desconocidam, ste algoritmo
# 1. Fijar tamaño inicial n0.
# 2. Generarlos.
# 3. Si querías más precisión, genera

# --------------------------------------------------------------------------------
# Integración de MC
# Clásica
# Observación: la integral de h en [0,1] es la esperanza de h(X) con X ~> U(0,1)

# EG int. en [0,1] de 4x^4
h <- function(x) (4 * x^4) * (x > 0 & x < 1)
# visualizamos la función en el dominio de integración
curve(h, 0, 1)
# fijamos el número de simulaciones (n=nsim)
nsim <- 100
# calculamos la aproximación
set.seed(1)
x <- runif(nsim) # x1,...,xn
hx <- sapply(x, h) # h(x1),...h(xn)
mean(hx) # la aproximación final
# valor exacto
4 / 5
# --------------------------------------------------------------------------------
# gráfica de ello:
nsim <- 1000
set.seed(1)
x <- runif(nsim)
hx <- sapply(x, h)
# aproximaciones para $n=1,...,nsim$
estim <- cumsum(hx) / (1:nsim)
# errores de estimación correspondientes
estim.err <- sqrt(cumsum((hx - estim)^2)) / (1:nsim)
plot(1:nsim, estim,
    type = "l", ylab = "Aproximación y límites de error",
    xlab = "Número de simulaciones"
)
z <- qnorm(0.025, lower.tail = FALSE)
lines(estim - z * estim.err, col = "blue", lwd = 2, lty = 3)
lines(estim + z * estim.err, col = "blue", lwd = 2, lty = 3)
abline(h = 4 / 5, col = 2)
# Aproximación final y su error
estim[nsim]
estim.err[nsim]
# --------------------------------------------------------------------------------
# Caso general: integrales con límites infinitos
# idea: factorizar la función en producto de f densidad por otra
# I = \int h(x) = \int c(x)f(x) = E[c(X)]
# ~~> I \aproxeq 1/n \sum c(X_i)
# EG \int_2^\infty \frac{e^{-x^2/2}}{\sqrt{2\pi}}dx
# ~~> c(x) = I(x>2)

nsim <- 1000
set.seed(1)
x <- rnorm(nsim) # x1,...,xn
cc <- function(x) (x > 2)
cx <- cc(x) ## c(x1),...,c(xn)
# aproximación:
mean(cx)
# error
qnorm(0.025, lower.tail = FALSE) * sd(cx) / sqrt(nsim)
# valor exacto
pnorm(2, lower.tail = FALSE)
# --------------------------------------------------------------------------------
# ej la misma integral pero con límite inferior en 4.5
nsim <- 1000
set.seed(1)
x <- rnorm(nsim) # x1,...,xn
cc <- function(x) (x > 4.5)
cx <- cc(x) ## c(x1),...,c(xn)
# aproximación:
mean(cx)
# error
qnorm(0.025, lower.tail = FALSE) * sd(cx) / sqrt(nsim)
# valor exacto
pnorm(4.5, lower.tail = FALSE)
# Falla para valores muy pequeños

#
# --- 5.4.2 MUESTREO POR IMPORTANCIA ---------------------------------------------------
#

# Idea: cambiar la función de densidad por otra con una cola más pesada
# generar Z_1..Z_n desde f densidad g(z) con soporte incluyendo el de f(x)
# I = \int c(x) f(x) dx = \int c(z) w(z) g(z) dz = E[c(Z)w(Z)]
# w(z) = f(z)/g(z)
# ~~> I \aproxeq 1/n \sum c(Z_i)w(z_i)

nsim <- 1000
set.seed(1)
z <- rexp(nsim) + 4.5
w <- dnorm(z) / dexp(z - 4.5)
boxplot(w)
# aproximación:
mean(w)

# error
qnorm(0.025, lower.tail = FALSE) * sd(w) / sqrt(nsim)


# assigning values to variables
a <- 1
b <- 1
c <- -1

# test 1 solving the quadratic equation
(-b + sqrt(b^2 - 4*a*c) / (2*a))
(-b - sqrt(b^2 - 4*a*c) / (2*a))

# test 2 using the correct formula
(-b + sqrt(b^2 - 4*a*c)) / (2*a)
(-b - sqrt(b^2 - 4*a*c)) / (2*a)

# assisgning solutions
solution1 <- (-b + sqrt(b^2 - 4*a*c)) / (2*a)
solution2 <- (-b - sqrt(b^2 - 4*a*c)) / (2*a)


## Author: Sergio García Prado

rm(list = ls())

## a)
####

##
## Asymptotic distibution of lambda.hat as parameter lambda of Pois(lambda)
## lambda.hat ~ N(lambda, lambda / n)
##

## b)
####
n <- 50
y <- 75  # sum(x_i)
alpha <- 0.05

LogLikelihood <- function(lambda, y, n) {
  y * log(lambda) - n * lambda
}

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

opt <- optim(runif(1), NegativeLogLikelihood, y = y, n = n, hessian = TRUE,
             lower = 10e-3, upper = 10e3, method="Brent")

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

(lambda.hat.var <- 1 / opt$hessian[1])
# 0.0299999723347587

## Wald's Confidence Interval at (1 - alpha)% level.
lambda.hat + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(lambda.hat.var)
# 1.16052441137235 1.83947553876206

## c)
####
lambda.zero <- 1

(W <- (lambda.hat - lambda.zero) ^ 2 / lambda.hat.var)
# 8.33334018703586

(W.pvalue <- 1 - pchisq(W, df = 1))
# 0.00389240243808919

## d)
####

(LRT <- 2 * (LogLikelihood(lambda.hat, y, n) - LogLikelihood(lambda.zero, y, n)))
# 10.8197662162247

(LRT.pvalue <- 1 - pchisq(LRT, df = 1))
# 0.0010042216868813


stirling <- function(z) sqrt(2*pi/z) * (exp(-1)*z)^z

nemes <- function(z) sqrt(2*pi/z) * (exp(-1)*(z + (12*z - (10*z)^-1)^-1))^z

lanczos <- function(z)
{
   if(length(z) > 1)
   {
      sapply(z, lanczos)
   } else
   {
     g <- 7
      p <- c(0.99999999999980993, 676.5203681218851, -1259.1392167224028,
        771.32342877765313, -176.61502916214059, 12.507343278686905,
        -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7)
      z <- as.complex(z)
      if(Re(z) < 0.5)
      {
         pi / (sin(pi*z) * lanczos(1-z))
      } else
      {
         z <- z - 1
         x <- p[1] + sum(p[-1]/seq.int(z+1, z+g+1))
         tt <- z + g + 0.5
         sqrt(2*pi) * tt^(z+0.5) * exp(-tt) * x
      }
   }
}

spouge <- function(z, a=49)
{
   if(length(z) > 1)
   {
      sapply(z, spouge)
   } else
   {
      z <- z-1
      k <- seq.int(1, a-1)
      ck <- rep(c(1, -1), len=a-1) / factorial(k-1) * (a-k)^(k-0.5) * exp(a-k)
      (z + a)^(z+0.5) * exp(-z - a) * (sqrt(2*pi) + sum(ck/(z+k)))
   }
}

# Checks
z <- (1:10)/3
all.equal(gamma(z), stirling(z))             # Mean relative difference: 0.07181942
all.equal(gamma(z), nemes(z))                # Mean relative difference: 0.003460549
all.equal(as.complex(gamma(z)), lanczos(z))  # TRUE
all.equal(gamma(z), spouge(z))               # TRUE
data.frame(z=z, stirling=stirling(z), nemes=nemes(z), lanczos=lanczos(z), spouge=spouge(z), builtin=gamma(z))


source('D:\\_VSB\\S8\\PS\\Beres\\GitPS\\CV2\\kombinatorika.R')
#Kolik hesel o délce 15 znaků lze vygenerovat z velkých a malých písmen anglické abecedy,
#má-li heslo obsahovat alespoň jedno velké písmeno a alespoň jedno malé písmeno?

#Počet hesel o délce 15 znaků z 52 znaků, alespoň 2*26 znaků
#Vypočítáme kolika různými způsoby se dá sestavit heslo o 15 místech z 52 znaků
#od této hodnoty odečteme způsoby sestavení, které by podmínku alespoň dvou porušily

variace_opak(52,15)-2*variace_opak(26,15)

#Ve třídě je 12 nadějných studentů, z nichž je možno sestavit tříčlenné soutěžní družstvo.
#Mezi těmito studenty jsou dvě dívky (Anička a Bára), které nejsou schopny spolupracovat,
#a tudíž je nejde do družstva zařadit obě najednou. Kolika způsoby lze provést výběr členů soutěžního družstva?

#Vypočítáme kolika způsoby lze sestavit družstvo a odečteme kolika způsoby lze sestavit tým, ve kterém by byly dívky spolu
n = 12
k = 3
x = 2
kombinace(n,k)-kombinace(n-x,k-x)
kombinace(12,3)-kombinace(12-2,3-2)

#Z dopravních statistik vyplývá, že u 10 % řidičů, kteří způsobili dopravní nehodu, bylo prokázáno požití alkoholu.
#V literatuře se uvádí, že riziko nehody se požitím alkoholu zvyšuje 7x. Na základě uvedených údajů odhadněte, kolik procent řidičů požilo před jízdou alkohol.

#A = Alkohol
#N = Nehoda
#6/7*x=0.1
#x=1/10/6/7
#x=7/60

#Bayesova věta
P_O = c(0.1, 0.9)   #    P(O.),    P(O-)
P_PO = c(1/7, 6/7) # P(P.|O.), P(P.|O-)
bayes(P_B = P_O, P_AB = P_PO, k = 1)

#Hladina vody v tankeru je kontrolována pomocí čtyř na sobě nezávislých spínačů stejného typu zapojených dle obrázku. Spínače mají být sepnuty při nízké hladině vody.
#Je-li hladina vody dostatečná, spínače by měly být vypnuty. Každý ze spínačů je s pravděpodobností 10 % v opačném stavu, než by měl být. Ve chvíli,
#kdy se propojí uzly A a B (tj. např. sepnou spínače 1 a 4), je vyhlášen poplach.

#S jakou pravděpodobností kontrolní systém (viz obrázek) vyhlásí poplach v případě, že v tankeru je nízká hladina vody?
#Rozdělíme obvod na paralelní bloky P1 a P2, kde P1 obsahuje spínače 1 a 2, P2 obsahuje 3 a 4.
#V paralelních blocích se šance na chybu změnšuje, ale mezi paralelními bloky, které jsou zapojeny sériově, se šance na chybu zvětšuje

P1 = 0.1*0.1
P2 = 0.1*0.1
(1 - P1)*(1 - P2)*100

#S jakou pravděpodobností kontrolní systém (viz obrázek) vyhlásí falešný poplach, tj. poplach v případě, že v tankeru je dostatečná hladina vody?
#V tomto případě použijeme stejný výpočet, ale otočíme pravděpodobnost spínačů na správný stav
P1 = 0.9*0.9
P2 = 0.9*0.9
(1 - P1)*(1 - P2)*100

variace(n=3,k=2)
kombinace(n=5,k=3)-kombinace(n=3,k=2)
kombinace(n=3,k=3)
kombinace(n=2,k=2)
kombinace(n=3,k=2)*2
kombinace(n=12,k=3)
kombinace(n=11,k=3)
kombinace(n=11,k=3)*2

kombinace(n=3,k=3)
1
kombinace(n=1,k=1)
kombinace(n=4,k=3)
2
kombinace(n=2,k=1)
kombinace(n=5,k=3)
3
kombinace(n=3,k=1)
kombinace(n=6,k=3)
4
kombinace(n=4,k=1)
kombinace(n=7,k=3)
5
kombinace(n=5,k=1)

kombinace(n=4,k=2)
kombinace(n=4,k=2)
kombinace(n=4,k=1)
kombinace(n=4,k=3)

123
124
134
234

123
124
125
126
134
135
136
145
146
156
234
235
236
245
246
256
345
346
356
456

k = 18
v1 = variace_opak(n = 26, k = k)
v2 = variace_opak(n = 52, k = k)
v3 = variace_opak(n = 62, k = k)
v1
v2
v3/60/60/24/365/1000
v2/v1


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

rm(list = ls())

## Test over sample 1.

y1 <- c(9, 3, 8, 14, 2, 13, 12, 19, 9, 4)

(k <- length(y))
# 10

(n1 <- sum(y1))
# 93

(e1 <- rep(1 / k * n1, k))
# 9.3 9.3 9.3 9.3 9.3 9.3 9.3 9.3 9.3 9.3

(Q1 <- sum((y1 - e1) ^ 2 / e1))
# 27.9677419354839

(pvalue1 <- 1 - pchisq(Q1, k - 1))
# 0.000965777402160084

## Test over sample 2.

y2 <- c(3, 4, 2, 14, 5, 6, 3, 17, 14, 12)

(n2 <- sum(y2))
# 80

(e2 <- rep(1 / k * n2, k))
# 8 8 8 8 8 8 8 8 8 8

(Q2 <- sum((y2 - e2) ^ 2 / e2))
# 35.5

(pvalue2 <- 1 - pchisq(Q2, k - 1))
# 4.8618021638136e-05

## Test between samples 1 and 2.

(y <- (y1 + y2))
# 12 7 10 28 7 19 15 36 23 16

a <- y * n1 / (n1 + n2)
(Qa <- sum((y1 - a) ^ 2 / a))
# 9.40743669989997

(pvaluea <- 1 - pchisq(Qa, k - 1))
# 0.400545165490795

b <- y * n2 / (n1 + n2)
(Qb <- sum((y2 - b) ^ 2 / b))
# 10.9361451636337

(pvalueb <- 1 - pchisq(Qb, k - 1))
# 0.280111283415469


# Introducción a modelos lineales: Qué es OLS?

cat("\014")
rm(list=ls())
graphics.off()
options(scipen=9999999)

#######################################################
# Cual es la relacion entre educacion y prestigio?
#######################################################

# Creemos una base de datos imaginaria
base = data.frame(
        nombre = c("Pedro", "Juan", "Diego"),
        educacion = c(57,50,61), # vector de educacion
        prestigio = c(64,53,67)
        )

base # veamos como se ve nuestra base de datos.

# ahora veamos la relacion que existe entre ambas variables.
plot(base$educacion,base$prestigio) # Que tipo de relacion es esta? Positiva? Negativa?

# Ahora creemos un modelo, es decir, estimemos beta_1
modelo = lm(prestigio ~ educacion, data = base)

summary(modelo) # veamos que nos dice nuestro "modelo"
# interpretacion: Siempre partimos con nuestra X. Por cada unidad que subimos nuestra x (educacion), subimos la cantidad establecida en beta_1 (educacion) en nuestra y (prestigio). Supongamos que educacion esta medido en meses y prestigio en puntos. Esta sera nuestra unidad de medida. Es decir, si subo un mes de educacion, subo en prestigio 1.306 puntos. (Y ahi esta nuestra relacion positiva).

# a) Por que se llama "modelo"? Pista: esta es la parte mas "artistica" de la estadistica.
# b) Analogia del mapa.

# cuan bien funciona nuestro modelo? Ocupemos el comando "predict" ("predecir" en espanol).
predict(modelo)
# Aqui vemos lo siguiente

# Lo que observamos:
# Pedro tenia 64, pero nuestro modelo predice 62.63
# Juan tenia 53, pero nuestro modelo predice 53.49
# Diego tenia 67, pero nuestro modelo predice 67.85

# Discutir: Es esto "suficientemente bueno"?

# El concepto de "error". La diferencia entre lo que observamos y lo que modelamos. Derivar algeibraicamente abajo.

#######################################################
# Modelo OLS en matriz.
#######################################################

# vector para el error. Algebra simple...pero con comandos.
# Volvamos a la ecuacion de OLS:
# y = b0 + b1*x1 + e
# Reordenando los terminos, tenemos que e=
# e = y-beta0-beta1*x
# Hagamoslo con R...y metamos esos numeros en una nueva variable "error" dentro de nuestro objeto "base"

base$error <- c(
        base$prestigio[1] - as.numeric(modelo$coefficients[1]) - (base$educacion[1] * as.numeric(modelo$coefficients[2])),
        base$prestigio[2] - as.numeric(modelo$coefficients[1]) - (base$educacion[2] * as.numeric(modelo$coefficients[2])),
        base$prestigio[3] - as.numeric(modelo$coefficients[1]) - (base$educacion[3] * as.numeric(modelo$coefficients[2]))
        )

base

# Comprobemos que esta correcto
base$error
modelo$residuals

# vector para el intercepto. Ojo: es un intercepto para todos. Por eso no esta indexado.
base$intercepto <- c(
        as.numeric(
                modelo$coefficients[1]
                )
        )

# vector para el beta. Ojo: es un beta para todos. Por eso no esta indexado.
base$beta1 <- c(
        as.numeric(
                modelo$coefficients[2]
        )
)

base # llamemos al a base.

# Llevar esta base a matrices en OLS.

#######################################################
# Prediccion
#######################################################

x=base$educacion # crea objeto

y=base$prestigio  # crea objeto

lm.out <- lm(y ~ x) # estima modelo de nuevo. el mismo modelo.

newx = seq(min(x),max(x),by = 1) # crea sequencia de numeros para el rango X del grafico

conf_interval <- predict(lm.out, newdata=data.frame(x=newx), interval="confidence", level = 0.95)

# usando el modelo estimado, predice (a) distintos valores de educacion NO OBSERVADOS (fit), y el 95% de intervalo de confianza, con "lower bound" o "lwr" (parte de ABAJO del intervalo), y "upper bound" o "upr" (parte de ARRIBA del intervalo).

plot(x, y, xlab="Educ", ylab="Prest", main="Regression", ylim = c(30,90)) # ploteamos
abline(lm.out, col="lightblue") # agregamos linea "fit"
lines(newx, conf_interval[,2], col="blue", lty=2) # lower bound
lines(newx, conf_interval[,3], col="blue", lty=2) # upper bound

#######################################################
# Por que "least squares" ("cuadrados menores"?)
#######################################################

# los betas estimados, minimizan la suma de los "errores cuadrados".


###################################################################
# MDS and PCoA
#
# Reference: https://goo.gl/wUXSae
# https://goo.gl/ckSGFW
###################################################################

#==============================================================================
# LIBRARY DEPENDENCE
#==============================================================================
library(ggplot2)

# Load the data and add some whitenoise as control
data.matrix <- matrix(nrow=100, ncol=10)
colnames(data.matrix) <- c(
  paste("wt", 1:5, sep=""),
  paste("ko", 1:5, sep=""))
rownames(data.matrix) <- paste("gene", 1:100, sep="")
for (i in 1:100) {
  wt.values <- rpois(5, lambda=sample(x=10:1000, size=1))
  ko.values <- rpois(5, lambda=sample(x=10:1000, size=1))

  data.matrix[i,] <- c(wt.values, ko.values)
}
head(data.matrix)
dim(data.matrix)

#==============================================================================
# Computing PCA as reference
#==============================================================================
pca <- prcomp(t(data.matrix), scale=TRUE, center=TRUE)

## calculate the percentage of variation that each PC accounts for...
pca.var <- pca$sdev^2
pca.var.per <- round(pca.var/sum(pca.var)*100, 1)
pca.var.per

## now make a fancy looking plot that shows the PCs and the variation:
pca.data <- data.frame(Sample=rownames(pca$x),
  X=pca$x[,1],
  Y=pca$x[,2])
pca.data

ggplot(data=pca.data, aes(x=X, y=Y, label=Sample)) +
  geom_text() +
  xlab(paste("PC1 - ", pca.var.per[1], "%", sep="")) +
  ylab(paste("PC2 - ", pca.var.per[2], "%", sep="")) +
  theme_bw() +
  ggtitle("PCA Graph")

#==============================================================================
# PCoA
# 	PCA = PCoA if distance metric is Euclidean.
# 	Different distance metrics produces diferent results
#==============================================================================
distance.matrix <- dist(scale(t(data.matrix), center=TRUE, scale=TRUE),
					method="euclidean")

## do the MDS math (this is basically eigen value decomposition)
mds.stuff <- cmdscale(distance.matrix, eig=TRUE, x.ret=TRUE)

## calculate the percentage of variation that each MDS axis accounts for...
mds.var.per <- round(mds.stuff$eig/sum(mds.stuff$eig)*100, 1)
mds.var.per

## now make a fancy looking plot that shows the MDS axes and the variation:
mds.values <- mds.stuff$points
mds.data <- data.frame(Sample=rownames(mds.values),
						X=mds.values[,1],
						Y=mds.values[,2])
mds.data

ggplot(data=mds.data, aes(x=X, y=Y, label=Sample)) +
	geom_text() +
	theme_bw() +
	xlab(paste("MDS1 - ", mds.var.per[1], "%", sep="")) +
	ylab(paste("MDS2 - ", mds.var.per[2], "%", sep="")) +
	ggtitle("MDS plot using Euclidean distance")

#==============================================================================
# Log scale
#==============================================================================
log2.data.matrix <- log2(data.matrix)

# empty distance matrix
log2.distance.matrix <- matrix(0,
  nrow=ncol(log2.data.matrix),
  ncol=ncol(log2.data.matrix),
  dimnames=list(colnames(log2.data.matrix),
    colnames(log2.data.matrix)))

log2.distance.matrix

# now compute the distance matrix using avg(absolute value(log2(FC)))
for(i in 1:ncol(log2.distance.matrix)) {
  for(j in 1:i) {
    log2.distance.matrix[i, j] <-
      mean(abs(log2.data.matrix[,i] - log2.data.matrix[,j]))
  }
}
log2.distance.matrix

## do the MDS math (this is basically eigen value decomposition)
## cmdscale() is the function for "Classical Multi-Dimensional Scalign"
mds.stuff <- cmdscale(as.dist(log2.distance.matrix),
  eig=TRUE,
  x.ret=TRUE)

## calculate the percentage of variation that each MDS axis accounts for...
mds.var.per <- round(mds.stuff$eig/sum(mds.stuff$eig)*100, 1)
mds.var.per

## now make a fancy looking plot that shows the MDS axes and the variation:
mds.values <- mds.stuff$points
mds.data <- data.frame(Sample=rownames(mds.values),
  X=mds.values[,1],
  Y=mds.values[,2])
mds.data

ggplot(data=mds.data, aes(x=X, y=Y, label=Sample)) +
  geom_text() +
  theme_bw() +
  xlab(paste("MDS1 - ", mds.var.per[1], "%", sep="")) +
  ylab(paste("MDS2 - ", mds.var.per[2], "%", sep="")) +
  ggtitle("MDS plot using avg(logFC) as the distance")


var.test <- function() { # var.test.r
 x <- c(21.6,20.8,17.6,20.1,20.1,21.9,20.6,19.4,21.5,26.1)
 y <- c(20.6,20.4,20.2,20.2,18.0,19.8,20.9,19.7,20.3,19.7,22.7)
 mm <- length(x);  nn <- length(y)

 F0 <- sd(x)^2/sd(y)^2
 F0
 if (F0 >= 1)  p.val <- 2*(1- pf(F0, mm-1, nn-1))
 else  p.val <- 2*pf(F0, mm-1, nn-1)
 p.val

 lbd <- 1/qf(0.975, mm-1, nn-1)*var(x)/var(y)
 ubd <- 1/qf(0.025, mm-1, nn-1)*var(x)/var(y)
 ci <-  c(lbd, ubd)
 list(F0=F0, p.val=p.val, ci=ci)
}


#03. 지수분포
# 확률밀도함수: d~
# 누적분포함수(점수): p~ 건수로 확률 추출
# 누적분포함수(확률): q~ 확률로 건수(시간) 추출

# 지수분포 누적확률계산
# 이하 : P(X <= a) lower.tail = TRUE
# 초과: P(X > a) lower.tail = FALSE
# pexp(q=대기시간, rate=평균발생건수(λ))
# 서비스센터 사례 - 평균발생건수: 5분에 1.5회
# 1분 P(X<=1/5) 이내로 받을 확률

pexp(q=1/5, rate=1.5, lower.tail = TRUE)

# 95%확률로 받을 수 있는 시간
qexp(p=0.95, rate=1.5, lower.tail = TRUE) # 누적하면 95% 이하이므로 (10분에 1콜이 무조건 온다.)

# 지수분포 누적확률 gra ph
x <- seq(0, 3, length = 500) # 0부터 3까지 500로 쪼개서 넣어라. 여기서는 단위가 5분이니까 숫자 1 = 5분이 된다.
plot(x,
     dexp(x, 1.5), # x 각각의 값을 y축에 뿌려주어라.
     type = "l",
     ylim = c(0,1.5))

# 그래프의 의미 : 대기시간이 x에 도달 했을 때까지 전화를 못받을 확률을 알아보는 것.

abline(h=0.2,  # 그래프에 선을 그려주는 함수. h= 가로선이 그려짐
       col="red",
       lty=1) # line 유형

# 10분에 평균 2회 전화, 3분 이내에 전화를 받을 확률 P(X<=3/10) 이하의 개념 이므로 lower.tail = TRUE
pexp(q=3/10, rate=2, lower.tail = TRUE)

# 95%확률로 받을 수 있는 시간 : 15분 이내에 무조건 전화 한번은 받는다. (95% 확률로)
qexp(p=0.95, rate=2, lower.tail = TRUE)

# 부록 ggplot2 이용
library(ggplot2)
ggplot(data.frame(x=c(0,3)), aes(x=x)) +
  stat_function(fun=dexp,
                args=list(rate=1.5),
                colour="red", size=1.5) +
  ggtitle("Exponential Distribution")


############################
# Visualization of Newton's and Halley's Method
# demo of the Convergance Interval for both
# https://www.youtube.com/OscarVeliz
# @author Oscar Veliz
############################
hyperx <- a <- b <- c <- 0
center <- 0
range <- 4
cap <- 2000 #maximum value for hyperbola
stepsize <- .001 #when generating points
eps <- 10^-7 #epsilon
hyperbola <- function(x) (x - hyperx + c) / (a*(x - hyperx)+b)
max <- 5
colors <- rainbow(max)
colors[2] <- c('darkgoldenrod1')#otherwise you can't see it
colors[3] <- c('chartreuse3')#same here
############################
# Change the following functions
############################
name <- "arctan(x)"
f <- function(x) atan(x)
fp <- function(x) 1.0 / (x^2 + 1)
fp2 <- function(x) (-2*x) / ((x^2+1)^2)
newtstep <- function(x) f(x) / fp(x)
halleystep <- function(x){
	fx = f(x)
	fpx = fp(x)
	(2*fx*fpx) / (2*fpx^2 - fx*fp2(x))
}
#####################
# Plots Newton's or Halley's Method
# @param xn starting x
# @param gam gamma (damping value)
# @param useNewt TRUE Newton, FALSE Halley
##################################
plotNewton <- function(xn = 1, gam = 1, useNewt = TRUE){
	if(useNewt)
		method = "Newton"
	else
		method = "Halley"
	print(paste(method,"Method"))
	svg(paste(method,"Plot.svg",sep = ""), bg = 'transparent')
	plot(f, center - range, center + range, xlab = paste("start =", xn,"gamma =",gam, sep = " "), ylab = " ", cex.lab = 1.4, cex.axis = 1.4, bg = 'transparent')
	title(main = "", sub = "x", cex.sub = 1.4, cex.main = 1.5 , xlab = " ", ylab = name, cex.axis = 1.4, cex.lab = 1.4, line = 2)
	title(main = paste(method,"'s Method", sep = ""), cex.main = 1.5 , xlab = "", ylab = "", line = .7)
	abline(a = 0, b = 0)#x axis
	if(useNewt){#Newton Plot
		for(n in 1:max){
			print(paste("x",n," = ",xn,sep=""))
			segments(xn, 0 , xn, f(xn), lty = "dashed", col = colors[n])#connect to axis
			points(xn, f(xn), col = colors[n])#draw point (xn, f(xn))
			text(xn, y = 0.05, labels = bquote(x[.(n)]), col = colors[n])#label x's
			abline(a = (fp(xn) * (-xn) + f(xn)), b = fp(xn), col = colors[n])#y=a+bx
			xn = xn - gam * newtstep(xn)#newton's method
		}
	}
	else{#Halley Plot
		xpoints = seq(center - range, center + range, stepsize)
		for(n in 1:max){
			print(paste("x",n," = ",xn,sep=""))
			denom = 2*fp(xn)^2-f(xn)*fp2(xn)
			hyperx <<- xn
			a <<- (-fp2(xn)) / denom
			b <<- (2*fp(xn)) / denom
			c <<- (2*f(xn)*fp(xn)) / denom
			segments(xn, 0 , xn, f(xn), lty = "dashed", col = colors[n])#connect to axis
			points(xn, f(xn), col = colors[n], pch = '.' )#draw point (xn, f(xn))
			text(xn, y = 0.05, labels = bquote(x[.(n)]), col = colors[n])#label x's
			ypoints = hyperbola(xpoints)
			#sanitize to remove asymptote connection
			for(i in 1:length(ypoints))
				if(abs(ypoints[i])>cap)
					ypoints[i] = NA
			lines(xpoints,ypoints,col = colors[n])
			points(xn, f(xn), col = colors[n])#draw point (xn, f(xn))
			xn = xn - gam * halleystep(xn)#halley's method
			if(abs(f(xn))<eps)
				break;
		}
	}
	print(paste("x = ",xn,sep=""))
}
#####################
# Plots Halley's Method
# @param xn starting x
# @param gam gamma (damping value)
# @param max maximum number of iterations to display
##################################
plotHalley <- function(xn = 1, gam = 1) plotNewton(xn,gam,useNewt=FALSE)

#####################
# Plots Convergance Interval
# Default values assume converges at center and
# diverges at ends. Otherwise makes incorrect plot.
# @param ld left diverge value
# @param lc left converge value
# @param rc right converge value
# @param rd right diverge value
# @param gam gamma damping value
# @param useNewt TRUE Newton, FALSE Halley
##################################
plotInterval <- function(ld = center - range, lc = center, rc = center, rd = center + range, gam = 1, useNewt = TRUE){
	if(useNewt)
		method = "Newton"
	else
		method = "Halley"
	print(paste(method,"Convergence Interval"))
	svg(paste(method,"ConvergenceInterval",".svg", sep = ""), bg = 'transparent')
	while(abs(lc - ld) >= eps || abs(rd - rc) >= eps){
		print(paste(ld,"[",lc,",",rc,"]",rd))
		if(abs(lc - ld) >= eps){#left side
			converging = FALSE
			x = (lc + ld) / 2.0 #midpoint between conv and div
			for(n in 1:10){#test a few iterations to see if conv
				if(useNewt)
					x = x - gam * newtstep(x)
				else
					x = x - gam * halleystep(x)
				if(x >= lc && x <= rc)
					converging = TRUE
				if(x < ld || x > rd)
					break
			}
			if (converging)
				lc = (lc + ld) / 2.0
			else
				ld = (lc + ld) / 2.0
		}
		if(abs(rc - rd) >= eps){#repeat with right side
			converging = FALSE
			x = (rc + rd) / 2.0
			for(n in 1:10){
				if(useNewt)
					x = x - gam * newtstep(x)
				else
					x = x - gam * halleystep(x)
				if(x >= lc && x <= rc)
					converging = TRUE
				if(x < ld || x > rd)
					break
			}
			if (converging)
				rc = (rc + rd) / 2.0
			else
				rd = (rc + rd) /2.0
		}
	}
	print(paste(ld,"[",lc,",",rc,"]",rd))
	#plot the interval
	plot(f, center - range, center + range, xlab = paste("gamma =", gam, "[", lc, ",", rc,"]", sep = " "), ylab = " ", cex.lab = 1.4, cex.axis = 1.4,)
	title(main = "", sub = "x", cex.sub = 1.4, cex.main = 1.5 , xlab = " ", ylab = name, cex.axis = 1.4, cex.lab = 1.4, line = 2)
	title(main = paste(method, "Convergence Interval",sep = " "), cex.main = 1.5 , xlab = "", ylab = "", line = .7)
	abline(a = 0, b = 0)#x axis
	for(x in seq(center - range + 0.1, center + range - 0.1, by = range/40))
		if(x >= lc && x <= rc)
			points(x, 0, col = c('chartreuse3'), pch = 15)
		else
			points(x, 0, col = c('firebrick3'), pch = 4)
}

### main
start <- 1.5
plotNewton(start)
plotHalley(start)
plotInterval()
plotInterval(useNewt = FALSE)


#' @title calcCwp
#'
#' @description Calculates the water plane area coefficient (\code{Cwp})
#' (dimensionless) using one of two methods (Kristensen or Schneekluth).
#'
#' @param Cbw Waterline block coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcCbw}})
#' @param CwpEquationType Indicates equation type:
#' \itemize{\item"kristensen"\item"schneekluth"}
#' This argument is not vectorized, as it takes only a single string
#'
#' @details
#'Kristensen:
#'\deqn{Cwp = 0.55+0.45Cbw}
#'
#'Schneekluth:
#'\deqn{Cwp = \frac{1+2Cbw}{3}}{Cwp = (1+2Cbw)/3}
#'
#' @return \code{Cwp} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2012. "Prediction of Resistance and Propulsion
#'Power of Ships. Clean Shipping Currents, 1 (6).
#'
#'Schneekluth, H. and Bertram, V. 1998. "Ship Design for Efficiency and Economy."
#'2nd ed. Oxford, Boston: Butterworth-Heinemann.
#'
#' @seealso \code{\link{calcCbw}}
#'
#' @examples
#' calcCwp(c(0.81,0.65),"kristensen")
#'
#' @export

calcCwp <- function(Cbw, CwpEquationType){

  if(grepl("kristensen", tolower(CwpEquationType))){
    Cwp<-0.55+0.45*Cbw
  }else{
    Cwp<-(1+2*Cbw)/3
  }

  return(Cwp)

}


#!/usr/bin/env Rscript

a = c(1,2,3)
# 显示是column vector
print(a)

# 显示的是行向量 [, x]
b = t(a)

7*a

# a列向量 b行向量, 为啥能相加
#     1 2 3
#  1
#  2
#  3
c1 = a + b

# 列向量相加
c2 = t(b) + a

# 行向量相加 == c1
c3 = b + t(a)

a = c(1,3,2)
a
b = c(2,8,9)
b
a + b
# 这个不是内积, 只是相乘
a*b
# 做求和运算(内积)
sum(a*b)

# 向量的length
sqrt(sum(a*a))

# 0-vector
rep(0, 5)

# 1-vector
rep(1, 3)

# (1,3) (2,2), (8,9) col by col
a = c(1,3)
b = c(2,2)
c = c(8,9)
A = matrix(c(a, b, c), ncol = 3)
A
A = matrix(c(a, b, c), ncol =3, byrow=T)
A

A1 = rbind(c(1, 3, 2), c(2, 8, 9))
A1

7*A1
t(A1)

B = matrix(c(5,8,3,4,2,7),ncol=3,byrow=T)
B
A+B

# A: 2x3  a:3x1
a = c(1, 3, 2)
# 注意形式: Aa
print(A)
print(A%*%a)
# ?????
print(A*a)


## The Heston Stochastic Volatility model
##
## - Closed form solution for a European call option
## - Monte Carlo solution (Absorbing at zero)
## - Monte Carlo solution (Reflecting at zero)
## - Monte Carlo solution (Reflecting at zero + Milstein method)
## - Monte Carlo solution (Alfonsi)
## - Plot implied volality surface
##
## Dale Roberts <dale.roberts@anu.edu.au>
##
## PARAMETERS
##
## lambda: mean-reversion speed
## vbar: long-term average volatility
## eta: volatility of vol process
## rho: correlation between stock and vol
## v0: initial volatility
## r: risk-free interest rate
## tau: time to maturity
## S0: initial share price
## K: strike price
##
## MODEL
##
## dS_t = S_t r dt + S_t sqrt(V_t)dW_t^S
## dV_t = \lambda (\vbar - V_t)dt - eta sqrt(V_t)dW_t^V
## with d<W^S,W^V>_t = \rho dt

ONEYEAR <- 250

Moneyness <- function(S, K, tau, r) {
    K*exp(-r*tau)/S
}

BlackScholesCall <- function(S0, K, tau, r, sigma, EPS=0.01) {
    d1 <- (log(S0/K) + (r + 0.5*sigma^2)*tau)/(sigma*sqrt(tau))
    d2 <- d1 - sigma*sqrt(tau)
    if (T < EPS) {
        return(max(S0-K,0))
    } else {
        return(S0*pnorm(d1) - K*exp(-r*(tau))*pnorm(d2))
    }
}

ImpliedVolCall <- function(S0, K, tau, r, price) {
    f <- function(x) BlackScholesCall(S0,K,tau,r,x) - price
    if (f(-1) * f(1) > 0)
        return(NA)
    uniroot(f,c(-1,1))$root
}

HestonCallClosedForm <-
    function(lambda, vbar, eta, rho, v0, r, tau, S0, K) {
	PIntegrand <- function(u, lambda, vbar, eta, rho, v0, r, tau, S0, K, j) {
            F <- S0*exp(r*tau)
            x <- log(F/K)
            a <- lambda * vbar

            if (j == 1) {
                b <- lambda - rho* eta
                alpha <- - u^2/2 - u/2 * 1i + 1i * u
                beta <- lambda - rho * eta - rho * eta * 1i * u
            } else {
                b <- lambda
                alpha <- - u^2/2 - u/2 * 1i
                beta <- lambda - rho * eta * 1i * u
            }

            gamma <- eta^2/2
            d <- sqrt(beta^2 - 4*alpha*gamma)
            rplus <- (beta + d)/(2*gamma)
            rminus <- (beta - d)/(2*gamma)
            g <- rminus / rplus

            D <- rminus * (1 - exp(-d*tau))/(1-g*exp(-d*tau))
            C <- lambda * (rminus * tau - 2/(eta^2) * log( (1-g*exp(-d*tau))/(1-g) ) )

            top <- exp(C*vbar + D*v0 + 1i*u*x)
            bottom <- (1i * u)
            Re(top/bottom)
	}

	P <- function(lambda, vbar, eta, rho, v0, r, tau, S0, K, j) {
            value <- integrate(PIntegrand, lower = 0, upper = Inf,
                               lambda, vbar, eta, rho, v0, r, tau,
                               S0, K, j, subdivisions=1000)$value
            0.5 + 1/pi * value
	}

        A <- S0*P(lambda, vbar, eta, rho, v0, r, tau, S0, K, 1)
        B <- K*exp(-r*tau)*P(lambda, vbar, eta, rho, v0, r, tau, S0, K, 0)
        A-B
    }

HestonCallMonteCarlo <-
    function(lambda, vbar, eta, rho, v0, r, tau, S0, K, nSteps=2000, nPaths=3000, vneg=2) {

        n <- nSteps
        N <- nPaths

        dt <- tau / n

        negCount <- 0

        S <- rep(S0,N)
        v <- rep(v0,N)

        for (i in 1:n)
            {
                W1 <- rnorm(N);
                W2 <- rnorm(N);
                W2 <- rho*W1 + sqrt(1 - rho^2)*W2;

                sqvdt <- sqrt(v*dt)
                S <- S*exp((r-v/2)*dt + sqrt(v * dt) * W1)

                if ((vneg == 3) & (2*lambda*vbar/(eta^2) <= 1)) {
                    cat("Variance not guaranteed to be positive with choice of lambda, vbar, and eta\n")
                    cat("Defaulting to Reflection + Milstein method\n")
                    vneg = 2
                }

                if (vneg == 0){
                    ## Absorbing condition
                    v <- v + lambda*(vbar - v)* dt + eta * sqvdt * W2
                    negCount <- negCount + length(v[v < 0])
                    v[v < 0] <- 0
                }
                if (vneg == 1){
                    ## Reflecting condition
                    sqvdt <- sqrt(v*dt)
                    v <- v + lambda*(vbar - v)* dt + eta * sqvdt * W2
                    negCount <- negCount + length(v[v < 0])
                    v <- ifelse(v<0, -v, v)
                }
                if (vneg == 2) {
                    ## Reflecting condition + Milstein
                    v <- (sqrt(v) + eta/2*sqrt(dt)*W2)^2 - lambda*(v-vbar)*dt - eta^2/4*dt
                    negCount <- negCount + length(v[v < 0])
                    v <- ifelse(v<0, -v, v)
                }
                if (vneg == 3) {
                    ## Alfonsi - See Gatheral p.23
                    v <- v -lambda*(v-vbar)*dt +eta*sqrt(v*dt)*W2 - eta^2/2*dt
                }
            }

        negCount <- negCount / (n*N);

        ## Evaluate mean call value for each path
        V <- exp(-r*tau)*(S>K)*(S - K); # Boundary condition for European call
        AV <- mean(V);
        AVdev <- 2 * sd(V) / sqrt(N);

        list(value=AV, lower = AV-AVdev, upper = AV+AVdev, zerohits = negCount)
    }

HestonSurface <- function(lambda, vbar, eta, rho, v0, r, tau, S0, K, N=5, min.tau = 1/ONEYEAR) {
    LogStrikes <- seq(-0.5, 0.5, length=N)
    Ks <- rep(0.0,N)
    taus <- seq(min.tau, tau, length=N)
    vols <- matrix(0,N,N)

    TTM <- Money <- Vol <- rep(0,N*N)

    HestonPrice <- function(K, tau) {
        HestonCallClosedForm(lambda, vbar, eta, rho, v0, r, tau, S0, K)
    }

    n <- 1
    for (i in 1:N) {
        for (j in 1:N) {
            Ks[i] <- exp(r * taus[j]+LogStrikes[i]) * S0
            price <- HestonPrice(Ks[i],taus[j])
            iv <- ImpliedVolCall(S0, Ks[i], taus[j], r, price)
            TTM[n] <- taus[j] * ONEYEAR # in days
            Money[n] <- Moneyness(S0,Ks[i],taus[j],r)
            Vol[n] <- iv
            n <- n+1
        }
    }

    data.frame(TTM=TTM, Moneyness=Money, ImpliedVol=Vol)
}

PlotHestonSurface <-
    function(lambda=6.21, vbar=0.019, eta=0.61, rho=-0.7, v0=0.010201, r=0.0319,
             tau=1.0, S0=100, K=100, N=30, min.tau = 1/ONEYEAR, ...) {

        Ks <- seq(0.8*K, 1.25 * K, length=N)
        taus <- seq(0.21, tau, length=N)

        HestonPrice <- Vectorize(function(k, t) {
            HestonCallClosedForm(lambda, vbar, eta, rho, v0, r, t, S0, k)})

        IVHeston <- Vectorize(function(k,t) { ImpliedVolCall(S0, k, t, r, HestonPrice(k,t))})

        z <- outer(Ks, taus, IVHeston)

        nrz <- nrow(z)
        ncz <- ncol(z)
        nb.col <- 256
        color <- heat.colors(nb.col)
        facet <- - (z[-1, -1] + z[-1, -ncz] + z[-nrz, -1] + z[-nrz, -ncz])
        facetcol <- cut(facet, nb.col)

        persp(x=Ks, y=taus, z, theta = 40, phi = 20, expand = 0.5, col=color[facetcol],
              xlab="Strikes", ylab="Time to maturity", zlab="Implied Volatility",
              ticktype="detailed", ...) -> res

        return(invisible(z))
    }


## 1. Multiple Random Experiments ##

p_a <- 12/100
p_b <- 17/100
p_a_and_b <- 3/100
p_a_or_b <- p_a + p_b - p_a_and_b

## 2. The Multiplication Rule ##

p_6_6 <- 1/6 * 1/6
p_3_2 <- 1/6 * 1/6
p_even_even <- 3/6 * 3/6
p_1_even <- 1/6 * 3/6

## 3. Independent Events ##

sql_and_ml <- 0.2 * 0.3
ml_or_viz <- 0.3 + 0.4 - (0.3 * 0.4)
at_least_one_skill <- 0.2 + 0.3 + 0.4 - (0.2 * 0.3) - (0.2 * 0.4) - (0.3 * 0.4) - (0.2 * 0.3 * 0.4)

## 4. Independence vs Mutual Exclusivity ##

sql_and_ml_me <- 0
ml_or_viz_me <- 0.3 + 0.4
at_least_one_skill_me <- 0.2 + 0.3 + 0.4

## 5. Complements ##

p_complement_even <- 1/2
p_complement_ace <- 48/52

## 6. Using Complements With Probability ##

p_one_double_6 <- 1 - (35/36)**24

## 7. Another Application: Detecting Dependence ##

p_intersection <- (0.1 * 0.17)
is_independent <- p_intersection == 0.08

Data Analyst in R/Step 5 - Probability and Statistics/3. Probability Fundamentals in R/3. Probabilities of Multiple Random Experiments.r


#задание 2
print ("task 2")
A <- matrix (c(-1,-3,-6,0,-3,3,-11,0,-8,-5,-5,-1,4,-7,-7,-5,-9,-7,-1,-8,11,-7,2,4,3,-4,7,10,4,8,-10,3,-5,-11,7,9),6,6)
A
#определитель
det(A) # Определитель A
#обратная
solve(A)
#транспон
t(A)
#задание 3
print ("task 3")
a <- c(2,-3,3,5,1) #
print ("Answer on the second task")
polyroot(a)

#задание 4
print ("task 4")
Q <- cbind(c(1,2,1),c(1,3,2),c(7,0,-1)) # Составить матрицу из трех столбцов-векторов
Q
d <- eigen(Q)$values;d
d1 <- round(d, 3); d1
D <- diag(d1); D

#задание 5
print ("5 task")
a <- c(1,5,-1,2,0,6,-2,1,1,-3,5,1)
b <- c(0,2,3,1,-4,-1,0,2,1,4,1,3)
p <- c(-3,0,-1,-1,0,4,3,2,-5,1,1,-6)

fir <- ((3)*a)-(4*b)
print ("first answer")
fir
sec <- ((2)*as.numeric(a%*%b))*p+2*(norm(p, type="2"))*a
print ("second answer")
sec
thr <- 3*as.numeric(a%*%p)*b+2*as.numeric(b%*%p)*a-2*(norm(p, type="2"))*p
print ("third answer")
thr

#6 задание
print ("sixth task")
install.packages("lpSolveAPI") # Загружаем библиотеку
library(lpSolveAPI) # Активируем библиотеку линейного программирования
M <- make.lp(ncol= 2) # Объявляем количество неотрицательных переменных в M
name.lp(M, "Example") # Объявляем название "Example"для задачи(модели) М
colnames(M) <- c("X1", "X2") # Объявляем названия переменных в модели М
lp.control(M, sense = "min")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(22,25)) # Задаем целевую функцию:
add.constraint(M, c(6,8), "<=", 80) # Задаем ограничение:
add.constraint(M, c(4, 6), "<=",120) #
add.constraint(M, c(4, 5), "<=",70) #
add.constraint(M, c(1, 0), "<=",12)
add.constraint(M, c(0, 1), "<=",14)

rownames(M) <- c("A", "B","C","D","E") # Называем ограничения в модели М
M # Выводим модель M на экран
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M) # Достигнутый min
X1.opt<- get.variables(M)[1]; X1.opt # Оптимальное значение для X1
X2.opt<- get.variables(M)[2]; X2.opt # Оптимальное значение для X2
f.max<- get.objective(M); f.max# Значение целевой функции на оптимальном решении


# Logistic model.
N <- function(t, r, K, N0) { K / (1 + ((K-N0)/N0)*exp(-r*t)) }

# Params.
k = 2000       # carrying capacity
n0 = 100       # initial population
R = 0.1        # rate of increase

plot(N(1:100, R, k, n0), t='l', lwd=2, col='blue', ylim=c(0, k),
     main='Logistic model for population growth in an environment')
abline(h=k)
abline(h=0)


# Function to propagate errors on individual aliquots through the D47 averages
# Based on: "Combining Multiple Averaged Data Points And Their Errors" by Ken Tatebe
# Iterative approach adding datapoints and propagating uncertainty

average_p <- function(x, x_sd, n = NA, verbose = FALSE, output = "SD"){
    if(is.na(n)){
        n = rep(1, length(x))
    }
    N <- n[1] + n[2] # Calculate sample size for first 2 samples
    average <- (x[1] * n[1] + x[2] * n[2]) / N # Calculate weighted average for first 2 samples
    sd_p <- sqrt(n[1]) # Calculate weighted standard deviation for first 2 samples
    for(i in 3:length(x)){ # Loop over x and their uncertainties x_sd
        sd_p <- sqrt(
            (N ^ 2 - N) / ((N + n[i]) ^ 2 - (N + n[i])) * sd_p ^ 2 + # Existing error term
            (n[i] ^ 2 - n[i]) / ((N + n[i]) ^ 2 - (N + n[i])) * x_sd[i] ^ 2 + # Error term of new datapoint
            N * n[i] * (average - x[i]) ^ 2 / ((N + n[i]) * ((N + n[i]) ^ 2 - (N + n[i]))) # Term resulting from distance between points
        )
        average <- (average * N + x[i] * n[i]) / (N + n[i]) # Increment total average
        N <- N + n[i] # Increment total sample size
    }
    resultvec <- c(average, sd_p, N)
    names(resultvec) <- c("average", "sd", "N")
    if(output == "SD"){
        return(resultvec[2])
    } else if(output == "All"){
        return(resultvec)
    } else{
        return("Error: output string not recognized")
    }
}

# Repeat calculations based on Monte Carlo simulations

propagate_MC <- function(x, x_sd, n = NA, Nsim = 10 ^ 4, verbose = FALSE, na.rm = TRUE, output = "SD"){ # Monte Carlo approach to estimate same errors
    if(is.na(n)){
        n = rep(1, length(x))
    }

    sims <- rep(NA, sum(Nsim * n)) # Vector to store simulated values
    for(i in 1:length(x)){
        sims[which(is.na(sims))[1]:(which(is.na(sims))[1] + Nsim * n[i] - 1)] <- rnorm(Nsim * n[i], x[i], x_sd[i]) # Add simulated values to vector
    }

    if(na.rm == TRUE){
        if(length(which(is.na(sims))) > 0){
            sims <- sims[-which(is.na(sims))] # Remove NA's from sims if called for
        }
    }

    average <- mean(sims) # Calculate average
    sd_p <- sd(sims) # Calculate standard deviation
    N <- length(sims) / Nsim # Calculate effective sample size

    resultvec <- c(average, sd_p, N)
    names(resultvec) <- c("average", "sd", "N")

    if(verbose == TRUE){
        print(resultvec)
    }
    if(output == "SD"){
        return(resultvec[2])
    } else if(output == "average"){
        return(resultvec[1])
    } else if(output == "All"){
        return(resultvec)
    } else if(output == "sims"){
        return(sims)
    } else{
        return("Error: output string not recognized")
    }
}


rm(list=ls())

# [1]
# a) Unfair coin and you flip 8 times. Probability heads is 0.4. What's the probability to have 2 heads?
# b) 8 athletes to compete in Olympic Games. Probability of making the final race is 0.4. What's the probability that 2 athletes make it into the final race?
dbinom(2,8,0.4)

# [2]
# a) Expectation number of heads
# b) Expectation number of athletes that make it into the finals

# E[Successes|N = 8] = n*p
E_successes_n_8 = 8*0.4

# [3]
# Supose E[N]=2 and var(N)=1.5
E_n = 2
Var_n = 1.5

# a) What is the expectation of the number of heads?
# b) What is the expectation of the number of swimmers that make it to the final?

# E[successes] = E[E[successes|N]] -> expectation of expectation of conditional
# E[E[successes|N = n]] = E[N*p] = 0.4*E[N] =>
E_successes = 0.4*E_n

# a) What is the variance of the number of heads?
# b) What is the variance of the number of swimmers that make it to the final?

# Var(success) = Var(E[successes|N]) + E[Var(successes|N)]
# we know of binomial:
#       E[successes|N] = n*p
#       Var(sucesses|N) = n*p*(1-p)
#
# so we get => Var(N*p) + E[N*p*(1-p)] => p^2*Var(N) + p*(1-p)*E[N]
Var_successes = 0.4^2*Var_n + 0.4*(1 - 0.4)*E_n


library(lpSolve)

#Linear Programing (LP)

f.Obj<-c(2,3)

##set constraint matrix coefficient
f.con<-matrix(c(1,3,
                2.5,1),nrow=2,byrow=TRUE)

## equality signs

f.dir <- c("<=",
           "<=")

## set right hand side coefficient

f.rhs <- c(8.25,
           8.75)

##Final value of obj

Z1 <- lp("max", f.Obj,f.con, f.dir, f.rhs)

Z1$solution
Z1

##### Mixed Linear Integer Programming (MIP)

Z2 <- lp("max", f.Obj,f.con, f.dir, f.rhs,int.vec = 1:2)
Z2$solution
Z2


# confidence interval for indpendent sample
fresh=c(10.2, 10.6,10.5 ,10.7,10.3, 10.2,10.8, 10.0,9.8 ,10.6 )
stored=c( 9.8, 9.7,
          9.6, 9.5,
          10.1, 9.6,
          10.2, 9.8,
          10.1 ,9.9)
n1=length(fresh)
n2= length(stored)
y1bar = mean(fresh)
y2bar=mean(stored)
s1=sd(fresh)
s2=sd(stored)
# common standard deviation
sp=sqrt(((n1-1)*s1*s1+(n2-1)*s2*s2)/(n1+n2-2))

# the t-percentile based on df for 95% confidence interval
tstar=qt( .975, df=18)
 margin=tstar*sp*sqrt((1/n1)+(1/n2))
 left_i=(y1bar-y2bar)-margin
 right_i=(y1bar-y2bar)+margin
 print("confidence interval is")
 print(left_i)
 print(right_i)