# #This will be a different path if in the lab or at home
# dird="E:\\OneDrive\\MATH4753\\DATAxls\\" # 2017
#
# #my function to read data
# myread=function(csv){
#   fl=paste(dird,csv,sep="")
#   read.table(fl,header=TRUE,sep=",")
# }
# #EASY WAY TO READ IN FILES

#spruce.df=myread("SPRUCE.csv")#MS pg478

spruce.df = read.csv("SPRUCE.csv")

#with(spruce.df, dput(list(D=BHDiameter,H=Height),
                     #file="spruce.dat"))
# Or use
#spruce.df=read.table(file.choose(),header=TRUE,sep=",")

#get wd
getwd()

#Top six lines
tail(spruce.df)

#Plot the points
windows()

plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

library(ggplot2)
windows()
g = ggplot(spruce.df,mapping = aes(x = BHDiameter, y = Height)) +
  geom_point()
print(g)

g = g+ geom_smooth(formula = y~ log(x), method = "lm", col = "steelblue")
g = g + geom_smooth(formula = y ~ x, method = "lm", col = "Black")
g = g + geom_smooth(formula = y~ x+ I(x^2), method ="lm", col = "Red")
print(g)

g = g + geom_smooth(formula = y~ poly(x,3), method ="lm", col = "green3")
g

#load s20x library and make lowess smoother
library(s20x)

trendscatter(Height~BHDiameter,f=0.5,data=spruce.df)
# Now make the linear model
spruce.lm=lm(Height~BHDiameter,data=spruce.df)
summary(spruce.lm)
#residuals  created from the linear model object
height.res=residuals(spruce.lm)

#fitted values made from the linear model object
height.fit=fitted(spruce.lm)

windows()
#Make the plot using the plot function
plot(height.fit,height.res)

# Put a lowess smoother through res vs fitted
trendscatter( height.fit,height.res)

# Quick way to make a residual plot
plot(spruce.lm, which =1)

# Two plots testing normality
windows()
normcheck(spruce.lm,shapiro.wilk = TRUE)

## Quadratic object using the linear model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(quad.lm)
add1(spruce.lm,.~.+I(BHDiameter^2))
anova(spruce.lm)
anova(quad.lm)
anova(spruce.lm,quad.lm)
cubic.lm=lm(Height~BHDiameter + I(BHDiameter^2)+I(BHDiameter^3),data=spruce.df)
anova(cubic.lm)
add1(quad.lm,.~.+I(BHDiameter^3))
#add to the scatter plot
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

coef(quad.lm)
names(quad.lm)
quad.lm$coef[2]

myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

 #Or more general method
myplot=function(x){
 quad.lm$coef[1] +quad.lm$coef[2]*x  + quad.lm$coef[3]*x^2
 }

curve(myplot, lwd=2, col="steelblue",add=TRUE)

plot(quad.lm, which=1)

plot(spruce.lm,which=1)
normcheck(quad.lm,shapiro.wilk = TRUE)

summary(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(3,6,8)))

ciReg(quad.lm)

predict(quad.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm,quad.lm)

data = 15:24
predict20x(quad.lm,data.frame(BHDiameter = data, `I(BhDiameter)^2`=data^2))

anova(quad.lm)
anova(spruce.lm)

height.qfit=fitted(quad.lm)

RSS=with(spruce.df, sum((Height-height.qfit)^2))
RSS
MSS = with(spruce.df, sum((height.qfit-mean(Height))^2))
MSS

TSS = with(spruce.df, sum((Height-mean(Height))^2))
TSS

MSS/TSS

cooks20x(quad.lm)

#Now remove the 24th datum and reanalyze data

quad2.lm=lm(Height~BHDiameter + I(BHDiameter^2) , data=spruce.df[-24,])
summary(quad2.lm)
summary(quad.lm)

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

#some other code you might need
#The following code plots residuals
windows()
#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,max(Height)),xlim=c(0,max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#Make a quadratic model
quad.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)

# Find the coefficients
coef(quad.lm)

#Make a function that produces heights for inputs "x"
myplot=function(x){
 0.86089580 +1.46959217*x  -0.02745726*x^2
 }

# add the quadratic to the points
curve(myplot, lwd=2, col="steelblue",add=TRUE)

#Place segments (residuals) on the plot (except for the 3 largest cooks distances. 18, 21, 24)
with(spruce.df[-c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[-c(18,21,24)]) )
with(spruce.df[c(18,21,24),],segments(BHDiameter, Height, BHDiameter, height.qfit[c(18,21,24)], col="Red", lwd=3) )
with( spruce.df, arrows(5,Height[24], BHDiameter[24], Height[24],lwd=2,col="Blue"))
with(spruce.df,text(2,Height[24], paste("Highest Cook's","\n", "distance",sep=" ")))
with(spruce.df, text(BHDiameter,Height, 1:36,cex=0.5,pos=4))
 #########################################################################

layout(matrix(1:4,nr=2,nc=2,byrow=TRUE))

#Lets look at where the plots will go
layout.show(4)

#Plot the data
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)
# add the line
abline(spruce.lm)

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

abline(spruce.lm)

#make yhat the estimates of E[Height | BHDiameter]
yhat=with(spruce.df,predict(spruce.lm,data.frame(BHDiameter)))
yhat=fitted(spruce.lm)
# Draw in segments making the residuals (regression errors)
with(spruce.df,{
segments(BHDiameter,Height,BHDiameter,yhat)
})

RSS=with(spruce.df,sum((Height-yhat)^2))

RSS

#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

#make nieve model
with(spruce.df, abline(h=mean(Height)))
abline(spruce.lm)

#make the explained errors (explained by the model)
with(spruce.df, segments(BHDiameter,mean(Height),BHDiameter,yhat,col="Red"))
MSS=with(spruce.df,sum((yhat-mean(Height))^2))
MSS

# Total  error
#make a new plot
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
main="Spruce height prediction",data=spruce.df)

with(spruce.df,abline(h=mean(Height)))
with(spruce.df, segments(BHDiameter,Height,BHDiameter,mean(Height),col="Green"))
TSS=with(spruce.df,sum((Height-mean(Height))^2))
TSS
RSS + MSS
MSS/TSS

summary(spruce.lm)

#obtain coefft values
coef(spruce.lm)

#Calculate new y values given x
predict(spruce.lm, data.frame(BHDiameter=c(15,18,20)))

anova(spruce.lm)

spruce2.lm=lm(Height~BHDiameter + I(BHDiameter^2),data=spruce.df)
summary(spruce2.lm)

### More on the problem
windows()
plot(Height~BHDiameter,bg="Blue",pch=21,cex=1.2,
     ylim=c(0,1.1*max(Height)),xlim=c(0,1.1*max(BHDiameter)),
     main="Spruce height prediction",data=spruce.df)

yhatt=with(spruce.df,fitted(spruce2.lm))
with(spruce.df,plot(BHDiameter,yhatt,col="Red")
)

sum(residuals(spruce2.lm)^2)
plot(yhatt~BHDiameter,data=spruce.df,type="p")
summary(spruce2.lm)
anova(spruce2.lm)
anova(spruce.lm,spruce2.lm)
MSS
RSS

## piecewise linear model in R
## Model y = b0 + b1x + b2(x-xk)*(x>xk)
## You will need to change the code appropriately
sp2.df=within(spruce.df, X<-(BHDiameter-20)*(BHDiameter>20)) # this makes a new variable and places it within the same df
sp2.df

lmp=lm(Height~BHDiameter + X,data=sp2.df)
tmp=summary(lmp)
names(tmp)
myf = function(x,coef){
  coef[1]+coef[2]*(x) + coef[3]*(x-18)*(x-18>0)
}
plot(spruce.df,main="Piecewise regression")
myf(0, coef=tmp$coefficients[,"Estimate"])
curve(myf(x,coef=tmp$coefficients[,"Estimate"] ),add=TRUE, lwd=2,col="Blue")
abline(v=18)
text(18,16,paste("R sq.=",round(tmp$r.squared,4) ))


set.seed(12)
x <- matrix(c(rep(1, 1000),rnorm(10000, mean = 10, sd = 1 )), ncol = 11)
y <- rnorm(1000, mean = 15, sd = 1 )

n <- 1000
x1 <- c(1:n)
x2 <- x1 + rnorm(n, mean = 0, sd = 10)
x3 <- x1 + rnorm(n, mean = 100, sd = 10)
X <- matrix(c(x1,x2,x3), ncol = 3)
y <- c(1:n) * 10
y <- y + runif(n, min = -5, max = 5)
X <- matrix(c(rep(1, n),X), ncol = 4)
betaHat <- solve(t(X)%*%X) %*% t(X)  %*% y
print(betaHat)
fm1 <- lm(y ~ X[,-1]) #b/c the first column is all 1's
summary(fm1)
summary(X)
write.table(X, file = "R:/DataSets/Matrix-10-18-18.csv", sep = ",", col.names = FALSE, row.names = FALSE )
write.table(y, file = "R:/DataSets/Vector-10-18-18.csv", sep = ",", col.names = FALSE, row.names = FALSE )
read.table(file = "R:/DataSets/Matrix-10-18-18.csv", sep = ",", header = F) -> Dat  #just to check I wrote it out right XD
read.table(file = "R:/DataSets/Vector-10-18-18.csv", sep = ",", header = F) -> Dat2

X2 <- X[,1:2]
betaHat <- solve(t(X2)%*%X2) %*% t(X2)  %*% y
e <- y - (X2 %*% betaHat)
e2 <- e^2
#s^2 estimator
s2 <- sum(e2) / (n - 2)
fm2 <- lm(y ~ 0 + X2)
#same model
fm3 <- lm(y ~ X2[,-1])


area <- function(a, b, c) {
    s = (a + b + c) / 2
    a2 = s*(s-a)*(s-b)*(s-c)
    if (a2>0) sqrt(a2) else 0
}

is.heronian <- function(a, b, c) {
    h = area(a, b, c)
    h > 0 && 0==h%%1
}

# borrowed from stackoverflow http://stackoverflow.com/questions/21502181/finding-the-gcd-without-looping-r
gcd <- function(x,y) {
  r <- x%%y;
  ifelse(r, gcd(y, r), y)
}

gcd3 <- function(x, y, z) {
    gcd(gcd(x, y), z)
}

maxside = 200
r <- NULL
for(c in 1:maxside){
    for(b in 1:c){
        for(a in 1:b){
            if(1==gcd3(a, b, c) && is.heronian(a, b, c)) {
                r <- rbind(r,c(a=a, b=b, c=c, perimeter=a+b+c, area=area(a,b,c)))
            }
        }
    }
}

cat("There are ",nrow(r)," Heronian triangles up to a maximal side length of ",maxside,".\n", sep="")
cat("Showing the first ten ordered first by perimeter, then by area:\n")
print(head(r[order(x=r[,"perimeter"],y=r[,"area"]),],n=10))


mul_inv <- function(a, b)
{
  b0 <- b
  x0 <- 0L
  x1 <- 1L

  if (b == 1) return(1L)
  while(a > 1){
    q <- as.integer(a/b)

    t <- b
    b <- a %% b
    a <- t

    t <- x0
    x0 <- x1 - q*x0
    x1 <- t
  }

  if (x1 < 0) x1 <- x1 + b0
  return(x1)
}

chinese_remainder <- function(n, a)
{
  len <- length(n)

  prod <- 1L
  sum <- 0L

  for (i in 1:len) prod <- prod * n[i]

  for (i in 1:len){
    p <- as.integer(prod / n[i])
    sum <- sum + a[i] * mul_inv(p, n[i]) * p
  }

  return(sum %% prod)
}

n <- c(3L, 5L, 7L)
a <- c(2L, 3L, 2L)

chinese_remainder(n, a)


# confidence interval for indpendent sample

n1= 10
n2= 9
y1bar = 8.27
y2bar=6.78
s1=2.956
s2=2.565
# 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)


grayscalesImage <- function(nrow = 4) {
  X <- matrix(NA, nrow = nrow, ncol = 2^(nrow + 2))
  for (i in 1:nrow) {
    X[i, ] <- rep(1:2^(i + 2), each = 2^(nrow - i)) / 2^(i + 2)
    if (i %% 2 == 0) X[i, ] <- rev(X[i, ])
  }
  par(mar = rep(0, 4))
  image(t(X[nrow:1, ]), col = gray(1:ncol(X) / ncol(X)), axes = FALSE)
}
## Example ##
grayscalesImage(6)  # produces image shown in screenshot to the right


#reaprtita normala
#gerare de valori dintr-o normala stadard
rnorm(10)
t <- seq(-5, 5, 0.01)
plot(t, dnorm(t), col="magenta")

for (i in 2:5) {
  lines(t, dnorm(t, i-4), col = i)
}

for (i in 2:5) {
  lines(t, dnorm(t, 0, i), col = i, ylim = c(0, 1), xlim = c(-6, 6))
}

lines(t, dnorm(t, 0, 0.5), col = "black")

#-----------------TEMA--------------------------

?round
?plot
?runif
#Tema Ex1
# pot face inversele in mod numeric ca mai jos deoarece
# imaginea functie este egala cu preimaginea, fiind o bijectie pe [0, 1]
f1 <- function(p) {
  (p^5 + p^3 + p) / 3
}

x <- seq(0, 1, 0.001)
y <- f1(x)
z <- seq(0, 1, 0.001) * 0

for(i in 1 : 1001) {
  if(round(y[i]*1000) == 0){
    z[i] = x[i]
  } else {
    z[round(y[i]*1000)] = x[i]
  }
}

prev = z(1);
for(i in 1: 1001){
  if (z[i] == 0) {
    z[i] <- prev
  }
  prev <- z[i]
}

plot(x,  z)

u <- runif(100)
x <- z[round(u, 3)*1000]
hist(x, freq = FALSE)

#Tema Ex2

f2 <- function(p) {
  (1 - exp(1)^(-2*x) + 2*x) / 3
}

x <- seq(0, 1, 0.001)
y <- f2(x)
z <- seq(0, 1, 0.001) * 0

for(i in 1 : 1001) {
  if(round(y[i]*1000) == 0){
    z[i] = x[i]
  } else {
    z[round(y[i]*1000)] = x[i]
  }
}

prev = z(1);
for(i in 1: 1001){
  if (z[i] == 0) {
    z[i] <- prev
  }
  prev <- z[i]
}

plot(x,  z)

u <- runif(100)
x <- 1:100 * 0
for(i in 1:100) {
  if(u[i] < 1) {
    x <- z[round(u, 3)*1000]
  } else {
    u[i] <- -log(3 - 3*u) / 2
  }
}
hist(x, freq = FALSE)

Bachelors Year 3/Simulation techniques/Introduction to R.r


mix.dist <- function(n,mix.par,mu1,sigma1,mu2,df) {
#Purpose:
#  Create n samples from the mixture distribution
#Inputs:
# n - number of samples to return
# mix.par - pi in the practical notes -- proportion of samples from norm dist
# mu1 - mean of norm dist
# sigma1 - sd of norm dist
# mu2 - mean of t dist
# df - df for t dist
#Outputs:
# vector of n values from the mixture distribution
#Implementation note:
# Uses vectorization - generates 'n' samples from both distributions (hmmm...)

#sample n values from a Bernoulli dist, to determine parent distribution for each data point
  nu <- rbinom(n,1,mix.par)
#sample values from the normal
  X <- rnorm(n,mu1,sigma1)
#sample values from the t
  Y <- mu2 + rt(n,df)
# combine
  Z <- nu*X + (1-nu)*Y
  return(Z)
}


#' Bias correction function from Pang et al. (2009).
#'
#' This function computes the function \eqn{h_{\nu, p}(t)} on page 1023 of Pang
#' et al. (2009).
#'
#' @param nu a specified constant (nu = N - K)
#' @param p the feature space dimension.
#' @param t a constant specified by the user that indicates the exponent to use
#' with the variance estimator. By default, t = -1 as in Pang et al. See the
#' paper for more details.
#'
#' @references Pang, H., Tong, T., & Zhao, H. (2009). "Shrinkage-based Diagonal
#' Discriminant Analysis and Its Applications in High-Dimensional Data,"
#' Biometrics, 65, 4, 1021-1029.
#' \url{http://onlinelibrary.wiley.com/doi/10.1111/j.1541-0420.2009.01200.x/abstract}
#' @return the bias correction value
h <- function(nu, p, t = -1) {
  if (nu <= 0) {
    rlang::abort("The value for 'nu' must be positive.")
  }

  if(nu / 2 + t / p > 0) {
    (nu / 2)^t * (gamma(nu / 2) / gamma(nu / 2 + t / p))^p
  } else {
    rlang::warn("The bias-correction has resulted in a NaN. Incrementing nu by 1...")
    (nu / 2)^t * (gamma(nu / 2) / gamma((nu + 1) / 2 + t / p))^p
  }
}

#' Stein Risk function from Pang et al. (2009).
#'
#' This function finds the value for \eqn{\alpha \in [0,1]} that empirically
#' minimizes the average risk under a Stein loss function, which is given on
#' page 1023 of Pang et al. (2009).
#'
#' @param N the sample size.
#' @param K the number of classes.
#' @param var_feature a vector of the sample variances for each dimension.
#' @param num_alphas The number of values used to find the optimal amount of
#' shrinkage.
#' @param t a constant specified by the user that indicates the exponent to use
#' with the variance estimator. By default, t = -1 as in Pang et al. See the
#' paper for more details.
#' @references Pang, H., Tong, T., & Zhao, H. (2009). "Shrinkage-based Diagonal
#' Discriminant Analysis and Its Applications in High-Dimensional Data,"
#' Biometrics, 65, 4, 1021-1029.
#' \url{http://onlinelibrary.wiley.com/doi/10.1111/j.1541-0420.2009.01200.x/abstract}
#' @return list with
#' \itemize{
#'   \item `alpha`: the alpha that minimizes the average risk under a Stein
#'    loss function. If the minimum is not unique, we randomly select an
#'    `alpha` from the minimizers.
#'   \item `risk`: the minimum average risk attained.
#' }
risk_stein <- function(N, K, var_feature, num_alphas = 101, t = -1) {
  nu <- N - K
  p <- length(var_feature)
  alphas <- seq(0, 1, length = num_alphas)

  # The pooled variance is defined in Pang et al. (2009) as the geometric mean
  # of the sample variances of each feature.
  var_pool <- prod(var_feature)^(t / p)

  # Here we compute the average risk for the Stein loss function on page 1023
  # for all values of alpha.
  risk_alphas <- sapply(alphas, function(alpha) {
    risk <- h(nu = nu, p = p)^alpha * h(nu = nu, p = 1)^(1 - alpha)
    risk <- risk / (h(nu = nu, p = 1, t = alpha * t / p))^(p - 1)
    risk <- risk / h(nu = nu, p = 1, t = (1 - alpha + alpha / p) * t)
    risk <- risk * (var_pool)^(alpha * t)
    risk <- risk * mean(var_feature^(-alpha * t))
    risk <- risk - log(h(nu = nu, p = p)^alpha * h(nu = nu, p = 1)^(1 - alpha))
    risk <- risk - t * digamma(nu / 2)
    risk <- risk + t * log(nu / 2) - 1
    risk
  })

  # Which of the alphas empirically minimize this risk?
  # If there are ties in the minimum risk, we randomly select
  # the value of alpha from the minimizers.
  alpha_min_risk <- alphas[which(min(risk_alphas) == risk_alphas)]
  alpha_star <- sample(alpha_min_risk, 1)

  list(alpha = alpha_star, var_pool = var_pool)
}

#' Shrinkage-based estimator of variances for each feature from Pang et al.
#' (2009).
#'
#' This function computes the shrinkage-based estimator of variance of each
#' feature (variable) from Pang et al. (2009) for the SDLDA classifier.
#'
#' @param N the sample size.
#' @param K the number of classes.
#' @param var_feature a vector of the sample variances for each feature.
#' @param num_alphas The number of values used to find the optimal amount of
#' shrinkage.
#' @param t a constant specified by the user that indicates the exponent to use
#' with the variance estimator. By default, t = -1 as in Pang et al. See the
#' paper for more details.
#'
#' @references Pang, H., Tong, T., & Zhao, H. (2009). "Shrinkage-based Diagonal
#' Discriminant Analysis and Its Applications in High-Dimensional Data,"
#' Biometrics, 65, 4, 1021-1029.
#' \url{http://onlinelibrary.wiley.com/doi/10.1111/j.1541-0420.2009.01200.x/abstract}
#' @return a vector of the shrunken variances for each feature.
var_shrinkage <- function(N, K, var_feature, num_alphas = 101, t = -1) {
  nu <- N - K
  p <- length(var_feature)

  risk_stein_out <- risk_stein(N = N, K = K, var_feature = var_feature,
                               num_alphas = num_alphas, t = t)

  var_pool <- risk_stein_out$var_pool
  alpha <- risk_stein_out$alpha

  var_feature_shrink <- (h(nu = nu, p = p, t = t) * var_pool)^alpha *
    (h(nu = nu, p = 1, t = t) * var_feature)^(1 - alpha)
  var_feature_shrink
}


#
# Don't complain; just work harder! Dan Stanford
#
# Our responsibility is to do what we can, learn what we can, improve the solutions, and pass them on. RF
#
# @author: me@andreagirardi.it
# @since: Wed Jan 15 18:34:22 CET 2020
# @project: RExercises
# @module: Programming basic lesson
# @desc:
#
#
# Exercises

##
#### Standard deviation and Geometric mean
##

print ('#### Standard deviation and Geometric mean ####')
temps <- c(32, 32, 31, 28, 29, 31, 39, 32, 32, 35, 26, 29)

mean <- mean(temps)
num_items <- length(temps)
squared_differences <- rep(0, num_items)
products <- 1
index <- 1
geometric_mean <- 0

for ( temp in temps ) {
    products <- products * temp
    geometric_mean <- products ^ (1. / num_items)
    squared_differences[index] <- (temp - mean) ^ 2
    index <- index + 1
}

# Calculate VARIANCE
average_squared_difference <- mean(squared_differences)

# Calculate standard deviation
standard_deviation <- sqrt(average_squared_difference)

paste0 ('mean:                  ', mean)
paste0 ('variance:              ', average_squared_difference)
paste0 ('standard_deviation:    ', standard_deviation)
paste0 ('geometric mean:        ', geometric_mean)


poisson.fun <- function(theta, x, y) {
  # parameters
  lambda1 <- theta[1]
  lambda2 <- theta[2]

  # priors
  log.priors <- dgamma(lambda1, .5, 1e-5, log=T) + dgamma(lambda2, .5, 1e-5, log=T)

  # likelihood
  log.like <- sum(dpois(x, lambda1, log=T)) + sum(dpois(y, lambda2, log=T))

  ll <- log.priors + log.like

  ifelse(is.na(ll) | is.nan(ll), -Inf, ll)
}

poisson.1g.fun <- function(theta, x) {
  # parameters
  lambda <- theta

  # priors
  log.priors <- dgamma(lambda, .5, 1e-5, log=T)

  # likelihood
  log.like <- sum(dpois(x, lambda, log=T))

  ll <- log.priors + log.like

  ifelse(is.na(ll) | is.nan(ll), -Inf, ll)
}

bayes.poisson.test <- function(x, y=NULL, nmc=20000, nbi=20000) {
  if(is.null(y)) {
    theta.init <- (sum(x)+.5)/length(x)
    out <- bayes::mcmc(poisson.1g.fun, theta.init, nmc, nbi, x=x)
    #colnames(out) <- c("lambda")
  } else {
    theta.init <- c((sum(x)+.5)/length(x), (sum(y)+.5)/length(y))
    out <- bayes::mcmc(poisson.fun, theta.init, nmc, nbi, x=x, y=y)
    colnames(out) <- c("lambda1", "lambda2")
  }
  return(out)
}


binomial.fun <- function(theta, x, prior) {

  # parameters
  # x[, 1] ... number of success
  # x[, 2] ... number of trials

  # priors  beta(a, b)
  #  flat beta(1, 1)
  #  jeffery beta(.5, .5
  #
  # log.priors <- sum(dbeta(theta, prior[1], prior[2], log=T))

  # likelihood
  # log.like <- sum(dbinom(x[, 1], x[, 2], theta, log=T))

  # ll <- log.priors + log.like
  # posterior is actually another beta(a+y, b+n-y)
  # therefore no need to run full monte carlo, just need to sample from
  ll <- sum(dbeta(theta, prior[1]+sum(x[ ,1]), prior[2]+sum(x[ ,2]) - sum(x[ ,1]), log=T))

  ifelse(is.na(ll) | is.nan(ll), -Inf, ll)
}
#
# x is a matrix (series) of success and trials
#      [,1] [,2]
# [1,]   23  100           100 trials with 23 success
# [2,]   24  200           200 trials with 24 success
#
bayes.binomial.test <- function(x, prior=c(1, 1), nmc=20000, nbi=20000) {
  theta.init <- (sum(x[, 1])+1) / (sum(x[, 2])+2)
  out <- bayes::mcmc(binomial.fun, theta.init, nmc, nbi, x=x, prior=prior)
  return(out)
}


library(tidyverse) # helpful in Data Cleaning and Manipulation
library(arules) # Mining Association Rules and Frequent Itemsets
library(arulesViz) # Visualizing Association Rules and Frequent Itemsets
library(gridExtra) #  low-level functions to create graphical objects
library(ggthemes) # For cool themes like fivethirtyEight
library(dplyr) # Data Manipulation
library(readxl)# Read Excel Files in R
library(plyr)# Tools for Splitting, Applying and Combining Data
library(ggplot2) # Create graphics and charts
library(knitr) # Dynamic Report generation in R
library(lubridate) # Easier to work with dates and times.
library(kableExtra) # construct complex tables and customize styles
library(RColorBrewer)

data <- read.csv("Q2_b.csv")

summary(data)

sumofspeed <- sum(data$SP)
sumofspeed / 50

sumofspeed <- sum(data$WT)
sumofspeed / 50

sort(data$SP)
sort(data$WT)

median(data$SP)
median(data$WT)

table(data$SP)
table(data$WT)

modeforcars <- table(as.vector(data$SP))
names(modeforcars)[modeforcars == max(modeforcars)]

modeforcars <- table(as.vector(data$WT))
names(modeforcars)[modeforcars == max(modeforcars)]

myvector_outlier<- c(-100, 2, 4, 6, 8, 10, 12, 14, 16)
mean(myvector_outlier[2:9])

myvector_trim<- c(-15, 2, 3, 4, 5, 6, 7, 8, 9, 12)
mean(myvector_trim)

mean(myvector_trim, trim=.1)

min(data$SP)
min(data$WT)

max(data$SP)
max(data$WT)

range(data$SP)
range(data$WT)

IQR(data$SP)
IQR(data$WT)

quantile(data$SP)
quantile(data$WT)

var(data$SP)
var(data$WT)

sqrt(var(data$SP))
sqrt(var(data$WT))

library(psych)
skew(data$SP)

#this is the clculation of Skewness
library(psych)
skew(data$WT)

#this is the clculation of Kurtosis
kurtosi(data$SP)
kurtosi(data$WT)

plot(density(data$SP))
plot(density(data$WT))

summary(data$SP)
summary(data$WT)

summary(data)

describe(data)

describeBy(data, group=data$SP)
describeBy(data, group=data$WT)

cor(data$SP, data$WT)

cor(data)

cor(data$SP, data$WT,  method="spearman")

barplot(skew(data$SP))
barplot(data$SP, data$WT)
barplot((data$WT))
barplot(kurtosi(data$SP))
barplot(data$SP)

boxplot((data$SP))
boxplot(data$WT)

plot(data$X, data$SP)
plot(data$WT, data$X)

plot.ecdf(data$X, data$SP)
plot.ecdf(data$WT, data$X)

#To draw a barplot of sp
#Horizontal
barplot(data$SP,xlab = "Sp", col = "cyan", horiz = TRUE)
#Vertical
barplot(data$SP, ylab = "Sp", col = "cyan", horiz = FALSE)

#To draw a barplot of wt
#Horizontal
barplot(data$WT,xlab = "wt", col = "cyan", horiz = TRUE)
#Vertical
barplot(data$WT, ylab = "wt", col = "cyan", horiz = FALSE)

#To find histogram for Sp
hist(data$SP,xlab = "SP", main = "Histogram for SP", col = "yellow")

#To find histogram for wt
hist(data$WT,xlab = "WT", main = "Histogram for WT", col = "yellow")

scatterplot3d::scatterplot3d(data$WT, data$SP, data$X)

scatter.smooth(data$X, data$SP)
scatter.smooth(data$WT, data$X)


n = c(15,32,18,5,8,29,23,18,1,20,25,22)
E=c( 7.78,26.25,21.39,14.58,8.67,29.25,23.83,16.25,7.56,25.50,20.78,14.17)
# test statistic
Xsquare = 0
i=1
while(i<=length( n)){
  Xsquare=Xsquare+(((n[i]-E[i])^2)/E[i])
  i=i+1
}
print(Xsquare)
# critical value
alpha = 0.05
X.alpha=qchisq(1-alpha,df=6)
# The computed value of xsquare is greater than x.alpha, so we reject the null hypothes


# Example : 2   Chapter : 6.3     Page No: 314
# Solve Differential equation

# lambda1,lamda2,lambda3,x1,x2,x3,c1,c2,c3 are computed here.. for remaining details look textbook
A<-matrix(c(1,0,0,1,2,0,1,1,3),ncol=3)
lambda<-eigen(A)$values
x<-round(eigen(A)$vectors)
u<-c(9,7,4)
c<-solve(x,u)
print("Lambda 3 and Lambda 2 and Lambda 1 are")
print(lambda)
print("x3 and x2 and x1")
print(x)
print("c3,c2 and c1 are")
print(c)
#The  answer may slightly vary due to  rounding off values
#The answers provided in the text book may vary because of the computation process
#Both answers are correct , here it is taken -Ax+b=0 , In the text book it is considered as Ax-b=0


# Loading required packages
library(ggplot2)
library(dplyr)
library(readr)

# Creating df of text data
heart_data <- read_csv("heart_data.csv")

# 1.1 Finding Least squares regression line
lin_fit <- lm(heart.disease ~ biking, data=heart_data)
summary(lin_fit)

# 1.2 Plotting Linear Fit
ggplot(data = heart_data, aes(x=biking, y=heart.disease)) + geom_point() + stat_smooth(method = lm)

# 1.3 Testing linear relationship along with assumptions
# Normality Test of residuals
shapiro.test(lin_fit$residuals)
# Significance test (look at p-value of variable)
summary(lin_fit)

# 1.4 Correlation coefficient test
cor.test(heart_data$heart.disease, heart_data$biking)
# Normality Test of variables
shapiro.test(heart_data$heart.disease)
shapiro.test(heart_data$biking)
# Kendall Correlation Test
cor.test(heart_data$heart.disease, heart_data$biking, method = "kendall")

# 1.5 Coefficient of determination
cor(heart_data$heart.disease, heart_data$biking)^2


# Get data
digits.train <- read.table(url("http://www.amlbook.com/data/zip/features.train"))
digits.test <- read.table(url("http://www.amlbook.com/data/zip/features.test"))

colnames(digits.train) <- c("digit", "symmetry", "intensity")
colnames(digits.test) <- c("digit", "symmetry", "intensity")

digits.train$digit <- factor(digits.train$digit)
digits.test$digit <- factor(digits.test$digit)

library(ggplot2)

ggplot(digits.train, aes(x = symmetry, y = intensity, color = digit)) +
  geom_point()

linearRegression <- function(x, y, lambda, invFn = function(x) solve(x)) {
  # Calculate pseudo inverse
  pseudo = invFn(t(x) %*% x + lambda * diag(ncol(x))) %*% t(x)
  w = pseudo %*% y
  Ein = sum(y != sign(t(w) %*% t(x)))/length(y)
  # error = sum(y != sign(t(t(w) %*% t(x)))) # In case of only one record
  list(w = w, Ein = Ein)
}

phi.1 <- function(x) as.matrix(cbind(bias = 1, x[,1], x[,2]))

phi.2 <- function(x) as.matrix(cbind(bias = 1, x[,1], x[, 2], x[, 1] * x[,2], x[,1]^2, x[,2]^2))

q7_q8_q9 <- t(sapply(0:9, function(myDigit) {
  lambda = 1
  y.train = ifelse(digits.train$digit == myDigit, 1, -1)
  x.train.1 = phi.1(digits.train[, -1]) # Could be outside the loop
  x.train.2 = phi.2(digits.train[, -1]) # Could be outside the loop

  fit.1 <- linearRegression(x.train.1, y.train, lambda)
  fit.2 <- linearRegression(x.train.2, y.train, lambda)

  y.test = ifelse(digits.test$digit == myDigit, 1, -1)
  x.test.1 = phi.1(digits.test[, -1])
  x.test.2 = phi.2(digits.test[, -1])

  Eout.1 = sum(y.test != sign(t(fit.1$w) %*% t(x.test.1)))/length(y.test)
  Eout.2 = sum(y.test != sign(t(fit.2$w) %*% t(x.test.2)))/length(y.test)

  Err.1 = Eout.1 - fit.1$Ein
  Err.2 = Eout.2 - fit.2$Ein

  cbind(myDigit, fit.1$Ein, Eout.1, Err.1,
        fit.2$Ein, Eout.2, Err.2, 100*(Eout.2 - Eout.1), Eout.2 <= 0.95 * Eout.1)
}))

colnames(q7_q8_q9) <- c("Digit", "Ein.1", "Eout.1", "Err.1",
                        "Ein.2", "Eout.2", "Err.2", "diff", "check")

q7_q8_q9

ggplot(as.data.frame(q7_q8_q9), aes(x=Digit)) +
  geom_line(aes(y = Eout.1, color="psi1")) +
  geom_line(aes(y = Eout.2, color = "psi2"))

# Q10
digits.train.sub <- subset(digits.train, digit == 1 | digit == 5)
digits.test.sub <- subset(digits.test, digit == 1 | digit == 5)
myDigit = 1

require(foreach)
foreach(lambda=c(0.01, 1), .combine = rbind) %do% {
  y.train = ifelse(digits.train.sub$digit == myDigit, 1, -1)
  x.train.2 = phi.2(digits.train.sub[, -1])
  fit.2 <- linearRegression(x.train.2, y.train, lambda)

  y.test = ifelse(digits.test.sub$digit == myDigit, 1, -1)
  x.test.2 = phi.2(digits.test.sub[, -1])

  Eout.2 = sum(y.test != sign(t(fit.2$w) %*% t(x.test.2)))/length(y.test)

  cbind(Ein.2 = fit.2$Ein, Eout.2)
}

# Q11
x = rbind(c(1,0), c(0,1), c(0,-1),
          c(-1,0), c(0,2), c(0,-2),
          c(-2,0))

y = c(-1, -1, -1, +1, +1, +1, +1)

plot(x, pch = y+2)

phi <- function(x) as.matrix(cbind(x[,2]^2 - 2 * x[,1] - 1, x[,1]^2 - 2 * x[,2] + 1))

plot(phi(x), pch = y + 2)

abline(-3, 7)

fit <- linearRegression(cbind(1, phi(x)), y, 0)
abline(-fit$w[1]/fit$w[3], -fit$w[2]/fit$w[3])

w1=-1; w2=1; b = -0.5
abline(-w1/w2, -b/w2, col = "red")
abline(-b/w2, -w1/w2, col = "red")
abline(w1/w2, b/w2, col = "red")
w1=1; w2=-1; b = -0.5
abline(-w1/w2, -b/w2, col = "blue")
abline(-b/w2, -w1/w2, col = "blue")
abline(w1/w2, b/w2, col = "blue")
w1=1; w2=1e6; b = -0.5
abline(-w1/w2, -b/w2, col = "green")
abline(-b/w2, -w1/w2, col = "green")
abline(w1/w2, b/w2, col = "green")
w1=0; w2=1; b = -0.5
abline(-w1/w2, -b/w2, col = "purple")
abline(-b/w2, -w1/w2, col = "purple")
abline(w1/w2, b/w2, col = "purple")

# Got Q11 wrong

# Q12
require(e1071)
fit <- svm(x, y,
           scale = TRUE,
           kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 1e16,
           type = "C-classification")

fit$tot.nSV

# Q13
f <- function(x) sign(x[,2] - x[,1] + 0.25 * sin(pi * x[,1]))
Eins <- sapply(1:10000, function(run) {
  x <- cbind(runif(100, -1, 1), runif(100, -1, 1))
  y <- f(x)
  # plot(x, pch=y+2)

  fit <- svm(x, y,
             scale = TRUE,
             kernel = "radial", gamma = 1.5, cost = 1e16,
             type = "C-classification")

  #fit$tot.nSV
  #points(x[fit$index,], col='blue', pch=14, lwd=4)
  sum(fit$fitted != y)
})

summary(Eins)

# Q14
# RBF
phi <- function(gamma, x, k) cbind(bias = 1,
                                   t(apply(x,1, function(x1)
                                     apply(k, 1, function(s)
                                       exp(- gamma * Norm(x1, s)^2)))))

# f <- function(x) sign(tanh(x[,1] - x[,2]))
k = 12 # 9
gamma = 1.5
N <- 100
runs <- 1000

q14_15 <- sapply(seq(runs), function(run) {
  x.train <- cbind(runif(N, -1, 1), runif(N, -1, 1))
  y.train <- f(x.train)
  fit.svm <- svm(x.train, y.train,
                 scale = TRUE,
                 kernel = "radial", gamma = gamma, cost = 1e16,
                 type = "C-classification")

  # Get centers
  fit.kmeans = kmeans(x.train, k)
  # Get RBF
  x.train.phi = phi(gamma = gamma, x.train, fit.kmeans$centers)
  fit.rbf <- linearRegression(x.train.phi, y.train, 0)

  x.test <- cbind(runif(N, -1, 1), runif(N, -1, 1))
  y.test <- f(x.test)

  Eout.svm <- sum(y.test != predict(fit.svm, x.test))/length(y.test)
  pred.rbf <- sign(phi(gamma, x.test, fit.kmeans$centers) %*% fit.rbf$w)
  Eout.rbf <- sum(y.test != pred.rbf)/length(y.test)

  cbind(Eout.svm, Eout.rbf, Eout.rbf > Eout.svm)
})

summary(t(q14_15)*100)
sum(q14_15[3,])*100/runs

# Q16
q16 <- sapply(seq(runs), function(run) {
  x.train <- cbind(runif(N, -1, 1), runif(N, -1, 1))
  y.train <- f(x.train)

  x.test <- cbind(runif(N, -1, 1), runif(N, -1, 1))
  y.test <- f(x.test)

  k = 9
  # Get centers
  fit.kmeans = kmeans(x.train, k)
  # Get RBF
  x.train.phi = phi(gamma = gamma, x.train, fit.kmeans$centers)
  fit.rbf.9 <- linearRegression(x.train.phi, y.train, 0)

  pred.rbf <- sign(phi(gamma, x.test, fit.kmeans$centers) %*% fit.rbf.9$w)
  Eout.rbf.9 <- sum(y.test != pred.rbf)/length(y.test)

  k = 12
  # Get centers
  fit.kmeans = kmeans(x.train, k)
  # Get RBF
  x.train.phi = phi(gamma = gamma, x.train, fit.kmeans$centers)
  fit.rbf.12 <- linearRegression(x.train.phi, y.train, 0)

  pred.rbf <- sign(phi(gamma, x.test, fit.kmeans$centers) %*% fit.rbf.12$w)
  Eout.rbf.12 <- sum(y.test != pred.rbf)/length(y.test)

  cbind(fit.rbf.9$Ein, fit.rbf.12$Ein, Eout.rbf.9, Eout.rbf.12)
})

summary(t(q16)*100)

# Q17
k = 9
q17 <- sapply(seq(runs), function(run) {
  x.train <- cbind(runif(N, -1, 1), runif(N, -1, 1))
  y.train <- f(x.train)

  x.test <- cbind(runif(N, -1, 1), runif(N, -1, 1))
  y.test <- f(x.test)

  gamma = 1.5
  # Get centers
  fit.kmeans = kmeans(x.train, k)
  # Get RBF
  x.train.phi = phi(gamma = gamma, x.train, fit.kmeans$centers)
  fit.rbf.9 <- linearRegression(x.train.phi, y.train, 0)

  pred.rbf <- sign(phi(gamma, x.test, fit.kmeans$centers) %*% fit.rbf.9$w)
  Eout.rbf.9 <- sum(y.test != pred.rbf)/length(y.test)

  gamma = 2
  # Get centers
  fit.kmeans = kmeans(x.train, k)
  # Get RBF
  x.train.phi = phi(gamma = gamma, x.train, fit.kmeans$centers)
  fit.rbf.12 <- linearRegression(x.train.phi, y.train, 0)

  pred.rbf <- sign(phi(gamma, x.test, fit.kmeans$centers) %*% fit.rbf.12$w)
  Eout.rbf.12 <- sum(y.test != pred.rbf)/length(y.test)

  cbind(fit.rbf.9$Ein, fit.rbf.12$Ein, Eout.rbf.9, Eout.rbf.12)
})

summary(t(q17)*100)
sum(q17[1,]==0)/runs * 100


mindistance <- function(vec, df=dfxs) {
    ## Function to find distance from vector vec to nearest point in dataframe df
    # subtract vec from dataframe column
    dif   <- sweep(df, 2, vec, "-")
    # head(dif,2)
    # sumsquare each row of dataframe of diferences
    sq    <- function(x) { sum(x^2) }
    difsq <- apply(dif, 1, sq)
    # return the minimum distance
    mindist <- sqrt( min(difsq) )
    return(mindist)
}

negative_mindistance <- function(vec, df=dfxs){
    mindistance(vec,df) * -1
}

## Tests of function

## ## add center point to database for testing
## testdata <- dfxs
## vec <- c(0.5, 0.5, 0.5, 0.5, 0.5, 0.5)
## testdata <- rbind(vec, testdata)
## head(testdata)
##
## ## test to return 0.1
## vec1 <- vec + c(0, 0.1, 0, 0, 0, 0)
## ##vec1
## testanswer <- mindistance(vec1, testdata)
## cat("test to return 0.1 = ", testanswer,"\n")
##
## ## test to return 0.14142
## vec1 <- vec + c(0, 0, 0.1, 0, 0.1, 0)
## ##vec1
## testanswer <- mindistance(vec1, testdata)
## cat("test to return 0.14142 = ", testanswer,"\n\n")
##
## ## how about if supply vec from a row in a dataframe and look for min distance from any point in dfxs?
## cat("test to use function on vector from dfxs dataframe (same as above but no null row)\n")
## vecdf <- data.frame( t( vec ))
## cat("vecdf =\n")
## vecdf
## cat("convert to vector\n")
## vec <- as.numeric( vecdf[1,] )
## vec
## mindistance(vec, dfxs)
##
## ## can also use apply to run mindistance function on each row of default dataframe, dfxs
## cat("\ntest to use function on all points in one dataframe to the dfxs dataframe\n")
## vecdf <- data.frame(rbind(vec, vec1))
## vecdf
## apply(vecdf, 1, mindistance)


RMin <- 10
RMax <- 15
NPts <- 100

# instead of a for loop, we generate what should be enough points
# also take care to have enough range to avoid rounding inaccuracies
nBlock <- NPts * ((RMax/RMin) ^ 2)
nValid <- 0
while (nValid < NPts) {
	X <- round(runif(nBlock, -RMax - 1, RMax + 1))
	Y <- round(runif(nBlock, -RMax - 1, RMax + 1))
	R <-  sqrt(X^2 + Y^2)
	Valid <- ( (R >= RMin) & (R <= RMax) )
	nValid <- sum(Valid)
	nBlock <- 2 * nBlock
}
plot(X[Valid][1:NPts],Y[Valid][1:NPts], pch=19, cex=0.25, col="blue",
	xlab="x",ylab="y",main="Fuzzy circle", xlim=c(-RMax,RMax), ylim=c(-RMax,RMax) )


# Preparing Dataset for the Time Series Analysis

library(readr)
library(tseries)
library(TSA)
library(dLagM)
library(forecast)
library(car)
library(x12)
library(kableExtra)

# Descriptive Analysis function
descriptive_analysis <- function(ts, object)
{
  plot(ts,
       ylab = c(paste0(toString(object))),
       main = c(paste0("Monthly Time Series Plot of ",toString(object))),
       type="o")
  points(y=ts,x=time(ts), pch=as.vector(season(ts)))

  par(mfrow=c(2,1))
  acf(ts,
      lag.max = 48,
      main = c(paste0("ACF plot of ",toString(object))))

  pacf(ts,
       lag.max = 48,
       main = c(paste0("PACF plot of ",toString(object))))
  par(mfrow=c(1,1))

  print(adf.test(ts))
  print(pp.test(ts))
}

# Function for Decomposition
decom <- function(ts)
{
  decom.x12 = x12(ts)
  plot(decom.x12 , sa=TRUE , trend=TRUE)

  plotSeasFac(decom.x12)

  decomposition <- stl(ts, t.window=15, s.window="periodic", robust=TRUE)
  plot(decomposition)
}

ASX_data <- read_csv("ASX_data.csv")
head(ASX_data)

#### ASX ordinaries Price Index

ASX_TS <- ts(ASX_data$`ASX price`, start = c(2004,1), frequency = 12)
class(ASX_TS)
head(ASX_TS)

#### Gold Price (AUD)

gold_TS <- ts(ASX_data$`Gold price`, start = c(2004,1), frequency = 12)
class(gold_TS)
head(gold_TS)

#### Crude Oil (Brent, USD/bbl)

oil_TS <- ts(ASX_data$`Crude Oil (Brent)_USD/bbl`, start = c(2004,1), frequency = 12)
class(oil_TS)
head(oil_TS)

#### Copper (USD/tonne)

copper_TS <- ts(ASX_data$`Copper_USD/tonne`, start = c(2004,1), frequency = 12)
class(copper_TS)
head(copper_TS)

#### Whole Dataset

ASX_data_TS = ts(ASX_data, start = c(2004,1), frequency = 12)
class(ASX_data_TS)
head(ASX_data_TS)

ASX_TS_lambda = BoxCox.lambda(ASX_TS)
ASX_TS_lambda

ASX_TSBC = ((ASX_TS^(ASX_TS_lambda)) - 1) / ASX_TS_lambda
descriptive_analysis(ASX_TSBC,"ASX ords price Index(Box-cox Transformed)")

gold_TS_lambda = BoxCox.lambda(gold_TS)
gold_TS_lambda

gold_TSBC = ((gold_TS^(gold_TS_lambda)) - 1) / gold_TS_lambda
descriptive_analysis(gold_TSBC,"gold price(Box-cox Transformed) in AUD")

oil_TS_lambda = BoxCox.lambda(oil_TS)
oil_TS_lambda

oil_TSBC = ((oil_TS^(oil_TS_lambda)) - 1) / oil_TS_lambda
descriptive_analysis(oil_TSBC, "Crude oil price(Box-cox Transformaed) in USD/bbl")

copper_TS_lambda = BoxCox.lambda(copper_TS)
copper_TS_lambda

copper_TSBC = ((copper_TS^(copper_TS_lambda)) - 1) / copper_TS_lambda
descriptive_analysis(copper_TSBC,"Copper price(Box-cox Transformed) in USD/Tonne")

## Differencing

ASX_TSBC_diff = diff(ASX_TSBC)
descriptive_analysis(ASX_TSBC_diff,"ASX price(Bc Transformed-1st diff)")

gold_TSBC_diff = diff(gold_TSBC)
descriptive_analysis(gold_TSBC_diff,"gold price(BC Transformed-1st diff)")

oil_TSBC_diff = diff(oil_TSBC)
descriptive_analysis(oil_TSBC_diff, "Crude oil price(BC Transformed 1st diff)")

copper_TSBC_diff = diff(copper_TSBC)
descriptive_analysis(copper_TSBC_diff,"Copper price(BC Transformed-1st diff)")

## Decomposition
decom(ASX_TS)

decom(gold_TS)

decom(oil_TS)

decom(copper_TS)

# The most accurate and suitable distributed lag model

ASX_scaled= scale(ASX_data_TS)
plot(ASX_scaled, plot.type="s",
     col =	c("blue", "red","green","black"),
     main= "ASX ordinaries and gold, oil, copper")
legend("topleft",lty=1,col=c("blue","red","green","black"), c("ASX(Y)", "Gold(X1)","Oil(X2)","Copper(X3)"))

cor <- as.data.frame(cor(ASX_data_TS)) %>% round(3)
kbl(cor) %>%
  kable_paper()

## Finite Distributed Lag Models.

ASX_m = as.data.frame(ASX_data[,c(1,2,3,4)])
colnames(ASX_m) <- c("asx", "gold", "oil", "copper")
for ( i in 1:12){
  model1.1 = dlm(formula = asx ~ gold + copper, data = data.frame(ASX_m), q = i )
  cat("q = ", i, "AIC = ", AIC(model1.1$model), "BIC = ", BIC(model1.1$model),"\n")
}

model1 = dlm(formula = asx ~ gold + copper, data = data.frame(ASX_m), q = 12)
summary(model1$model)
checkresiduals(model1$model)
vif(model1$model)

## Polynomial Distributed Lag Model

finiteDLMauto(x = as.vector(ASX_m$copper), y = as.vector(ASX_m$asx), q.min = 1, q.max = 12, k.order = 1,
              model.type = "poly", error.type ="AIC", trace = TRUE)

model2 = polyDlm(x = as.vector(ASX_m$copper), y = as.vector(ASX_m$asx), q = 10, k = 1, show.beta = TRUE)
summary(model2$model)
checkresiduals(model2$model)
vif(model2$model)

## Koyck Distributed Lag Model

model3 = koyckDlm(x = as.vector(ASX_m$copper), y = as.vector(ASX_m$asx))
summary(model3,diagnostics = TRUE)
checkresiduals(model3$model)
vif(model3$model)

## Autoregressive Distributed Lag Model

for (i in 1:5)
{
  for(j in 1:5)
  {
    model4 = ardlDlm(formula = asx ~ gold + copper, data = data.frame(ASX_m),p = i , q = j )
    cat("p = ", i, "q =" , j,"AIC = ", AIC(model4$model), "BIC = ", BIC(model4$model), "\n")
  }
}

# ardlDLM(1,5)

model4_1 = ardlDlm(formula = asx ~ gold + copper, data = data.frame(ASX_m), p = 1 , q = 5)
summary(model4_1)
checkresiduals(model4_1$model)
vif(model4_1$model)

# ardlDLM(2,5)

model4_2 = ardlDlm(formula = asx ~ gold + copper, data = data.frame(ASX_m), p = 2 , q = 5)
summary(model4_2)
checkresiduals(model4_2$model)
vif(model4_2$model)

# ardlDLM(3,5)

model4_3 = ardlDlm(formula = asx ~ gold + copper, data = data.frame(ASX_m), p = 3 , q = 5)
summary(model4_3)
checkresiduals(model4_3$model)
vif(model4_3$model)


fact=function(num)
{
  if(num==1)
    return(1)
  else
  {
    return(num*fact(num-1))
  }
  print(fact)
}

fact(5)


chi2 <- function(a,b,c,d) {
  # Compute the chi^2 statistic for a 2x2 crosstab containing the values
  # [[a, b], [c, d]]
  ooe <- function(o, e) {(o-e)*(o-e) / e}
  tot = 0.0 + a+b+c+d
  a = as.numeric(a)
  b = as.numeric(b)
  c = as.numeric(c)
  d = as.numeric(d)
  (ooe(a, (a+c)*(a+b)/tot)
   +  ooe(b, (b+d)*(a+b)/tot)
   +  ooe(c, (a+c)*(c+d)/tot)
   +  ooe(d, (d+b)*(c+d)/tot))
}

corpus.compare <- function(words.x, freq.x=rep(1, length(words.x)), words.y, freq.y=rep(1, length(words.y))) {
  # Compare two corpora, listen relative frequency and chi-squared
  # words should be a vector of character with the words for corpus x and y
  # freq, if given, should be a vector of the same length as words with the counts per word
  # words may be duplicated
  n.x = aggregate(freq.x, list(words.x), FUN=sum)
  colnames(n.x) = c("word", "freq.x")
  n.y = aggregate(freq.y, list(words.y), FUN=sum)
  colnames(n.y) = c("word", "freq.y")
  result = merge(n.x, n.y, all=T)
  result[is.na(result)] = 0
  result$chi = chi2(result$freq.x, result$freq.y, sum(result$freq.x) - result$freq.x, sum(result$freq.y) - result$freq.y)
  result$over = (result$freq.x / result$freq.y) / (sum(result$freq.x) / sum(result$freq.y))
  result
}

corpus.split <- function(aid, words, freq=NULL, pattern, ...) {
  selected.aid = aid[grepl(pattern, words, ...)]
  print(paste("Selected", length(selected.aid),"/", length(unique(aid)),"using pattern", pattern))
  words.x = words[aid %in% selected.aid]
  freq.x = if (is.null(freq)) NULL else freq[aid %in% selected.aid]
  words.y = words[!(aid %in% selected.aid)]
  freq.y = if (is.null(freq)) NULL else freq[!(aid %in% selected.aid)]
  list(words.x=words.x, freq.x=freq.x, words.y=words.y, freq.y=freq.y)
}

corpus.freqs <- function(aid, words, freq) {
  # compute the document frequency for all words
  freqs = aggregate(freq, list(words), FUN=sum)
  docfreqs = aggregate(aid, list(words), FUN=function(x) length(unique(x)))
  result = merge(freqs, docfreqs, by='Group.1')
  colnames(result) <- c("word", "tf", "df")
  result$df.prop = result$df / length(unique(aid))
  result$idf = log(length(unique(aid)) / result$df)
  result$tfidf = result$tf * result$idf
  result
}


library(kernlab)
library(MASS)

drawLine = function(w, color, width = 0.5) {
  abline(a = w[3] / w[2], b = -w[1] / w[2], lwd = width, col = color, asp = 1)
}

plotROCCurve <- function(dset, w) {
  dsetLength <- dim(dset)[1]

  d <- matrix(NA, dsetLength, 2)

  for (i in 1:dsetLength) {
    d[i, ] <- c(i, sum(w * c(dset[i, 1:2], -1)))
  }

  sorted <- dset[order(d[ ,2], decreasing = TRUE), 3]

  truePositive <- 0
  falsePositive <- 0

  result <- matrix(0, dsetLength+1, 2)

  for (i in 1:dsetLength) {
    ans <- sorted[i]
    if (ans == 1) {
      truePositive <- truePositive + 1
    } else {
      falsePositive <- falsePositive + 1
    }
    result[i+1,] <- c(falsePositive, truePositive)
  }
  plot(result[, 1], result[, 2], type="l", xlab="False positive rate", ylab="True positive rate")
}

mu1 <- c(0, 0)
mu2 <- c(2, 2)
sig1 <- matrix(c(2, 0.9, 0.9, 2), 2, 2)
sig2 <- matrix(c(0.5, 0, 0, 2), 2, 2)
dset1 <- mvrnorm(50, mu1, sig1)
dset2 <- mvrnorm(50, mu2, sig2)
dset <- rbind(cbind(dset1, 1),cbind(dset2, -1))
# dset <- cbind(dset, -1)

# m <- matrix(data = c(
#   0, 0,
#   0.2, 0.1,
#   -0.7, 0.2,
#   -0.5, -0.3,
#   0.4, -0.2,
#
#   2, 2,
#   -2, 2,
#   2, -2,
#   -2, -2,
#   -3, 0,
#   -5, 0,
#   4, 1,
#   3, -4
# ), ncol = 2, byrow = TRUE)
# cl <- c(rep(1, 5), rep(-1, 8))

C <- 0.1

svp <- ksvm(as.matrix(dset[, 1:2]), c(dset[,3]),type="C-svc", kernel = "vanilladot", C = C, scaled = c())

supportVectorIndices <- SVindex(svp)
w <- colSums(coef(svp)[[1]] * dset[supportVectorIndices, 1:2])
w[3] <- b(svp)

plot(dset[-supportVectorIndices ,1], dset[ -supportVectorIndices,2], pch=21, bg=c("1" = "green","-1" = "blue")[paste(dset[-supportVectorIndices ,3])])
# plot(dset[-supportVectorIndices, 1], dset[-supportVectorIndices, 2], pch = 21, bg = "grey", main = "C = 0.1")
points(dset[supportVectorIndices, 1], dset[supportVectorIndices, 2], pch = 24, bg="red", col=c("1" = "green","-1" = "blue")[paste(dset[-supportVectorIndices ,3])])
drawLine(w, "red", width = 3)

# plotROCCurve(dset, w)

# svp <- ksvm(m,cl,type="C-svc")
# plot(svp, data=as.matrix(dset[, 1:2]))
# drawLine(w, "red")

# svp


# Example : 1   Chapter : 6.6     Page No: 356
# Similar matrices are matrices with same eigen values
A<-matrix(c(0.5,0.5,0.5,0.5),ncol=2)
Aev<-eigen(A)$values
print("Eigen values of A ")
print(Aev)
Lambda<-matrix(c(1,0,0,0),ncol=2)
Lev<-eigen(Lambda)$values
print("eigen values of lambda matrix")
print(Lev)
M<-matrix(c(1,1,0,2),ncol=2)
M1<-solve(M)
M1AM<-M1%*%A%*%M
M1AMev<-eigen(M1AM)$values
print("EIgen values of M-1*A*M")
print(M1AMev)
print("A and M-1*A*M are similar matrices")


sieve <- function(n)
{
   n <- as.integer(n)
   if(n > 1e6) stop("n too large")
   primes <- rep(TRUE, n)
   primes[1] <- FALSE
   last.prime <- 2L
   for(i in last.prime:floor(sqrt(n)))
   {
      primes[seq.int(2L*last.prime, n, last.prime)] <- FALSE
      last.prime <- last.prime + min(which(primes[(last.prime+1):n]))
   }
   which(primes)
}

sieve(1000)


#Define our Birthday Sim Function
pbirthdaysim <- function(n, nsims=100000, feb29=TRUE) {
  ## Using nsims simulations, estimate the probability
  ## that a room of n people includes a shared birthday
  bdays <- 1:366
  ## Feb 29 represented as day 366
  ## We'll sample other days 4 times as often
  ## compared to day 366
  probs <- c(rep(4,365),1)
  if(!feb29) {
    # drop Feb 29 from bdays and probs
    bdays <- bdays[-366]
    probs <- probs[-366]
  }
  probs <- probs/sum(probs)
  anydup <- function(ignored)
    ## simulate n birthdays, return TRUE if
    ## there's a duplicate
    any(duplicated(sample(bdays, n, prob=probs, replace=TRUE)))

  sum(sapply(seq(nsims), anydup)) / nsims
}

# install the package devtools
#install.packages("devtools")
# install the doAzureParallel and rAzureBatch package
#devtools::install_github("Azure/rAzureBatch")
#devtools::install_github("Azure/doAzureParallel")

#Run on the cloud cluster
library(doAzureParallel)
setCredentials("credentials.json")
cl <- makeCluster("cluster-birthday.json")
registerDoAzureParallel(cl)
system.time(bdayp <- foreach(n=1:100) %dopar% pbirthdaysim(n))
bdayp <- unlist(bdayp)

plot(bdayp, xlab="People in room",
     ylab="Probability of shared birthday")
abline(h=0.5)

# de-provision your cluster in Azure
#stopCluster(cl)


## 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.
library(xts)
library(Quandl)
library(quantmod)

fit.bubblear1 <- function(prcs) {
    coef(lm.fit(cbind(Intercept = 1, prcs[,-1]), prcs[,1]))[2]
}

btc.prices <- Quandl("BITFINEX/BTCUSD", type="xts")[,"Mid"]
btc.prices$lagMid <- lag(btc.prices$Mid)
fits.btc.ar <- rollapply(na.omit(btc.prices), 90, fit.bubblear1, align="right", by.column=FALSE)

spx.prices <- Quandl("CHRIS/CME_SP1", type="xts")[,"Settle"]
spx.prices$lagSettle <- lag(spx.prices$Settle)
fits.spx.ar <- rollapply(na.omit(spx.prices), 90, fit.bubblear1, align="right", by.column=FALSE)

ust.tickers <- c("FRED/DGS3MO", "FRED/DGS2", "FRED/DGS10", "FRED/DGS30")
ust <- Quandl(ust.tickers, type="xts")/100
colnames(ust) <- c("UST3M", "UST2Y", "UST10Y", "UST30Y")

eugb.tickers <-c("BUNDESBANK/BBK01_WT3210", # 6M
                 "BUNDESBANK/BBK01_WT3213", # 2Y
                 "BUNDESBANK/BBK01_WT3229", # 10Y
                 "BUNDESBANK/BBK01_WT3500") # 30Y
eugb <- Quandl(eugb.tickers, type="xts")/100
colnames(eugb) <- c("EUGB6M", "EUGB2Y", "EUGB10Y", "EUGB30Y")

eonia.6m <- Quandl("BUNDESBANK/BBK01_ST0304", type="xts")/100

ted <- Quandl("FRED/TEDRATE", type="xts")/100
bed <- eonia.6m - eugb$EUGB6M

index.tickers <- c("^SPX", "^STOXX50E")
adj.close <- 6  # 6th field is adjusted close
spx.prices <- getSymbols("^SPX", source="yahoo", auto.assign=FALSE,
                         return.class="xts")[,adj.close]
estox.prices <- getSymbols("^STOXX50E", source="yahoo", auto.assign=FALSE,
                           return.class="xts")[,adj.close]
spx.rets <- diff(log(spx.prices))
estox.rets <- diff(log(estox.prices))


# Master Thesis Project - Extreme Value Theory
# We assume that the stock prices follow a geometric
# Brownian motion (Black-Scholes model). We plot the
# empirical stock price data as well as the simulated
# geometric Brownian motions associated to them.
# Killian Martin--Horgassan
# 02-06-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("logGrossReturns.r")
source("loadStockData.r")
source("loadStockData_plain.r")
source("meanAndVarianceDF.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks
df_plain <- loadStockData_plain(CHOICE)

# Loading the log-gross returns for the five stocks
df <- loadStockData(CHOICE)

# Computing the mean and Variances of the stock
meanAndVarDF <- meanAndVarianceDF(df)

# Building the Geometric Brownian motion
	N = dim(df)[1]
	M = dim(df)[2]
	c <- rep(0,N)
	geomBMs <- data.frame(c,c,c,c,c)

	means <- meanAndVarDF[1]
	vars <- meanAndVarDF[2]

	# Time component
	timeSteps = 0:(N-1)

	# Brownian motion component
    dis = rnorm(N,0,1)
    dis = cumsum(dis)

	for (i in 1:M) {
		coeff1 = (means[[1]])[i] - 0.5*(vars[[1]])[i]
		geomBMs[i] <- (df_plain[[i]])[1]*exp(coeff1*timeSteps + sqrt((vars[[1]])[i])*dis)
	}

# Plotting the actual stock prices and the corresponding simulations
x_label <- "Weekly measurements"
y_label <- "Prices and simulation"
title1 <- "BNP Stock"
title2 <- "Carrefour Stock"
title3 <- "LVMH Stock"
title4 <- "Sanofi Stock"
title5 <- "Total Stock"

quartz()
png(file = "actualAndSimulated.png")
par(mfrow = c(3,2))
plot(df_plain[[1]], pch = 1, col = "black", type = 'l', xlab = x_label, ylab = y_label, main = title1)
lines(geomBMs[[1]], col = 'yellow')
plot(df_plain[[2]], pch = 1, col = "blue", type = 'l', xlab = x_label, ylab = y_label, main = title2)
lines(geomBMs[[2]], col = "yellow")
plot(df_plain[[3]], pch = 1, col = "green", type = 'l', xlab = x_label, ylab = y_label, main = title3)
lines(geomBMs[[3]], col = "yellow")
plot(df_plain[[4]], pch = 1, col = "purple", type = 'l', xlab = x_label, ylab = y_label, main = title4)
lines(geomBMs[[4]], col = "yellow")
plot(df_plain[[5]], pch = 1, col = "red", type = 'l', xlab = x_label, ylab = y_label, main = title5)
lines(geomBMs[[5]], col = "yellow")
dev.off()
graphics.off()

# Rescaling the y-axis by computing the maxima and minima
# and adapting the y-min and y-max
Ymaxima <- c(max(df_plain[[1]],geomBMs[[1]]), max(df_plain[[2]],geomBMs[[2]]),
	max(df_plain[[3]],geomBMs[[3]]), max(df_plain[[4]],geomBMs[[4]]),
	max(df_plain[[5]],geomBMs[[5]]))
Yminima <- c(min(df_plain[[1]],geomBMs[[1]]), min(df_plain[[2]],geomBMs[[2]]),
	min(df_plain[[3]],geomBMs[[3]]), min(df_plain[[4]],geomBMs[[4]]),
	min(df_plain[[5]],geomBMs[[5]]))

# Plotting with the y-axes properly scaled
quartz()
png(file = "actualAndSimulatedRescaled.png")
par(mfrow = c(3,2))
plot(df_plain[[1]], pch = 1, col = "black", type = 'l', xlab = x_label, ylab = y_label, main = title1, ylim = c(Yminima[1], Ymaxima[1]))
lines(geomBMs[[1]], col = 'yellow')
plot(df_plain[[2]], pch = 1, col = "blue", type = 'l', xlab = x_label, ylab = y_label, main = title2, ylim = c(Yminima[2], Ymaxima[2]))
lines(geomBMs[[2]], col = "yellow")
plot(df_plain[[3]], pch = 1, col = "green", type = 'l', xlab = x_label, ylab = y_label, main = title3, ylim = c(Yminima[3], Ymaxima[3]))
lines(geomBMs[[3]], col = "yellow")
plot(df_plain[[4]], pch = 1, col = "purple", type = 'l', xlab = x_label, ylab = y_label, main = title4, ylim = c(Yminima[4], Ymaxima[4]))
lines(geomBMs[[4]], col = "yellow")
plot(df_plain[[5]], pch = 1, col = "red", type = 'l', xlab = x_label, ylab = y_label, main = title5,
ylim = c(Yminima[5], Ymaxima[5]))
lines(geomBMs[[5]], col = "yellow")
dev.off()
graphics.off()


rm(list = ls()) #cleaning up
library(utils)
library(tidyverse)

data <- read.csv("nlsw88.csv")

##########
# Part 1 #
##########
# Testing: log(wage_i) = b_0 + b_1*years_school_i + error_i

# Modeling
fit <- lm(lwage~yrs_school, data=data)
summary(fit)
coefficients(fit)

# Confidence interval 90%
ci <- confint(fit, level=0.90)
ci

# Sum residuals
sum(residuals(fit)) # or sum(fit$residuals)

##########
# Part 2 #
##########
# Testing: log(wage_i) = b_0 + b_1*black_i + error_i
#
# We can deduce:
#   - E[wage|black=0] = b_0 + b_1*E[black=0] + E[error] = b_0 + b_1*0 + 0 = b_0
#   - E[wage|black=1] = b_0 + b_1*E[black=0] + E[error] = b_0 + b_1*1 + 0 = b_0 + b_1
#
# So:
#   - b_0 = E[wage_no_black]
#   - b_1 = E[wage_black] - b_0 = E[wage_black] - E[wage_no_black]
#
mean_no_black = mean(data$lwage[data$black == 0])
mean_black = mean(data$lwage[data$black == 1])

fit2 <- lm(lwage~black, data=data)
coefficients(fit2)
print(mean_no_black) #equals to intercept coefficient
print(mean_black-mean_no_black) #equals to black coefficient

# Hypothesis: black is not affecting the wages
#   - null hypothesis: b_1 = 0
#
# Using t-statistic = b_1/se(b_1)  - taken from summary
summary(fit2)
t_statistic <- -0.16554/0.02744

##########
# Part 3 #
##########
# Testing: log(wage_i) = b_0 + b_1*yrs_school + b_2*ttl_exp + error_i
#
fit3 <- lm(lwage~yrs_school+ttl_exp, data=data)
r2 <- summary(fit3)$r.squared
print(r2) # tell us: 26.7% of the total variance in the logarithm of the wage
          # is explained by the years of schooling and the total experience

# Testing:
#
# Years school counts double over total experience, so:  2*b_1 = b_2
#
# Restricted model:  log(wage_i) = b_0 + b_1*(yrs_school + 2*ttl_exp) + error_i
#
data$yrs_exp <- data$yrs_school+ 2*data$ttl_exp
restricted_fit3 <- lm(lwage~yrs_exp, data=data)
summary(restricted_fit3) # so, b_1 will value 0.026292

# Use 'anova' to calculate ((SSR_r - SSR_u)/r) / (SSR_u/(n - k - 1))
anova_rest = anova(restricted_fit3) #gives us: SSR, SST, degrees freedom, F value, p-value, ...
anova_unrest = anova(fit3)

SSR_r <- anova_rest$`Sum Sq`[2]
SSR_u <- anova_unrest$`Sum Sq`[3]
n_minus_k_plus_1 <- anova_unrest$Df[3] #be careful, it's not counting k+1
f_test_statistic <- ((SSR_r - SSR_u)/r) / (SSR_u/(n_minus_k_plus_1))
f_test_statistic
p_value <- df(f_test_statistic, df1 = 1, df2 = n_minus_k_plus_1)
p_value


require(graphics)
require(deldir)

png("kmeans_bw_voronoi.png", width = 5.5, height = 5.5, units = "in", res = 300)

par(mfrow=c(2,2), mai=c(0.2,0.2,0.2,0.2), xaxt="n", yaxt="n")

pch = c(3,21,22,23,24)

cl = kmeans(as.matrix(iris[,1:2]), centers=2)
vtess <- deldir(cl$centers[,1], cl$centers[,2], rw=c(4,8,1,8))
plot(iris$Sepal.Length, iris$Sepal.Width, type="n", asp=1, main = 'k=2', ylab = 'Sepal Width', xlab='Sepal Length')
points(iris$Sepal.Length, iris$Sepal.Width, bg = gray.colors(2)[cl$cluster], pch=pch[cl$cluster])
plot(vtess, wlines="tess", wpoints="none", number=FALSE, add=TRUE, lty=1)
points(cl$centers, pch=19, cex=1.5, font=2)

cl = kmeans(as.matrix(iris[,1:2]), centers=3)
vtess <- deldir(cl$centers[,1], cl$centers[,2], rw=c(4,8,1,8))
plot(iris$Sepal.Length, iris$Sepal.Width, type="n", asp=1, main = 'k=3', ylab = 'Sepal Width', xlab='Sepal Length')
points(iris$Sepal.Length, iris$Sepal.Width, bg = gray.colors(3)[cl$cluster], pch=pch[cl$cluster])
plot(vtess, wlines="tess", wpoints="none", number=FALSE, add=TRUE, lty=1)
points(cl$centers, pch=19, cex=1.5, font=2)

cl = kmeans(as.matrix(iris[,1:2]), centers=4)
vtess <- deldir(cl$centers[,1], cl$centers[,2], rw=c(4,8,1,8))
plot(iris$Sepal.Length, iris$Sepal.Width, type="n", asp=1, main = 'k=4', ylab = 'Sepal Width', xlab='Sepal Length')
points(iris$Sepal.Length, iris$Sepal.Width, bg = gray.colors(4)[cl$cluster], pch=pch[cl$cluster])
plot(vtess, wlines="tess", wpoints="none", number=FALSE, add=TRUE, lty=1)
points(cl$centers, pch=19, cex=1.5, font=2)

cl = kmeans(as.matrix(iris[,1:2]), centers=5)
vtess <- deldir(cl$centers[,1], cl$centers[,2], rw=c(4,8,1,8))
plot(iris$Sepal.Length, iris$Sepal.Width, type="n", asp=1, main = 'k=5', ylab = 'Sepal Width', xlab='Sepal Length')
points(iris$Sepal.Length, iris$Sepal.Width, bg = gray.colors(5)[cl$cluster], pch=pch[cl$cluster])
plot(vtess, wlines="tess", wpoints="none", number=FALSE, add=TRUE, lty=1)
points(cl$centers, pch=19, cex=1.5, font=2)

dev.off()


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

bs.call <- function(S,K,rf,T,sigma) {
    d1 <- (log(S/K)+(rf+sigma^2/2)*T)/(sigma*sqrt(T))
    S*pnorm(d1)-K*exp(-rf*T)*pnorm(d1-sigma*sqrt(T))
}

oz.per.year <- 10000
rf <- 0.03  # 3% interest rates
wacc <- 0.08  # 8% weighted average cost of capital
s0 <- 1300
s0.lt <- 1200
K <- 1000
sigma <- 0.3

## annual real options approach, no mean reversion
oz.per.year*((s0-K)/(1+wacc) + bs.call(s0,K,rf,1,sigma)/(1+wacc) +
             sum(bs.call(s0.lt,K,rf,1:8,sigma)/(1+wacc)*exp(-rf)))

## annual real options, assuming mean reversion (approximation)
oz.per.year*((s0-K)/(1+wacc) + bs.call(s0,K,rf,1,sigma)/(1+wacc) +
             sum(bs.call(1200,1000,0.03,1,0.3)/(1+wacc)*exp(-rf*(1:8))))

## quarterly real options, no mean reversion
oz.per.year/4*((s0-K)/(1+wacc)^0.25
    + sum(bs.call(1300,1000,0.03,(1:4)/4,0.3)/(1+wacc)^0.25)
    + sum(bs.call(1300-25*(1:3),1000,0.03,0.25,0.3)/(1+wacc)^0.25*exp(-rf*(5:7)/4))
    + sum(bs.call(1200,1000,0.03,(1:32)/4,0.3)/(1+wacc)^0.25*exp(-rf*(8:39)/4)))

## quarterly real options, assuming mean reversion (approximation)
oz.per.year/4*((s0-K)/(1+wacc)^0.25
    + sum(bs.call(1300,1000,0.03,0.25,0.3)/(1+wacc)^0.25*exp(-rf*(0:3)/4))
    + sum(bs.call(1300-25*(1:4),1000,0.03,0.25,0.3)/(1+wacc)^0.25*exp(-rf*(4:7)/4))
    + sum(bs.call(1200,1000,0.03,0.25,0.3)/(1+wacc)^0.25*exp(-rf*(8:39)/4)))


#' @title Binomial distribution simulator
#'
#' @param iter The number of iterations to simulate, an integer
#' @param n The size of the binomial distribution
#' @param p The probability of success
#'
#' @return A barplot of the binomial distribution
#' @export
#'
#' @importFrom grDevices rainbow
#' @importFrom graphics barplot
#'
#' @examples
#' \dontrun{mybin(iter = 10000, n = 20, p = 0.7)}
mybinomial=function(iter=100,n=10, p=0.5){
  # make a matrix to hold the samples
  #initially filled with NA's
  sam.mat=matrix(NA,nrow=n,ncol=iter, byrow=TRUE)
  #Make a vector to hold the number of successes in each trial
  succ=c()
  for( i in 1:iter){
    #Fill each column with a new sample
    sam.mat[,i]=sample(c(1,0),n,replace=TRUE, prob=c(p,1-p))
    #Calculate a statistic from the sample (this case it is the sum)
    succ[i]=sum(sam.mat[,i])
  }
  #Make a table of successes
  succ.tab=table(factor(succ,levels=0:n))
  #Make a barplot of the proportions
  barplot(succ.tab/(iter), col=rainbow(n+1), main="Binomial simulation", xlab="Number of successes")
  succ.tab/iter
}


## See Bayesian Choice, pg. 181
posterior_ccdf <- function(n0, m){
  if(n0 < 1 || m < 1 || n0 <  m) stop("Something is wrong, check your parameters")
  require(VGAM)
  lnum <- log(VGAM::zeta(x = 2, shift = n0))
  ldenom <- log(VGAM::zeta(x = 2, shift = m))
  return(exp(lnum - ldenom))
}
posterior_ccdf <- Vectorize(posterior_ccdf)
approximate_posterior_ccdf <- function(n0, m){
  m/n0
}
approximate_posterior_ccdf <- Vectorize(approximate_posterior_ccdf)

obs.tram.number <- 100

k <- 10

N0s <- obs.tram.number:(k*obs.tram.number)

ps <- posterior_ccdf(n0 = N0s, m = obs.tram.number)
app.ps <- approximate_posterior_ccdf(n0 = N0s, m = obs.tram.number)

plot(N0s, 1-ps, type = "l", lwd = 3,
     main = "CDF of N given T",
     xlab = expression(n[0]), ylab = expression(Pr(N >= n[0])))
lines(N0s, 1-app.ps, col = 2, lwd = 2, lty = 2)
legend(x="bottomright",
       legend = c("Exact", "Approximate"),
       col = 1:2, lty = 1:2, lwd = 2, bty = 'n')
abline(h = 1/2, lty = 2)
abline(v = 2*obs.tram.number, lwd = 2, col = 2, lty = 2)


##########################################################################
##################This script provides examples for ######################
##################an introduction to R basic concepts ####################
##########################################################################
#R is just a sophisticated calculator
6^6
5+210
3-10

#Basic data concepts in R
#Assign a name for an object
Ex<-6
#look at object
Ex
#use the object in a calculation
Ex*5

#set up a vector
Vec<-c(3,4,5,2,10,4,6)
#subset the vector by the first two elements
Vec[1:2]

#set up a matrix
Mat<-matrix(c(1,2,3,4,5,6), ncol=2, byrow=TRUE)
Mat
#set up a matrix that fills in by columns
Mat.bycol<-matrix(c(1,2,3,4,5,6), ncol=2, byrow=FALSE)
Mat.bycol

#calculate the average value of Vec
mean(Vec)
#specify arguments by name and not order
mean(na.rm=TRUE,x=Vec)

# multiply matrix by vector
Mat.scale<-matrix(c(2,2,2,3,3,3), ncol=2,byrow=TRUE)
Mat*Mat.scale

#multiply vector by 5
Vec*5

#data types
#note there are different types of data
#and here's what they look like

#numeric
N.ex<-14/15
N.ex
#character
C.ex<-c("December")
C.ex
#Factor
F.ex<-as.factor("a")
F.ex

#set working directory
#this is the file path for where your file is saved
setwd("c:\\Users\\scardarelli\\Documents/research/siberia_lai/R_Intro-master/1_Intro/")
#check what your working directory is set at
getwd()

#read in data file
datM<-read.csv("mountain_data.csv")
#check out data
datM

#get dimensions of the dataset
dim(datM)
#Note output is a vector of 2 values
#we can name this and refer to later
Mdim<-dim(datM)

#get the column names
names(datM)

#look at the names and first 5 rows
head(datM)
tail(datM)
#look at only the name columne
#refer to a column in a data frmae
#dataframename$column.name
datM$Name

#look at name in second column
datM[,2]

#refer to multiple columns
datM[,2:4]

#refer to several rows
datM[1:3,]

#make a data frame
M.ft<-data.frame(Rank=datM$Rank, Elev=datM$Elev.ft)
M.ft

#subset all of the tallest mountains in the US
US.M<-datM[datM$Region=="US",]

#subset by mountains above 20,000 ft
High.M<-datM[datM$Elev.ft>20000,]
High.M

#look at difference between prominance and elevation
High.M$Elev.ft-US.M$Prom.ft
#oops, you should see a warning message
#this is using mismatched vectors!!!
#watch for these error and warnign messages
#because they are important!!

#here is the correct code
High.M$Elev.ft-High.M$Prom.ft


setwd('/Users/demg/Projects/FA/Course III/ECONOMETRICS/task4')
data <- read.table('./AG.txt', dec=',', header=TRUE)
getwd()
#install.packages('lmtest')
#install.packages("ggiraphExtra")
library(lmtest)
library(ggiraphExtra)

x <- data$x
y <- data$y
x
y

#линейная модель
m1<-lm(y~x,data=data)
m1
sm1<-summary(m1)
sm1
A1 <- (sum(abs(sm1$residuals/y))/length(y))*100

ggPredict(m1, interactive = TRUE)
#данная модель значима
#критерий Стьюдента
#H0 отвергается, коэффициенты значимы

#показательная модель
m2<-lm(log10(y)~x,data=data)
m2
sm2=summary(m2)
sm2

A2 <- (sum(abs(sm2$residuals/log10(y)))/length(log10(y)))*100
ggPredict(m2, interactive = TRUE)
#данная модель значима
#критерий Стьюдента
#H0 отвергается, коэффициенты значимы

#степенная модель
x1<-log10(x)
y1<-log10(y)
m3<-lm(y1~x1,data=data)
m3
sm3=summary(m3)
sm3

A3 <- (sum(abs(sm3$residuals/y1))/length(y1))*100
ggPredict(m3, interactive = TRUE)
#данная модель значима

#гиперболическая модель
#критерий Стьюдента
#H0 отвергается, коэффициенты значимы

x2<-1/x
m4<-lm(y~x2,data=data)
m4
sm4=summary(m4)
sm4

A4 <- (sum(abs(sm4$residuals/y))/length(y))*100
ggPredict(m4, interactive = TRUE)

#Линейная
print(sm1$sigma)
print(sm1$r.squared)
print(sm1$fstatistic)
print(A1)

#Показательная
print(sm2$sigma)
print(sm2$r.squared)
print(sm2$fstatistic)
print(A2)

#степенная
print(sm3$sigma)
print(sm3$r.squared)
print(sm3$fstatistic)
print(A3)

#гиперболическая
print(sm4$sigma)
print(sm4$r.squared)
print(sm4$fstatistic)
print(A4)

#данная модель значима
#критерий Стьюдента
#H0 не отвергается, коэффициенты незначимы

#Отчет
#у гиперболической модели самый маленький коэффициент детерминации, а у показательной коэффициент
#R-squared:  0.6878791 (ближе всего к 1), значит,качество данной модели лучшее среди всех остальных


# Brute force, see the "Permutations" page for the next.perm function
safe <- function(p) {
	n <- length(p)
	for(i in 1:(n-1)) {
		for(j in (i+1):n) {
			if(abs(p[j] - p[i]) == abs(j - i)) return(FALSE)
		}
	}
	return(TRUE)
}

queens <- function(n) {
	p <- 1:n
	k <- 0
	while(!is.null(p)) {
		if(safe(p)) {
			cat(p,"\n")
			k <- k + 1
		}
		p <- next.perm(p)
	}
	return(k)
}

queens(8)
# 1 5 8 6 3 7 2 4
# ...
# 92


fib=function(n,x=c(0,1)) {
   if (abs(n)>1) for (i in seq(abs(n)-1)) x=c(x[2],sum(x))
   if (n<0) return(x[2]*(-1)^(abs(n)-1)) else if (n) return(x[2]) else return(0)
}

sapply(seq(-31,31),fib)


#' Probability of path choices using logit model.
#'
#' This function calculates probabilities for selection of each path on the network based on set of path disutilities (costs). The function uses a logit random utility model.
#' @param u Vector of utlities on each path
#' @param ODpair Vector indicating the OD pair serviced by each route.
#' @param theta The logit parameter. Defaults to 1.
#' @return Vector of route choice probabilities
#' @keywords path route probability
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' ODpair <- c(1,1,2,2)
#' Alpha <- rep(10,7)
#' Beta <- rep(2,7)
#' pow <- rep(4,7)
#' path_flow <- c(10,20,15,15)
#' x <- A%*%path_flow
#' u <- PathCost(x,A,Alpha,Beta)
#' LogitPathProb(u,ODpair,theta=0.7)
#' @export

LogitPathProb <- function(u,ODpair,theta=1){
	u <- u - rep(tapply(u,ODpair,min),table(ODpair))
	p1 <- exp(-theta*u)
	p.sums <- tapply(p1,ODpair,sum)
	p.sums <- rep(p.sums,unname(table(ODpair)))
	p1/p.sums
}


y1bar=25.1
y2bar=23.5
y3bar=37.8

MSE=10.278
sigma=sqrt(MSE)

# crtical value
alpha = 0.025
z.alpha=qt(1-alpha,df=15)

# For panels 2 and 3, we have nt = 10 observations per panel, thus confidence interval will be
n=10
error=sigma*z.alpha*sqrt(2/n)
#  thus confidence interval will be
left_i=(y3bar-y2bar)-error
right_i=(y3bar-y2bar)+error
print("confidence interval is")
print(left_i)
print(right_i)


## Load some packages that will be useful
library(mgcv) # load the MGCV package with Simon Wood's gam() functions
library(readr) # Hadley Wickham's package for reading in data easily
library(ggplot2) # for plotting with ggplot
library(ggfortify) # for autoplot

##################################################################################################
## We'll first examine the bias-variance tradeoff in a simplified form with a small exercise.
## If you remember, this tradeoff is one of the concepts behind finding the optimal amount of smoothing.
## We'll fit linear regressions to parts of the data, increasing the number of parts from 1 to 10.
##################################################################################################

# First, read in the bioluminescence data.
# Sources is the number of bioluminescent plankton seen in each water sample
# SampleDepth is the depth of the water sample, in m
# Station is the ID of the location at which multiple water samples were taken
ISIT <- read_tsv(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/ISIT.txt')) # tsv for tab-separated values

# Subset it to one station. This is what we'll work with for now.
ISITsub <- subset(ISIT, Station == 8)

# Plot the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point()

# Now you can fit a linear regression to the ISITsub dataset, with Sources as the response and SampleDepth as the explanatory variable
# Please call the output "mod1", as I've started to fill in for you
mod1 <- lm(Sources ~ SampleDepth, data=ISITsub)

# Q1: What was your code for fitting a linear regression of Sources vs. SampleDepth?

## mod1 <- lm(Sources ~ SampleDepth, data=ISITsub)

# We'll predict the mean response and confidence intervals from this model and save the output
ISITsub$mod1 <- predict(mod1)
ISITsub$mod1lwr <- predict(mod1, interval='confidence', level=0.95)[,'lwr']
ISITsub$mod1upr <- predict(mod1, interval='confidence', level=0.95)[,'upr']

# Now plot the linear model fit to the full dataset on top of the data
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3)

# Q2: Use your skills from earlier in this course and evaluate this linear model (autoplot may be useful here). How does this fit look to you? Does a linear regression look reasonable? Any well-justified answer is appropriate.

## Visually you can see that the linear model is not a great fit

autoplot(mod1)

## From autoplot()'s QQ plot we can see that the residuals don't look normal, and the sign and magnitude of the
## residuals still show a pattern when plotted against the fitted values. The variance does seem to be pretty
## homogeneous, however. It also looks like some data-points (represented in the bottom right hand corner of the
## residuals vs leverage plot, eg. 20, 17 & 24) are having an outsized effect on the model fit.

# For comparison, let's fit linear models to two halves of the data. This involves a fair bit of coding in R, so please ask for help understanding the code where things are confusing.
# First, we have to find the halves of the data
quants2 <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.5)) # define the ends and the half-way point in the data with the quantile function
ISITsub$split2 <- cut(ISITsub$SampleDepth, breaks=quants2, include.lowest=TRUE, labels=1:2)

# Q3: In your own words, what does the cut() function do? How are we using it here?

## It looks like cut creates a new column that assigns each row to one of the quantiles (1 & 2 in this case)

# Next, let's fit a linear model to each subset (half) of the data. We do this in a loop to make it easier.
mod2s <- vector('list', length=2) # A list to hold each of our models in a single, convenient object
ISITsub$mod2 <- ISITsub$mod2lwr <- ISITsub$mod2upr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mod2s)){ # Loop through each model
	mod2s[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split2==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
	ISITsub$mod2[ISITsub$split2==i] <- predict(mod2s[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
	ISITsub$mod2lwr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
	ISITsub$mod2upr[ISITsub$split2==i] <- predict(mod2s[[i]], interval='confidence', level=0.95)[,'upr']
}

# Plot the data, the 1-model fit, and the 2-model fit
# There will be an odd 3rd line segment connecting the end of the first model fit to the beginning of the second model fit. Just pretend it's not there.
ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
	geom_point() +
	geom_line(aes(y=mod1)) +
	geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
	geom_line(aes(y=mod2, color='red')) +
	geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red')

# Q4: Has the fit between the model and the data improved? What's the downside of continuing the split the data into finer and finer chunks and fitting more models?

## It does look better, the average distance between points and the line are definitely smaller now than they
## were for the linear model.

# Now, it's your turn. Please fit 10 linear regression models. I'd recommend using the 2-model code above as a guide and tweaking it.

quants <- quantile(ISITsub$SampleDepth, probs=seq(0, 1, by=0.1))
ISITsub$split <- cut(ISITsub$SampleDepth, breaks=quants, include.lowest=TRUE, labels=1:10)

mods <- vector('list', length=10) # A list to hold each of our models in a single, convenient object
ISITsub$mods <- ISITsub$modslwr <- ISITsub$modsupr <- NA # Initialize the variables we'll use and fill with NA
for(i in 1:length(mods)){ # Loop through each model
    mods[[i]] <- lm(Sources ~ SampleDepth, data=ISITsub[ISITsub$split==i,]) # Fit a linear regression to the appropriate subset of the data. Now see why we made the split2 vector?
    ISITsub$mods[ISITsub$split==i] <- predict(mods[[i]]) # Now predict from that model. Notice we're only predicting for part of the data.
    ISITsub$modslwr[ISITsub$split==i] <- predict(mods[[i]], interval='confidence', level=0.95)[,'lwr'] # Same for the confidence intervals
    ISITsub$modsupr[ISITsub$split==i] <- predict(mods[[i]], interval='confidence', level=0.95)[,'upr']
}

# Now plot the 10 models on top of the data and on top of the 1- and 2-model fits. The plot with the data, 1-model, and 2-model fit is probably a useful guide here.

ggplot(ISITsub, aes(x=SampleDepth, y=Sources)) +
    geom_point() +
    geom_line(aes(y=mod1)) +
    geom_ribbon(aes(ymin=mod1lwr, ymax=mod1upr), alpha=0.3) +
    geom_line(aes(y=mod2, color='red')) +
    geom_ribbon(aes(ymin=mod2lwr, ymax=mod2upr), alpha=0.3, fill='red')+
    geom_line(aes(y=mods, color='blue'))+
    geom_ribbon(aes(ymin=modslwr, ymax=modsupr), alpha=0.3, fill='blue')

# Q5: Compare your 10-model fit to the 1-model fit. Which model's predictions are furthest from the observed data? Which model has the widest confidence bounds? How does this (or does this not) illustrate the bias-variance tradeoff?

## The 10-model fit goes through almost all the points, and goes very close to the others. The 1-model fit's predictions
## are the furthest from the observed data. The confidence interval on the 10 model fit is very large in some places.
## This demonstrates that as you improve fit by adding complexity to the model, you also increase the variance around
## the predictions and thereby decrease certainty in the predictions.

####################################################
## Now you'll fit some GAMs and evaluate your models
####################################################
#install.packages("maps") # if needed
library(maps) # has map data in it

# load the data
spdata <- readRDS(url('https://github.com/aeda2021/2021_master/raw/main/raw-data/gadusmorhua.rds')) # load the spdata data.frame with abundance and environmental data from cod surveys
spdata$presfit01 <- as.numeric(spdata$presfit) # make a vector that's nice for plotting
spdata <- spdata[order(spdata$presfit01),] # order the data from absent to present for ease of plotting

# examine the data
head(spdata) # look at the dataset
summary(spdata)

# make a map of the data
world <- map_data('world')

ggplot() +
	geom_polygon(data=world, aes(x=long, y=lat, group=group), color='black', fill=NA) + # the map
	xlim(-100, -45) +
	ylim(23, 62) +
	geom_point(data=spdata, aes(x=lon, y=lat, color=presfit, alpha=0.1), size=0.01) # the data points. note that because the dataframe is sorted from absent to present, the presences are plotted on top of the absences

# Q6: Based on the map, do you think cod prefer warmer or cooler waters? Why do you think that?

## According to the map, cod site occupancy is much more common in the cold waters of New England and Atlantic
## Canada.

# Q7: Plot cod presence/absence (the presfit vector) vs. the bottom temperature (SBT.actual). At what range of temperatures have cod been observed?

ggplot(spdata, aes(y=SBT.actual, group=presfit01)) +
    geom_boxplot()

# Q8: Fit a GAM for presfit against SBT.actual. Check the model. Does it look like the assumptions have been met? Why or why not?

gam1 <- gam(presfit01 ~ s(SBT.actual), data=spdata)
gam.check(gam1)

plot(gam1)

## Those look weird. The histogram of residuals looks bimodal, and everything else is two equidistant lines,
## because the data is binary.

# Q9: Fit a new GAM with a more appropriate error structure and save it as "mod2". The gam() function takes the same family= argument as does glm(). Which error structure and link function did you choose?

mod2 <- gam(presfit01 ~ s(SBT.actual), data=spdata, family='binomial')

summary(mod2)

## I used the binomial error distribution because of the binary nature of the outcome data, and left the link
## family as the default 'logit'.

# Q10: Check your mod2 GAM. Does it look like the assumptions have been met? Make sure to read the text output as well as look at the graphs. If something doesn't look right, what would you do to fix it?

gam.check(mod2)

check_model(mod2)

plot(mod2, ylim=c(-100,1000))

## The the QQ plot looks much better. The others still look a little funky, including the histogram of residuals
## which is still bimodal.

# Q11: Interpret your mod2 GAM (summary function). How much deviance is explained? Is the SBT.actual term significant at alpha=0.05? How wiggly do you expect the smooth fit to be?

summary(mod2)

## The GAM explains 26.5% of the deviance. The SBT.actual interaction is highly significant, (so yes, significant at alpha = 0.05).
## My first instinct was that there was no reason for the fit to be wiggly given what appears to be a straightforward
## threshold type relationship between temperature and presense of cod. However, seeing an edf of about 9 made me unsure
## (Zuur says 10ish edf is usually pretty wiggly, iirc). Because I already plotted the model, though, I can see
## that it is not very wiggly!

# Now let's make predictions from our last model (mod2) and plot them.
nd <- data.frame(SBT.actual = seq(-5,30, by=0.5)) # make a data.frame of new explanatory variables
nd$mod2 <- predict(mod2, newdata=nd, type='response') # predict on the scale of the response
nd$mod2se <- predict(mod2, newdata=nd, type='response', se.fit=TRUE)$se.fit # get the standard errors of the fit

ggplot(spdata, aes(x=SBT.actual, y=presfit01)) +
	geom_point() +
	geom_line(data=nd, aes(x=SBT.actual, y=mod2, color='red')) +
	geom_ribbon(data=nd, aes(x=SBT.actual, ymin=mod2-mod2se, ymax=mod2+mod2se), alpha=0.3, fill='red', inherit.aes=FALSE)

# Q12: Does the fit look realistic? Why or why not? Does it look overfit? Why or why not?

## I suspect that the model might be overfit. Without knowing the ecology of cod very well or diving into the
## data much deeper, it seems odd to me that there is a wiggle in the line between SBT =  1 and SBT = 6ish...
## I would have though the true relationship to be more monotonically decreasing in this interval. However
## there may be some ecological explanation that I'm not aware of... closer inspection of the data may give a
## hint here.

# Q13: This dataset is actually a concatenation of seven different surveys which each have slightly different abilities to catch cod. Fit a new GAM that includes a categorical predictor for survey (the region vector). Based on AIC, which model would you choose? How confident would you be?

mod3 <- gam(presfit01 ~ s(SBT.actual) + factor(region), data=spdata, family='binomial')
summary(mod3)
AIC(mod2, mod3)

## The model with region as a factor explains more of the deviance (33%) and has a lower AIC (delta AIC = 800),
## Such a large delta AIC makes me very confident that the model with region as a factor is a better choice.


births <- read.table('birth.txt',header=T)

# fit a loess regression

birth.lo <- loess(netherlands~year, data=births)
plot(birth$year,predict(birth.lo))

# the span = argument to loess() is the smoothing parameter
#  higher = smoother (more like an overall quadratic)

# compare predicted values with those from a quadratic model

birth.lm2 <- lm(netherlands~year + I(year^2), data=births)
# the I() bit is to tell R to evaluate the formula inside
# an alternative is to compute year2 in the births data frame
# births$year2 <- births$year^2
# birth.lm2 <- lm(netherlands~year + year2, data=births)

plot(birth$year, predict(birth.lm2))
lines(birth$year,predict(birth.lo))

# would be nice to use anova() to compare the two fits, but
#  anova can only compare loess() to loess() or lm() to lm()

# trick loess into giving you a quadratic regression

birth.lo2 <- loess(netherlands~year, data=births, span=100)
anova(birth.lo2, birth.lo)

# trick loess into giving you a linear regression
birth.lo1 <- loess(netherlands~year, data=births, span=100, degree=1)
anova(birth.lo1, birth.lo)

# The mgcv library provides gam() which gives you smoothing splines
#  and generalized additive models (covered in 511)

# Breusch-Pagan test, need to assemble by specific computations

# just the linear regression
birth.lm <- lm(netherlands~year,data=births)

esq <- (45/0.00006542)*resid(birth.lm)^2
# need to replace 45 by N, 0.00006542 by SSE

bp <- lm(esq~births$year)
summary(bp)
# gives you the information for the Breush-Pagan test

# the cut() function breaks a continuous variable into groups
yeargroup <- cut(birth$year,breaks=seq(1949,1994,5))

# seq(1949, 1994, 5) gives 1949, 1954, 1959, ...
# breaks includes the lowest break in the first group
# so the first group includes 1949, 1950, 1951, 1952, and 1953.
# 1954 goes into the second group

# the result of cut() is a factor

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


# Recursive function to find factorial
recursive.factorial <- function(x) {
if (x == 0)    return (1)
else           return (x * recursive.factorial(x-1))
}


# ************************************************
### simon munzert
### maximum likelihood estimation
# ************************************************

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

### Writing functions in R -----------------------

# R is a functional programming lanugage, i.e. it provides many tools for the creation and manipulation of functions
# you can do virtually anything with functions: assign them to variables, store them in lists, pass them as arguments to other functions, ...
# very helpful in obeying the "don't repeat yourself" a.k.a. DRY principle

f <- function(x) x^2
f
f(3)

# function that returns the mean of a vector
my_mean <- function(my_vector) {
  mean <- sum(my_vector)/length(my_vector)
  mean
}
my_mean(c(1, 2, 3))
my_mean

# another function that finds the remainder after division ("modulo operation")
remainder <- function(num = 10, divisor = 4) {
  remain <- num %% divisor
  remain
}
remainder()
args(remainder)

## let's study the "functions.r" file now!

### Exercise: Functions --------------------------
# 1. program a function ultimateAnswer() that always returns the number 42!
# 2. program a function normalize() that produces normalizes a numeric vector x to mean(x) = 0 and sd(x) = 1!

### Probability distributions in R -----------

# for an overview of implemented distributions, see
?Distributions

## the Normal distribution

# rnorm() performs random draws from the distribution
y <- rnorm(1000, mean = 0, sd = 1)
plot(y)
plot(density(y))

# dnorm() gives the density of the distribution
dnorm(0, mean = 0, sd = 1)
z_scores <- seq(-3, 3, by = .1)

dvalues <- dnorm(z_scores)
plot(z_scores, dvalues, type = "l", main = "pdf of the Standard Normal", xlab = "Z score")

# pnorm() gives the distribution function
pnorm(0)
pnorm(-1)
pnorm(1.96)
pnorm(1.96, lower.tail = FALSE)

pvalues <- pnorm(z_scores)
plot(z_scores, pvalues,  type = "l", main = "cdf of the Standard Normal", xlab= "Z score", ylab="Probability Density")

## the Binomial distribution
p <- 0.5
n <- 100
size <- 5
tmp <- rbinom(n, size, p)
table(tmp)
plot(table(tmp), xlab = "Sum of 1 in N", ylab = "Occurrence in n = 100")
text(4.5, c(27, 24, 21), c(paste0("n = ", n), paste0("p = ", p), paste0("N = ", size)))

## Example 1: Coin flips ----------------------

# get 100 random draws from a binomial distribution with p = .4 --> the estimate we're actually interested in
set.seed(1234)
flips <- rbinom(n = 100, size = 1, prob = .4)
table(flips)

# define likelihood function
binom_loglik <- function(x, p) { # x: vector of results/observed 0s and 1s, p: probability of success
  llik <- sum(dbinom(x, size = 1, prob = p, log = TRUE)) # calculate log likelihood with pdf for binomial distribution
  return(-llik) # return the negative log likelihood
}

# visually identify parameter value for which negative likelihood is minimized (= likelihood is maximized)
llks <- vector()
probs <- seq(0, 1, .01)
for (i in seq_along(probs)) {
  llks[i] <- -sum(dbinom(flips, size = 1, prob = probs[i], log = TRUE))
}
plot(probs, -llks, type = "l")
abline(v = probs[which.min(llks)], col = "red", lty = 2)

# numerically optimize log-likelihood
result <- optim(par = .5, fn = binom_loglik, x = flips, method = 'Brent', lower = 0, upper = 1)
result
# par: initial values of parameter to be estimated, we assume a fair coin
# fn: function to be minimized
# lower/upper: since probability paramenter can only be within the unit interval

## Example 2: Linear model ---------------------

# prepare data, run OLS
data("wage1")
wage_ols <- lm(wage ~ educ, data = wage1)
summary(wage_ols)
y <- wage1$wage
X <- cbind(1, wage1$educ)

# define likelihood function...
# ... but how? Here are three options:
  # 1. minimizing the sum of squared residuals (not an acutal ML estimate)
  # 2. maximizing the log-likelihood for normally distributed residuals
  # 3. maximizing the log-likelihood for normally distributed DVs

# 1. Squared residuals
ols <- function(y, X, b) {
  res <- y - X %*% b # calculate residuals
  return(sum(res^2, na.rm = TRUE))
}
# this function calculates the sum of squared residuals
# OLS is defined to return coefficients that give the smallest possible
# sum of squared residuals

# 2. normally distributed residuals
normal_loglik <- function(theta, y, X) {
  b <- theta[-length(theta)] # b's
  sigma <- theta[length(theta)] # sigma
  res <- y - X %*% b # residuals
  return(-sum(dnorm(res, mean = 0, sd = sigma, log = TRUE), na.rm = TRUE))
}
# implies the following assumption on the distribution of e:
# y = f(X, b) + e with e ~ N(0, sigma)

# 3. normally distributed y
normal2_loglik <- function(theta, y, X) {
  b <- theta[-length(theta)] # b's
  sigma <- theta[length(theta)] # sigma
  yhat <- X %*% b # predicted values for y
  return(-sum(dnorm(y, mean = yhat, sd = sigma, log = TRUE), na.rm = TRUE))
}
# an equivalent formulation is
# y ~ f(theta, sigma) with theta = g(X, b)

# OLS solution
result_ols <- optim(par = c(1, 1), fn = ols, y = y, X = X, method = "BFGS")
result_ols

# optimize log-likelihoods
result_normal <- optim(par = c(1, 1, 1), fn = normal_loglik, y = y, X = X, method = "BFGS")
result_normal

result_normal2 <- optim(par = c(1, 1, 1), fn = normal2_loglik, y = y, X = X, method = "BFGS")
result_normal2

# compare again with OLS
summary(wage_ols)

## Assessing estimation uncertainty ---------------------

result <- optim(par = c(1, 1, 1), fn = normal_loglik, y = y, X = X, hessian = TRUE) # set hessian = TRUE to optain Hessian matrix, which contains the second-order partial derivates

inv_hess <- solve(result$hessian) # take the inverse of the Hessian to get the Fisher information matrix

sigma <- sqrt(diag(inv_hess)) # the square root of the diagonals are then the standard errors

estimates_df <- data.frame(params = result$par,
                           ci95lo = result$par - 1.96 * sigma,
                           ci95hi = result$par + 1.96 * sigma)
rownames(estimates_df) <- c("beta_0", "beta_1", "sigma2")
estimates_df


# Guía del fichero: https://rpubs.com/probestaunal/tablas

######################
#  ANÁLISIS GRÁFICO  #
######################

# graficar las frecuencias relativas
nj <- c(145, 2415, 3456, 852, 459, 157, 130)
names(nj) <- 0:6
barplot(nj)

# graficar las frecuencias relativas
hj <- prop.table(nj)
barplot(hj)

##################################################################
#                   DISTRIBUCIÓN DE FRECUENCIAS                  #
##################################################################
# Considerar el siguiente conjunto de datos asociados con el     #
# nivel educativo de una muestra de empleados (Bachillerato (B), #
# Pregrado (P), Maestría (M), y Doctorado (D)). Elaborar la      #
# tabla de frecuencias correspondiente.                          #
#                                                                #
# B, D, M, B, B, P, B, M, B, B, B, P, B, M, B, B, M, B, M, B, B, #
# B, B, B, B, B, P, B, B, B, B, M, B, P, B, B, M, B, B, B, D, B, #
# M, B, P, B, B, B, P, P                                         #
##################################################################

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

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

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

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

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

##################################################################################################
#                                    VARIABLES CUANTITATIVAS                                     #
##################################################################################################
# Considerar el siguiente conjunto de datos asociados con el peso (en kg) de una                 #
# muestra de materiales. Elaborar la distribución de frecuencias correspondiente.                #
#                                                                                #
# 103.1, 82.1 , 106.2, 100.9, 91.8, 96.1 , 126.9, 119.8, 93.1 , 86.8, 75.2 , 93.0, 82.3 , 94.8,  #
# 64.2 , 105.3, 108.0, 86.3 , 81.8, 138.1, 92.5, 66.3 , 66.6 , 142.2, 96.5 , 74.8, 95.4 , 100.1, #
# 81.9 , 112.0, 116.8, 103.2, 66.1, 60.4 , 78.7                                                  #
##################################################################################################

# datos
peso<- c(103.1, 82.1, 106.2, 100.9, 91.8,  96.1,  126.9, 119.8, 93.1, 86.8, 75.2, 93.0,
         82.3,  94.8, 64.2,  105.3, 108.0, 86.3,  81.8,  138.1, 92.5, 66.3, 66.6, 142.2,
         96.5,  74.8, 95.4,  100.1, 81.9,  112.0, 116.8, 103.2, 66.1, 60.4, 78.7)
# tamaño de la muestra
n <- length(peso)
print(n)

# numero de intervalos
m <- round(1 + 3.3*log(n, base = 10), 2)
print(m)

# rango
R <- max(peso) - min(peso)
print(R)

# amplitud
a <- R/m
print(a)

# limites
lim <- min(peso) + (0:m)*a
print(lim)
# frecuencias absolutas
nj <- table(cut(x = peso, breaks = lim, include.lowest = T))
print(nj)

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

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

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


f1 <- function(x) dnorm(x)
f2 <- function(x) dcauchy(x)
f3 <- function(x) dt(x, df = 1)
f4 <- function(x) dt(x, df = 5)
f5 <- function(x) dt(x, df = 30)

par(mfrow = c(1, 2))
curve(f1, -5, 5, xlab = expression(x), ylab = "Densidade", lwd = 2)
curve(f2, lwd = 2, col = "grey50", add = TRUE)
curve(f3, lwd = 2, col = "red", lty = 2, add = TRUE)
curve(f4, lwd = 2, col = "blue", lty = 3, add = TRUE)
curve(f5, lwd = 2, col = "red", lty = 4, add = TRUE)

curve(f1, 2, 5, xlab = expression(x), ylab = "Densidade", lwd = 2)
curve(f2, lwd = 3, col = "grey50", add = TRUE)
curve(f3, lwd = 3, col = "red", lty = 2, add = TRUE)
curve(f4, lwd = 3, col = "blue", lty = 3, add = TRUE)
curve(f5, lwd = 3, col = "red", lty = 4, add = TRUE)

legend(x = "topright",
       legend = c(
         "N(0,1)",
         "Cauchy",
         "T(1)",
         "T(5)",
         "T(30)"
       ),
       col = c("black", "grey50", "red", "blue", "red", "blue"),
       lty = c(1, 1, 2, 3, 4, 5),
       lwd = 2,
       bty = 'n')