#' Metropolis-Hastings sampler
#'
#' sample xhat from the target distribution p(xhat), with given proposal distribution q(xhat|x), the acceptance rate is: \cr
#'   min( 1 , dp(xhat)/dp(x) * dq(x|xhat)dq(xhat|x) ) \cr
#' where dp() is the density function of the target distribution, dq() the the density function of the proposal distribution. A new sample xhat is drawn from the sampler of the proposal distribution rq(). See examples.
#'
#' @param nsamples integer, number of samples to draw
#' @param xini initial sample, the chain of samples starts from here. xini must be a matrix of one row, or a numeric vector that will be converted to a matrix of one row.
#' @param dp function(x), the LOG density function of the target distribution log dp(x), DON'T FORGET THE LOG.
#' @param dq function(xhat,x), the LOG density function of the proposal distribution log dq(xhat | x), DON'T FORGET THE LOG.
#' @param rq function(x), the generator of the proposal distribution rq(xhat | x).
#' @return a matrix of nsamples rows.
#' @export
#' @examples
#' \donttest{
#'
#' ## example1: independent Metropolis-Hastings algorithm, get 5000 samples from Beta(2.7,6.3)
#' ## with independent uniform proposal U(0,1), and independent normal proposal N(0.5,1).
#'
#' ## step1: define p() and q()
#' dp <- function(x) if(x>0&x<1) dbeta(x,2.7,6.3,log = TRUE) else -Inf
#' dq1 <- function(xnew,x) 0               #uniform proposal log density
#' dq2 <- function(xnew,x) dnorm(xnew,0.5,1) #normal proposal log density
#' rq1 <- function(x) runif(1,0,1)           #uniform proposal sampler
#' rq2 <- function(x) rnorm(1,0.5,1)         #normal proposal sampler
#' ## step2: get 5000 samples, with two different proposals
#' X1 <- MetropolisHastings(nsamples = 5000,xini = runif(1,0,1),dp=dp,dq=dq1,rq=rq1)
#' X2 <- MetropolisHastings(nsamples = 5000,xini = runif(1,0,1),dp=dp,dq=dq2,rq=rq2)
#' ## step3: plot the result, calculate acceptance rate
#' sum(diff(X1)!=0)/nrow(X1)                 #the acceptance rate of uniform proposal
#' sum(diff(X2)!=0)/nrow(X2)                 #the acceptance rate of normal proposal
#' ## Clearly Uniform, compare to Normal, can better resemble Beta, so the acceptance rate is higher
#' ## plot the results
#' hist(X1)
#' hist(X2)
#' hist(rbeta(5000,2.7,6.3))
#'
#' ## example2: independent Metropolis-Hastings algorithm, sample from an improper distribution
#' ## p(x) = -|x|+1, where -1<x<1, with independent uniform proposal U(-1,1)
#'
#' ## step1: define p() and q()
#' dp <- function(x) log(-abs(x)+1)        #log dp
#' dq <- function(xnew,x) 1
#' rq <- function(x) runif(1,-1,1)         #make sure -1<x<1
#' ## step2: get 5000 samples
#' X <- MetropolisHastings(nsamples = 5000,xini = runif(1,-1,1),dp=dp,dq=dq,rq=rq)
#' ## step3: plot the result, calculate acceptance rate
#' hist(X)
#' sum(diff(X)!=0)/nrow(X)                 #the acceptance rate
#'
#' ## example3: random walk Metropolis-Hastings algorithm, sample from a
#' ## normal mixture 0.2*N(1,1)+0.8*N(-5,1), with symmetric proposal xhat ~ U(x-l,x+l),
#' ## compare different values of l.
#'
#' ## step1: define p() and q()
#' dp <- function(x) log(dnorm(x,1,1)*0.2+dnorm(x,-5,1)*0.8)
#' ## a symmetric proposal has no influence to the acceptance rate, so a constant function
#' ## would suffice.
#' dq <- function(xnew,x) 1
#' rq1 <- function(x) runif(1,x-0.01,x+0.01)
#' rq2 <- function(x) runif(1,x-2,x+2)
#' ## step2: get 5000 samples
#' X1 <- MetropolisHastings(nsamples = 5000,xini = rnorm(1),dp=dp,dq=dq,rq=rq1)
#' X2 <- MetropolisHastings(nsamples = 50000,xini = rnorm(1),dp=dp,dq=dq,rq=rq2)
#' ## step3: plot the result, calculate acceptance rate
#' sum(diff(X1)!=0)/nrow(X1)
#' sum(diff(X2)!=0)/nrow(X2)
#' ## plot the results
#' hist(X1,xlim = c(-10,5))
#' hist(X2,xlim = c(-10,5))
#' hist(c(rnorm(1000,1,1),rnorm(4000,-5,1)),xlim = c(-10,5))
#'
#' ## note that X1 has a higher acceptance rate comparing to X2, though it performs poorer.
#' ## So we use Kolmogorov-Smirnov to test the real performance of X1 and X2:
#' ks.test(jitter(X1),c(rnorm(1000,1,1),rnorm(4000,-5,1))) #ks.test() assumes continuous
#' ## samples doesn't contain equal values, otherwise there will be a warning.so use jitter() to
#' ## remove the equals
#' ks.test(jitter(X2),c(rnorm(1000,1,1),rnorm(4000,-5,1)))
#' ## it turns out that even though X2 looks better from the histogram, it still doesn't
#' ## pass the KS test.
#'
#' ## example4: hybrid Metropolis-Hastings algorithm, questions same as previous example,
#' ## but use a mixutre proposal instead.
#'
#' ## we use mixture proposal to capture both the local and global areas of the target distribution
#' ## step1: define p() and q()
#' dp <- function(x) log(dnorm(x,1,1)*0.2+dnorm(x,-5,1)*0.8)
#' ## a symmetric proposal has no influence to the acceptance rate,
#' ## so a constant function would suffice.
#' dq <- function(xnew,x) 1
#' ##70% local, 30% global
#' rq <- function(x) if(runif(1)<0.7) runif(1,x-0.1,x+0.1) else runif(1,x-3,x+3)
#' ## step2: get 5000 samples
#' X <- MetropolisHastings(nsamples = 5000,xini = rnorm(1),dp=dp,dq=dq,rq=rq)
#' ## step3: plot the result, calculate acceptance rate
#' sum(diff(X)!=0)/nrow(X)
#' ## plot the results
#' hist(X,xlim = c(-10,5))
#' hist(c(rnorm(1000,1,1),rnorm(4000,-5,1)),xlim = c(-10,5))
#'
#' ## perform the KS test again, this time it says there's no significance difference between the MH
#' ## and the real samples. ks.test() assumes continuous samples doesn't contain equal values,
#' ## otherwise there will be a warning.so use jitter() to remove the equals
#' ks.test(jitter(X),c(rnorm(1000,1,1),rnorm(4000,-5,1)))
#' }
MetropolisHastings <- function(nsamples,xini,dp,dq,rq){
    if(is.vector(xini)) xini <- matrix(xini,nrow = 1L)
    else if(!is.matrix(xini)) stop("xini must be a numeric vector or a numeric matrix of only one row")
    if(!is.integer(nsamples)) nsamples <- as.integer(nsamples)
    if(nsamples<0L) stop("Error in MetropolisHastings(): nsamples must be greater than 0!")
    out <- matrix(0,nrow = nsamples+1L,ncol = length(xini))
    out[1L,] <- xini
    if(!is.function(dp) | !is.function(dq) | !is.function(rq)) stop("dp, dq and rq must be functions!")
    xnew <- numeric(ncol(out))          #initialize place holder
    x <- xnew                           #initialize place holder
    for(i in 2L:(nsamples+1L)){
        x <- out[i-1L,]
        xnew <- rq(x)
        if(runif(1) < exp(dp(xnew) - dp(x)-
                          dq(x,xnew) + dq(xnew,x))){
            out[i,] <- xnew
        }else{
            out[i,] <- out[i-1L,]
        }
    }
    out[-1,,drop=FALSE]
}


#' @title calcFroudeNum
#'
#' @description Calculate the Froude number (\code{froudeNum}) (dimensionless).
#'
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#'   \code{\link{calcSpeedUnitConversion}})
#' @param lwl Waterline length (vector of numericals, m) (see
#'   \code{\link{calclwl}})
#'
#' @details
#' The Froude number is a dimensionless coefficient that relates a vessel's speed
#' and length to a relative resistance. The equation for the Froude number is:
#' \deqn{Fn=\frac{V}{\sqrt{g*Lwl}}}{Fn=V/sqrt(g*lwl)}
#' Where V is the ship's speed, g is the gravitational constant (9.81 m/s^2),
#' and \code{lwl} is the waterline length (m) of the vessel.
#'
#' @return \code{froudeNum} (vector of numericals, dimensionless)
#'
#' @references
#' \href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#' @seealso \itemize{
#' \item \code{\link{calcSpeedUnitConversion}}
#' \item \code{\link{calclwl}}
#' }
#'
#' @examples
#' calcFroudeNum(seq(1,5,1),214)
#'
#' @export

calcFroudeNum <- function(shipSpeed, lwl){

  froudeNum<-(shipSpeed)/((9.81*lwl)^0.5)

  return(froudeNum)
}


#Kruskal-Wallis Test

#Decimos que 2 muestras son independientes
#si provienen de poblaciones no relacionadas
#

#Con Kruskal podemoss decidir si las poblaciones son
#identicas sin asumir la normalidad de las distribuciones

'''
In the built-in data set named airquality,
the daily air quality measurements in New York,
May to September 1973, are recorded. The
ozone density are presented in the data frame
column Ozone.'''

head(airquality)

'''
The null hypothesis is that the monthly ozone
density are identical populations. To test
the hypothesis, we apply the kruskal.test
function to compare the independent monthly
data. The p-value turns out to be nearly
zero (6.901e-06). Hence we reject the
null hypothesis.
'''

kruskal.test(Ozone ~ Month, data = airquality)

'''
Kruskal-Wallis rank sum test

data:  Ozone by Month
Kruskal-Wallis chi-squared = 29.267, df =
4, p-value = 6.901e-06

Como el p-value es menor a la significancia, podemos decir que
rechazamos la hipotesis y decidir que que son no identicas
'''

Parcial/5. Metodos no parametricos/Kruskal.r


#function to calculate pi by comparing the area of the unit
#circle to that of the unit sphere (should be pi/4)
# inputs:
#   n.pts    = number of points to test
#
mcpi <- function(n.pts) {
  #generate n.pts (x,y) points in the unit square
  m = matrix(runif(2*n.pts),n.pts,2)
  #determine if they are in the unit circle
  in.ucir <- function(x) { as.integer((x[1]^2 + x[2]^2) <= 1) }
  in.cir = apply(m, 1, in.ucir )
  #return the proportion of points in the unit circle * 4
  return (4*sum(in.cir)/n.pts)
}


y <- c(41, 39, 47, 51, 43, 40, 57, 46, 50, 59, 61, 52)
x<- c( 24 ,30 ,33 ,35 ,36 ,36 ,37 ,37 ,38 ,40 ,43 ,49)

# Apply the lm() function.
relation <- lm(y~x)

print(summary(relation))
cor(y,x)
# For all 12 observations, the output shows a correlation coefficient of .646
# after subseting x>=37

y1 <- c(  57, 46, 50, 59, 61, 52)
x1<- c(  37 ,37 ,38 ,40 ,43 ,49)
# Apply the lm() function.
relation <- lm(y1~x1)
print(summary(relation))
 cor(y1,x1)
# For  subset having x greater than or equal to 37, the output shows a correlation coefficient of .188


#pontos
x1 = c(0,1,2,3)
y1 = c(2,-2,2,0)
plot (x1,y1,"b", main="Pontos")

#lagrange
t = seq(1,4,0.01)

#f = (y1[1]*(t-x1[2])*(t-x1[3])*(t-x1[4]))/((x1[1]-x1[2])*(x1[1]-x1[3])*(x1[1]-x1[4])) + (y1[2]*(t-x1[1])*(t-x1[3])*(t-x1[4]))/((x1[2]-x1[1])*(x1[2]-x1[3])*(x1[2]-x1[4])) + (y1[3]*(t-x1[1])*(t-x1[2])*(t-x1[4]))/((x1[3]-x1[2])*(x1[3]-x1[1])*(x1[3]-x1[4])) + (y1[4]*(t-x1[1])*(t-x1[2])*(t-x1[3]))/((x1[4]-x1[2])*(x1[4]-x1[3])*(x1[4]-x1[1]))

w1 = ((t-2)*(t-3)*(t-4))/((1-2)*(1-3)*(1-4))
w2 = ((t-1)*(t-3)*(t-4))/((2-1)*(2-3)*(2-4))
w3 = ((t-1)*(t-2)*(t-4))/((3-1)*(3-2)*(3-4))
w4 = ((t-1)*(t-2)*(t-3))/((4-1)*(4-2)*(4-3))

xx = x1[1]*w1 + x1[2]*w2 + x1[3]*w3 + x1[4]*w4
yy = y1[1]*w1 + y1[2]*w2 + y1[3]*w3 + y1[4]*w4

plot(xx, yy, "l",main="Lagrange")

plot(x1,y1, "b", c(0,3), c(-3,3),col="blue",main="Lagrange+Pontos")
lines(xx, yy, "l", col="red")

#pesos
plot(t,w1, type="l", xlim=c(1,4), ylim=c(-0.5,1.2), col="orange", main="Pesos")
lines(t,w2, "l", col="red")
lines(t,w3, "l", col="cyan")
lines(t,w4, "l", col="green")


library(tidyverse)
library(stringr)
library(purrr)
library(lubridate)
library(readr)

setwd("C:/Users/Ghozy Haqqoni/Documents/!Kuliah/Semester 5 - DS/Time Series/datas/")

####Removing trends in variability via the logarithmic transformation####
# Log rapid_growth
ts.plot(rapid_growth)
linear_growth <- log(rapid_growth)
# Plot linear_growth using ts.plot()
ts.plot(linear_growth)
####

####Removing trends in level by differencing####
# Generate the first difference of z
dz <- diff(z)
# Plot dz
ts.plot(dz)
# View the length of z and dz, respectively
length(z)
length(dz)
####

####Removing seasonal trends with seasonal differencing####
# Generate a diff of x with lag = 4. Save this to dx
dx <- diff(x, lag = 4)
# Plot dx
ts.plot(dx)
# View the length of x and dx, respectively
length(x)
length(dx)
####

####Simulate the white noise model####
# Simulate a WN model with list(order = c(0, 0, 0))
#ARIMA(0,0,0)
white_noise <- arima.sim(model = list(order = c(0, 0, 0)), n = 100) #produce 100obs
# Plot your white_noise data
ts.plot(white_noise)
# Simulate from the WN model with: mean = 100, sd = 10
white_noise_2 <- arima.sim(model = list(order = c(0, 0, 0)), n = 100, mean = 100, sd = 10)
# Plot your white_noise_2 data
ts.plot(white_noise_2)
####

####Estimate the white noise model####
# Fit the WN model to y using the arima command
arima(y, order = c(0,0,0))
# Calculate the sample mean and sample variance of y
mean(y)
var(y)
####

####Simulate the random walk model####
# Generate a RW model using arima.sim
random_walk <- arima.sim(model = list(order = c(0, 1, 0)), n = 100)
# Plot random_walk
ts.plot(random_walk)
# Calculate the first difference series
random_walk_diff <- diff(random_walk)
# Plot random_walk_diff
ts.plot(random_walk_diff)
####

####Simulate the random walk model with a drift####
# Generate a RW model with a drift uing arima.sim
#mean=1 to produce a drift
rw_drift <- arima.sim(model = list(order = c(0,1,0)), n =100, mean = 1)
# Plot rw_drift
ts.plot(rw_drift)
# Calculate the first difference series
rw_drift_diff <- diff(rw_drift)
# Plot rw_drift_diff
ts.plot(rw_drift)
####

####Estimate the random walk model####
# Difference your random_walk data
rw_diff <- diff(random_walk)
# Plot rw_diff
ts.plot(rw_diff)
# Now fit the WN model to the differenced data
model_wn <- arima(rw_diff, order = c(0,0,0))
# Store the value of the estimated time trend (intercept)
int_wn <- model_wn$coef
# Plot the original random_walk data
ts.plot(random_walk)
# Use abline(0, ...) to add time trend to the figure
abline(0, int_wn)
####

####Are the white noise model or the random walk model stationary?####
# Use arima.sim() to generate WN data
white_noise <- arima.sim(model = list(order = c(0,0,0)), n=100)
# Use cumsum() to convert your WN data to RW
random_walk <- cumsum(white_noise)
# Use arima.sim() to generate WN drift data
wn_drift <- arima.sim(model = list(order = c(0,0,0)), n=100, mean=0.4)
# Use cumsum() to convert your WN drift data to RW
rw_drift <-  cumsum(wn_drift)
# Plot all four data objects
plot.ts(cbind(white_noise, random_walk, wn_drift, rw_drift))
####


# Example : 7.3A   Chapter : 7.3     Page No: 405
# leftinverse,rightinverse,Pseduoinverse of given matrices
A1<-matrix(c(2,2),ncol=1)
A2<-matrix(c(2,2),ncol=2)
A3<-matrix(c(2,2,2,2),ncol=2)
A1T<-t(A1)
A2T<-t(A2)
A1inv<-solve(A1T%*%A1)%*%A1T
print("Left inverse of A1")
print(A1inv)
print(A1inv%*%A1)
A2inv<-A2T%*%solve(A2%*%A2T)
print("right inverse of A2")
print(A2inv)
print(A2%*%A2inv)

#The answers given in the text book is wrong it is 1/8 ..  not 1/sqrt(8)
V1<-svd(A3)$v
U1T<-t(svd(A3)$u)
d<-svd(A3)$d
sigma1<-matrix(c(1/d[1],0,0,0),ncol=2)
A3inv<-2*(V1%*%sigma1%*%U1T)
print("The Pseduo inverse of the given matrix")
print(A3inv)


# 5.1
# Let q = 5. Draw θj
# from the uniform distribution on [−2, 2] for j = 1, . . . , q.
# Let σ^2_z= [1 + sum(θ^2_j)]^-1 and
# {Zt} dist WN(0, σ2Z) and define the MA(q) process:
# a) Calculate and plot the autocovariance function defined by {(θj, j = 1, . . . , q), σ2Z} .

set.seed(1234)
q = 5
#draw U[-2,2] q times
theta = runif(n=q, min = -2, max = 2);theta
## [1]  -1.5451864  0.4891976  0.4370989  0.4935178  1.4436615
sigma = sqrt( 1/(1+sum(theta^2)) );sigma
## [1] 0.4033803

# Auto-covariance function for MA(q)
# %*% is matrix multiplication and sum
gammaX = function(h, theta, sigma) {
    h = abs(h)
    if ( h > length(theta)) return(0)
	theta_k = c(1,theta)
    theta_kh = c(theta_k[(h+1):length(theta_k)], rep(0,h ))
    g = sigma^2 * sum(theta_k * theta_kh ) #The formula for ACVF of MA(q)
    return (g)
}

h = 0:10
'''
sapply(X, FUN)
Arguments:
-X: A vector or an object
-FUN: Function applied to each element of x
'''
gam = sapply(h, gammaX, theta=theta, sigma=sigma)
print(gam)
plot(h, gam, type="h", col=4)

#aacvf
library("itsmr")
a = specify(ar=c(0),ma=theta, sigma2=sigma^2)
gamma.itsmr = aacvf(a,10)

plot(h, gamma.itsmr, type="h")
gamma.itsmr

# b) Make an R program for IA and find (θ∞, ν∞) = {(θ∞j, j = 1, . . . , q), ν∞}
N = 100
q = 5
IA = function(N, gamma.vec){
	#I) Initialisation page 30
	v = numeric(N) #initialize nu
	gamma = c(gamma.vec[1:(q+1)], rep(0,N)) #initialize
	Theta = matrix(0, ncol=N, nrow=N) #initialize
	v[1] = gamma[1] #gamma0
	Theta[1,1] <- gamma[2]/v[1] #theta1,1=gamma(1)/nu0
	v[2] = (1-Theta[1,1]^2)*v[1] #nu1 = (1-theta1,1^2)nu0

	#II) Start up part, for n=2,..,q
	for(n in 2:q) {
		Theta[n,n] = gamma[n+1]/v[1] #theta(n,n) = gamma(n)/nu0
		for (k in 1:(n-1)) {
			Theta[n,n-k] = (gamma[n+1-k]-sum(Theta[k, k:1]*Theta[n, n:(n+1-k)]*v[1:k]))/v[k+1]
		}
		v[n+1] = gamma[1] - sum( Theta[n,n:1]^2*v[1:n] ) #nu(n)
	}

	#III) Steady state part; for n>=q+1, formula on IA slide page 31
	for(n in (q+1):N) {
		Theta[n,q] = gamma[q+1]/v[n+1-q] #Theta(n,q)=gamma(q)/nu(n-q)
		for(k in 1:q-1){
			Theta[n,q-k] = (gamma[q+1-k] - sum(Theta[n-q+k,k:1]*Theta[n,q:(q-k+1)]*v[(n-q):(n-q+k-1)]))/v[n-q+k]
		}
		v[n+1] = gamma[1] - sum(Theta[n,n:1]*Theta[n,n:1]*v[1:n]) #nu(n)
	}
	return(list(theta=Theta, nu=v))
}

ia = IA(N, gam)
theta.inf = ia$theta[N, 1:q];theta.inf
#[1] -0.1114082  0.2216191 -0.0309017 -0.3244026  0.3339867
nu.inf = ia$nu[N];nu.inf
#[1] 0.7816983

# c) Calculate and plot the autocovariance function defined by the parameters from b).
#    Compare with a).

gamma.ia = sapply(h, FUN=gammaX, theta=theta.inf, sigma=sqrt(nu.inf));gamma.ia
sum(gamma.ia-gam)
#[1] 0.0261705 difference is less than 0.03
# smal difference in last term
plot(h, gamma.ia, type="h", col="blue", ylab = "ACVF") #from b)
lines(h+0.01, gam, type="h", col="red") #from a)

#d) If the two parameter sets are different then at most one of them
# gives an invertible model. Which of them does that with probability one?

theta = runif(n=q, min = -2, max = 2);theta
Mod(polyroot(c(1,theta)))
#[1]  0.7795998  0.8878476  0.8878476  2.2131556 12.8982231 - non-invertible
Mod(polyroot(c(1,theta.inf)))
# [1] 1.438013 1.200501 1.438013 1.098225 1.098225 - invertible
#IA found the invertible model

# 5.2
# a)  For N = 1000,
#     generate {Xt, t = 1, . . . , N} according to (5.1)MA(q)

q = 5
set.seed(1234)
theta = runif(q, -2, 2);theta
sigma2z = 1/(1+sum(theta^2));sigma2z

#(5.1) \ X_t = \sum_{j=0}^{q}\theta_j Z_{t-j}, \ \theta_0=1

N = 1000
sigmaz = sqrt(sigma2z)
#rlaplace -> lib(extraDistr)
library(extraDistr)
set.seed(1234)
Zt = rlaplace(n=N, mu=0, sigma=sigmaz/sqrt(2))
Xt = arima.sim(list(ma=theta), n=N, innov = Zt)
head(Xt)

#b) Calculate and plot the empirical autocovariance function
acf(Xt, type="covariance")

#c) Find {theta_inf,j | j = 1..q, v_inf} from the IA with input
# {gamma(h) | h = 0..q} If the algortihm does not converge,
# increase q to q' and use gamma(h) ;h = 0..q' as input
emp.gamma = as.vector(acf(Xt, type="covariance", plot=FALSE)$acf)
length(emp.gamma)
ia2 = IA(N, emp.gamma)
theta.inf2 = ia2$theta[N, 1:5];theta.inf2
nu.inf2 = ia2$nu[N];nu.inf2

# d) Compute and plot the autocovariance function defined the
# parameters from the IA given in c). Compare with b)
gamma.acvf <- sapply(h, FUN=gammaX, theta=theta.inf2, sigma=sqrt(nu.inf2))
acf(Xt, type="covariance", lag.max = 15)
lines(h+0.08, gamma.acvf, type="h", col="green")
gamma.acvf
# [1]  1.00313296 -0.14888739  0.09920841  0.06194804 -0.24862657  0.23970684  0.00000000  0.00000000  0.00000000  0.00000000  0.00000000
emp.gamma[1:(q+1)]
#[1]  1.00313296 -0.14888739  0.09920841  0.06194804 -0.24862657  0.22084301

# gamma.ia2 which is ACVF and  emp.gamma which is empirical ACVF
# is the same expect last term. ACVF sligtly larger than empirical ACVF

# e)
'''
The estimators theta_hat, sigma_hat from IA - satisfy the equation because, we see from the plot
that the emprical ACVF is approximately equal to the theoretical ACVF (mentioned in 5.1 a)

What do you call these estimators?
Moment estimators.

How can you do this without using IA?
Could have used Newton-Rhapson/newton method - root finding algorithm
'''

# 5.4 An AR(6) model
# Do basic descriptive statistics and estimation for the there cases.
# Present plots and for the estimation use both Yule Walker, least square and maximum likelihood
phi = c(0.40, 0.36, -0.47, 0.45, 0.21, -0.03)
set.seed(1234)

Mod(polyroot(c(1,phi)))

N1=100
Xt.1 = arima.sim(list(ar=phi), n=N1, innov = rnorm(N1) )
N2=1000
Xt.2 = arima.sim(list(ar=phi), n=N2, innov = rnorm(N2) )
N3=100000
Xt.3 = arima.sim(list(ar=phi), n=N3, innov = rnorm(N3) )

#descriptive statistics
summary(Xt.1);var(Xt.1)
summary(Xt.2);var(Xt.2)
summary(Xt.3);var(Xt.3)
par(mfrow=c(3,1))
plot(1:N1, Xt.1, type="l")
plot(1:N2, Xt.2, type="l")
plot(1:N3, Xt.3, type="l")
par(mfrow=c(3,1))
acf(Xt.1, type="covariance")
acf(Xt.2, type="covariance")
acf(Xt.3, type="covariance")

ar_order=6

# AR: c(0.40, 0.36, -0.47, 0.45, 0.21, -0.03)
ar.ols(x = Xt.1, aic = FALSE, order.max = 6)
ar(Xt.1, order=ar_order, method="yw")
ar(Xt.1, order=ar_order, method="mle")
ar(Xt.1, order=ar_order, method="burg")
'''
ols: 0.4659   0.2360  -0.4993   0.4478   0.1301   0.0372
yw:	 0.4595   0.1501  -0.4686   0.4738
mle: 0.5231   0.1386  -0.4991   0.5357
burg:0.5001   0.1534  -0.5121   0.5110
'''

ar.ols(x = Xt.2, aic = FALSE, order.max = ar_order)
ar(Xt.2, order=ar_order, method="yw")
ar(Xt.2, order=ar_order, method="mle")
ar(Xt.2, order=ar_order, method="burg")
'''
ols: 0.3880   0.4106  -0.4998   0.4686   0.2161  -0.1100
yw:	 0.3855   0.4031  -0.4921   0.4684   0.2103  -0.1042
mle: 0.3855   0.4031  -0.4921   0.4684   0.2103  -0.1042
burg:0.3868   0.4068  -0.4984   0.4713   0.2156  -0.1102
'''

ar.ols(x = Xt.3, aic = FALSE, order.max = ar_order)
ar(Xt.3, order=ar_order, method="yw")
ar(Xt.3, order=ar_order, method="mle")
ar(Xt.3, order=ar_order, method="burg")
'''
ols: 0.3989   0.3646  -0.4747   0.4507   0.2132  -0.0366
yw:	 0.3989   0.3646  -0.4746   0.4507   0.2131  -0.0366
mle: 0.3988   0.3646  -0.4747   0.4506   0.2132  -0.0366
burg:0.3988   0.3646  -0.4747   0.4506   0.2132  -0.0366

phi = c(0.40, 0.36, -0.47, 0.45, 0.21, -0.03)
#Pretty close to ground truth when N is large
'''

#spectrum(Xt.1, ..., )
#method - specifying the method used to estimate the spectral density. Allowed methods are "pgram" (default), "ar"
par(mfrow = c(2,2))
spectrum(Xt.1 )  #method = c("pgram", "ar")
spectrum(Xt.1, spans = 3)
spectrum(Xt.1, spans = c(3,3))
spectrum(Xt.1, spans = c(3,5))

par(mfrow = c(2,2))
spectrum(Xt.2 )  #method = c("pgram", "ar")
spectrum(Xt.2, spans = 3)
spectrum(Xt.2, spans = c(3,3))
spectrum(Xt.2, spans = c(3,5))

par(mfrow = c(2,2))
spectrum(Xt.3 )  #method = c("pgram", "ar")
spectrum(Xt.3, spans = 3)
spectrum(Xt.3, spans = c(3,3))
spectrum(Xt.3, spans = c(3,5))

# acf, spectrum, spec.pgram, spectrum, arima, ar
# 1. Discuss which parameters that are significant for the different situations.
# 2. How mabny observations are need for this size of the model?
# 3. Comment a parametric versus a nonparametric estimate of the spectral density.
# 4. Can you see any connection between the data and the empirical ACF or the spectral density?
# 5. You have used 3 different estimation methods for the autoregressive parameter vector. Do they differ much?

#Answere:
# 5: OLS, YW, MLE are equal for large N and different for smal N
# 2: bservations need:
# coeftest is a generic function for performing z and (quasi-)t Wald tests of
# estimated coefficients. coefci computes the corresponding Wald confidence intervals.
library(lmtest)
order_ar=6
coeftest(arima(Xt.1, order=c(order_ar,0,0), method="ML"))
'''
z test of coefficients:

           Estimate Std. Error z value  Pr(>|z|)
ar1        0.450212   0.100279  4.4896 7.136e-06 ***
ar2        0.200640   0.110741  1.8118  0.070016 .
ar3       -0.507068   0.105346 -4.8134 1.484e-06 ***
ar4        0.459391   0.104804  4.3833 1.169e-05 ***
ar5        0.132699   0.115263  1.1513  0.249622
ar6        0.034579   0.107562  0.3215  0.747844
intercept -1.188528   0.417712 -2.8453  0.004437 **
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

'''

coeftest(arima(Xt.2, order=c(order_ar,0,0), method="ML"))
'''
z test of coefficients:

           Estimate Std. Error  z value  Pr(>|z|)
ar1        0.388763   0.031453  12.3602 < 2.2e-16 ***
ar2        0.405273   0.033031  12.2696 < 2.2e-16 ***
ar3       -0.499476   0.032276 -15.4750 < 2.2e-16 ***
ar4        0.471797   0.032224  14.6411 < 2.2e-16 ***
ar5        0.215453   0.033085   6.5122 7.405e-11 ***
ar6       -0.110041   0.031498  -3.4936 0.0004765 ***
intercept  0.213069   0.245183   0.8690 0.3848372
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
'''

# 2: n=1000 is needed for low p value of phi. N=1000. All phi_i significant.

# 3: parametric versus a nonparametric
# non-parametric: periodogram, parametric: AR estimation
# er to metoder i spectrum, en parametrisk og en ikke.

#From wiki:
#https://en.wikipedia.org/wiki/Spectral_density_estimation?fbclid=IwAR1azWt2zz6iM5O8gO5AaJpvHehBv28tM-dgPGbTGILagk5E5xX0zHy3kko #Techniques
# Below is a partial list of parametric techniques:
# - AR which assumes that the nth sample is correlated with the previous p samples.
spectrum(Xt.1, method="ar")

#Following is a partial list of non-parametric spectral density estimation techniques
# periodogram - the modulus-squared of the discrete Fourier transform
spectrum(Xt.1, method="pgram")

par(mfrow=c(3,2))
spectrum(Xt.1, method="pgram")
spectrum(Xt.2, method="pgram")
spectrum(Xt.3, method="pgram")
spectrum(Xt.1, method="ar")
spectrum(Xt.2, method="ar")
spectrum(Xt.3, method="ar")

# The spectrum function estimates the spectral density of a time series.

# spec.pgram calculates the periodogram using a fast Fourier transform,
# and optionally smooths the result with a series of modified
# Daniell smoothers (moving averages giving half weight to the end values)

# So spectrum( X, method="pgram") === spec.pgram(X)

# 4: empirical ACF or the spectral density:
#The relation between the autocovariance (or autocorrelation)
#and the spectral density (for which the periodogram is an estimator)
#is given by the Fourier transform. The two form a
#so-called Fourier-transform pair meaning the two are
#time(or space)-domain vs. frequency-domain representations of the
#same thing
par(mfrow=c(3,1))
spectrum(Xt.3, method="pgram")
acf(Xt.3, type="covariance")
plot(1:N3, Xt.3, type="l")

# 5.5
# Xt be a stationary and linear causal time series with white noise process Zt in WN(0,sig^2)
# Find empi(Z_n+1) = P_n (Z_n+1) where P_n is linear prediction based on X_1,..,X_n
# Let X_t= theta(B)Z_t with q finitie - non-invertible - and find empi(Z_n+1)

#a) Let p = 10 and draw a sample of size p from the standard uniform distribution on
#[-1; 1]. Define theta = choose(n,k)*U
#Let sigma2 = 1 and Zt be iid Gaussian white noise with variance sigma2
set.seed(1234)
p = 10
U = runif(p, -0.001,0.001)

phi_est = numeric(p)
#definition of a causal AR(p) process
for (j in 1:p){
	#choose - binomial coefficient: n choose k
	phi_est[j] = choose(p,j)*U[j]
}
arima.sim( list( ar = phi_est ), n = NN, innov = rnorm(NN) )
phi_est
sigma2_emp = 1
Zt = rnorm(1, 0, sigma2_emp)

# b) Calulate the spectral density
spectral_density = function(omega, phi_est, sigma2_emp){
  w = complex(real = cos(omega) , imaginary = sin(omega)) #z= exp(i*omega) by euler
  w_bar = Conj(z) #z_bar= exp(-i*omega) by euler
  z_i = polyroot(c(1, (-1)*phi_est))
  w_vektor = rep(z, p)^(1:p)
  w_vektor_bar = rep(w_bar, p)^(1:p)
  is_ar = -1
  z = c(1, is_ar*phi_est*w_vektor)
  z_bar = c(1, is_ar*phi_est*w_vektor_bar)
  return ( sigma2_emp/((2*pi)*(z*z_bar)) )
}

omega = pi/4 # r=sqrt(2) then r*exp(i*omega) = 1+i
spd = spectral_density(omega, phi_est, sigma2_emp)

NN=100000
empirical = arima.sim(list( ar = phi_est), n=NN, innov = rnorm(NN) )
spectrum(empirical, method="pgram")
par(mfrow=c(2,1))
plot(spd)

# c) Find the roots, and plot them
library(plotrix)
z_i = polyroot(c(1,-phi_est))
plot(z_i, type="p", pch = 17)
draw.circle(0, 0, radius=1)

# d) Exchange all roots that are inside the unit circle by their corresponding inverses.

#find non-causal AR roots /or non-invertible MA q roots
non_causal = function(z_i) {
  causal_roots = numeric(length(z_i))
  for ( i in 1:length(z_i) ) {
    if ( Mod( z_i[i] ) <= 1) {causal_roots[i] = 1/z_i[i]
    } else {causal_roots[i] = z_i[i]}
  }
  return (causal_roots)
}

#e) Check that all the roots are located outside the unit disk You may use R to plot them
causal = non_causal(c(1,-phi_est))
plot(causal, type="p", pch = 17, xlim=c(-5,15), ylim=c(-5,max(Mod(causal)+1)) )
draw.circle(0, 0, radius=1)

# f) Calculate and plot the spectral density
spectral_density = function(omega, phi_est, sigma2_emp){
  w = complex(real = cos(omega) , imaginary = sin(omega)) #z= exp(i*omega) by euler
  w_bar = Conj(z) #z_bar= exp(-i*omega) by euler
  z_i = polyroot(c(1, (-1)*phi_est))
  z_i = non_causal(z_i)
  w_vektor = rep(z, p)^(1:p)
  w_vektor_bar = rep(w_bar, p)^(1:p)
  is_ar = -1
  z = c(1, is_ar*phi_est*w_vektor)
  z_bar = c(1, is_ar*phi_est*w_vektor_bar)
  return ( sigma2_emp/((2*pi)*(z*z_bar)) )
}

# 5.7
# Write an R-program that calculates the phis given the roots of the
# characteristic polynomialof an AR(p) model.
# Apply your program to the situation in the previous problem.
library(utils)
#Last term has sign (-1)^(p+1)
getPhiFromCausalRoots = function( z_i ) {
	p = length(z_i)
	if ( p == 1 ) {return (1/z_i)}
	phi = numeric( p )
	phi[1] = sum(1/z_i)
	for( i in 2:(p-1) ) {
		#sum the product of all i-tuples. Tuples in column-space => Margin=2
		phi[i] = (-1)^(i-1) * sum(apply(combn(1/z_i, i), MARGIN=2, FUN=prod) )
	}
	return (phi)
}

causal_phi = Re( getPhiFromCausalRoots( causal ) )

# 5.8
# Simulate with N = 1000 the model
N=1000
polyroot(causal_phi)

Xt = arima.sim( list( ar = causal_phi ), n = N, innov = rnorm(NN) )


### X1, ..., Xn ~ exponencial(lambda)
## Estimadores
delta <- function(samp) samp[1]
delta0 <- function(samp){ ## estimador melhorado por Rao-Blackwell
  s <- sum(samp)
  x1 <- samp[1]
  n <- length(samp)
  # est <- (n-1)/s * (1 - x1/s)^(n-2)
  est <- exp( ## versão numericamente estável
    log(n-1)-log(s) + (n-2)*log1p(- x1/s)
  )
  return(est)
}

## Simulando dados
Nsim <- 1000
N <- 500
lambda <- 3

amostras <- matrix(rexp(n = Nsim*N, rate = lambda),
                   ncol = N, nrow = Nsim)

### Aplicando os estimadores

Ds <- apply(amostras, 1, delta)
D0s <- apply(amostras, 1, delta0)

par(mfrow = c(1, 2))
hist(Ds, probability = TRUE,
     xlab = expression(delta))
abline(v = lambda, lwd = 2, lty = 2)

hist(D0s, probability = TRUE,
     xlab = expression(delta[0]))
abline(v = lambda, lwd = 2, lty = 2)

## EQM

mean((Ds-lambda)^2)
mean((D0s-lambda)^2)

mean(Ds)
mean(D0s)

var(Ds)
var(D0s)


library(MASS)
library(ISLR)

#fix(Boston)
names(Boston)

lm.fit=lm(medv ~ lstat, data = Boston)
lm.fit
summary(lm.fit)
coef(lm.fit)
confint(lm.fit)

#the expected mean and its 95% interval
predict(lm.fit, data.frame(lstat=c(5,10,15)), interval = "confidence")
#the expected value and its 95% interval
#this is necessarily wider because the mean is necessarily smaller then
#the biggest and bigger than the smallest possible values
predict(lm.fit,data.frame(lstat=c(5,10,15)), interval = "prediction")

plot(Boston$lstat,Boston$medv)
abline(lm.fit)

par(mfrow=c(2,2))
plot(lm.fit)

plot(predict(lm.fit), residuals (lm.fit))
plot(predict(lm.fit), rstudent (lm.fit))

plot(hatvalues (lm.fit))
which.max(hatvalues (lm.fit))

lm.fit=lm(medv ~lstat+age ,data=Boston)
summary(lm.fit)

lm.fit=lm(medv ~.,data=Boston)
summary(lm.fit)

library(car)
vif(lm.fit)

summary(lm(medv ~ lstat*age,data=Boston))

lm.fit2=lm(medv ~ lstat+I(lstat^2), data = Boston)
summary(lm.fit2)

lm.fit=lm(medv~lstat, data = Boston)

#The null hypothesis is that the two models
#fit the data equally well;
#and the alternative hypothesis is that the full
#model is superior.
#Here the F-statistic is 135 and the associated p-value is
#virtually zero. This provides very clear evidence
#that the model containing
#the predictors lstat and lstat 2 is far superior
#to the model that only
#contains the predictor lstat .
anova(lm.fit ,lm.fit2)

par(mfrow=c(2,2))
plot(lm.fit2)

lm.fit5=lm(medv ~ poly(lstat ,5), data = Boston)
summary(lm.fit5)


#The Rejection Sampling method is usually used to simulate data from an unknown distribution. To do this
#one samples from a distribution that covers the suport of the unknown distribution and use certain
#criteria for accepting/rejecting the sampled values. One way to do this is as follows (Rice, p 92).

# Step 1: Generate T with density m.

# Step 2: Generate U, uniform on [0,1] and independent of T. If M(T)*U ??? f(T), then let X = T (accept T).
#Otherwise, go to Step 1 (Reject T).

#Where M(x) is a function such that M(x) ??? f(x) on [a,b].

#To keep things simple for myself I will be simulating a Beta distribution with
#parameters 6 and 3 (f). To do this I will sample T's from a scaled uniform distribution (M),
#and reject sampled values where M(T)*U ??? f(T).

#In a plot of the beta distribution with parameters 6 and 3 we can see that the f(x) never goes above 3.
#For this reason I chose to scale the uniform distribution M by multiplying it by 3.
#Here is the R code to implement rejection sampling for 100,000 observations in this example

library(combinat) # combinatorics utilities
library(datasets) # The R Datasets Package
library(base)
library(stats)
library(graphics)
library(nmle)
library(lattice)
library(mcsm)
library(ggplot2)
library(reshape2)

x = seq(0, 1, by = 0.001)

y1 = pcauchy(x, 0, 1)
y2 = pnorm(x, 0, 1)
df <- data.frame(x, y1, y2)

g <- ggplot(df, aes(x))
g <- g + geom_line(aes(y = y1), colour = "red")
g <- g + geom_line(aes(y = y2), colour = "green")
g

sample.x = rcauchy(100000, 0, 1)
sample.x <- subset(sample.x, sample.x > -3 & sample.x < 3)
accept = c()

for(i in 1:length(sample.x)){
  U = runif(1, 0, 1)
  if(dcauchy(sample.x[i], 0, 1) * ((sqrt(2 * pi) * (exp(1)) ^ (-0.5))) * U <= dnorm(sample.x[i], 0, 1)) {
    accept[i] = 'Yes'
  }
  else
    accept[i] = 'No'
}

# ((sqrt(2 * pi) * (exp(1)) ^ (-0.5))) = 1.520347

t = data.frame(sample.x, accept = factor(accept, levels= c('Yes','No')))

summary(t)

hist(t[,1][t$accept == 'Yes'], breaks = seq(-3, 3, 0.01), freq = FALSE, main = 'Histogram of X', xlab = 'X')
points(sample.x, dnorm(sample.x, 0, 1), col = "red")

#With 100,000 observations sampled, the data fits very well.
#We can look at the densities of both the accepted and rejected values to get an idea of what's going on.

qplot(sample.x, data = t, geom = 'density', color = accept)
par(new = TRUE)
# qplot(x, db, geom = "line")

norm <- pnorm(sample.x)
simulated <- t
df <- data.frame(x = sample.x, norm, simulated)

# melt the data to a long format
df2 <- melt(data = df, id.vars = "x")

# plot, using the aesthetics argument 'colour'
# ggplot(data = df2, aes(x = x, y = value, colour = variable)) + geom_line()

df <- data.frame(x = rnorm(1000))
ggplot(df, aes(x)) + stat_density(kernel = "biweight")

x <- seq(-3, 3,length = 1000)
db <- dnorm(x, 0, 1)

qplot(x, db, geom = "line")

x <- seq(-3, 3, length = 100)
db <- 1.53 * dcauchy(x, 0, 1)

qplot(x, db, geom = "line")

ggplot() + geom_line(aes(x, db))

ggplot(data.frame(x = c(-2, 2)), aes(x)) + stat_function(fun = rnorm)
print(qplot(sample.x, data = T, geom = 'histogram', fill = accept, binwidth = 0.01))

#In fact, when I ran this example I got 33,114 accepted values and 66,886 rejected values.
#I probably could have chosen a better value than 3 to scale the uniform distribution, but ideally
#rejection sampling uses a known distribution that is only slightly different from the unknown
#distribution we're trying to estimate.


# Example : 4   Chapter : 7.3     Page No: 404
# Pseduoinverse of matrix
A<-matrix(c(2,1,2,1),ncol=2)
V<-svd(A)$v
UT<-t(svd(A)$u)
d<-svd(A)$d
sigma1<-matrix(c(1/d[1],0,0,0),ncol=2)
A1<-V%*%sigma1%*%UT
print("The Pseduo inverse of the given matrix")
print(A1)
#The  answer may slightly vary due to  rounding off values
#The answers provided in the text book may vary because of the computation method followed.


#######################################################
### Gamma distribution with Lambda = 8, Alpha = 0.5 ###
#######################################################

## Sample the samples
nSamples <- 10000
lambda = 8
alpha = 0.5
xVal <- rgamma(nSamples, shape=lambda, rate=alpha)

## Make a histogram
png("gamma_hist.png", height = 800, width = 600)
xHist <- hist(xVal, breaks=20)

## Calculate characteristics
xA1 <- mean(xVal) # mean
xM2 <- mean((xVal - xA1)^2) # biased sample variance
xS2 <- nSamples * xM2 / (nSamples - 1) # unbiased sample variance
xS22 <- var(xVal) # unbiased sample variance
xSigma2 <- sqrt(xS22)
xSigma <- sd(xVal) # standard deviation (sqrt(m2))
xSem <- xSigma / sqrt(nSamples) # error of mean
xMed <- median(xVal) # median
xMax <- max(xVal) # max value
xMin <- min(xVal) # min value
xQuant <- quantile(xVal) # quantiles
xIqr <- IQR(xVal) # interquartile range
xM3 <- mean((xVal - xA1)^3) # third central moment
xGamma1 <- xM3 / xSigma^3 # skewness
xM4 <- mean((xVal - xA1)^4) # forth central moment
xGamma2 <- xM4 / xSigma^4 # kurtosis

print(paste0('Mean: ', xA1))
print(paste0('Biased sample variance: ', xM2))
print(paste0('Unbiased sample variance: ', xS2))
print(paste0('Unbiased sample variance 2: ', xS22))
print(paste0('Standard deviation: ', xSigma))
print(paste0('Standard deviation 2: ', xSigma2))
print(paste0('Error of mean: ', xSem))
print(paste0('Median: ', xMed))
print(paste0('Max value: ', xMax))
print(paste0('Min value: ', xMin))
cat('Quantiles: ', xQuant, '\n')
print(paste0('Interquantile range: ', xIqr))
print(paste0('Skewness: ', xGamma1))
print(paste0('Kurtosis: ', xGamma2))


# Example : 1   Chapter : 6.1     Page No: 284
# Eigen values and eigen vectors
A<-matrix(c(0.8,0.2,0.3,0.7),ncol=2)
sol<-eigen(A)
lambda<-sol$values
x<-sol$vectors
print("The eigen values of the matrix are")
print(lambda)
print("The eigen vectors of the matrix in normalised form are")
print(x)
#to get eigen vectors in the textbook multiply normalised vectors by scalars
x[,1]<-x[,1]*(0.6/x[1,1])
x[,2]<-x[,2]*(1/x[1,2])
print("Eigen vectors with respect to the above eigen values respectively are")
print(x)
print(A%*%x)
#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


# Configuring the working directory. (for running in Repl.it don't configure a working directory)
setwd("C:/Users/Weatherlly/Desktop/Estatistica")
# Entering values from the stem and leaf diagram.
Milimetros <- c(0.50,1.50,2.50,3.60,5.30,5.30,5.30,5.80,5.80,6.10,6.40,6.40,6.40,6.40,6.40,6.40,6.60,7.40,7.60,7.60,8.10,8.10,8.10,8.40,8.40,8.40,8.40,8.60,8.60,9.10,9.10,9.40,9.70,9.90,10.2,10.4,10.7,10.7,10.7,10.9,11.2,11.2,11.2,11.4,11.4,11.4,11.9,12.2,12.2,12.2,12.4,12.4,13.2,14.0,14.2,22.9)
# Configuring the amplitures of the branches.
Milimetros2 <- (cut(Milimetros,breaks=c(0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,16.0,18.0,20.0,23.0)))
# Calculation of absolute and relative frequencies.
N <- length(Milimetros2); N     # Number of objects (number of data)
ni <- table(Milimetros2); ni 	  # Absolute frequencies
fi <- ni/N ; fi		      	      # Relative frequencies
Ni <- cumsum(ni); Ni	          # Cumulative absolute frequencies
Fi <- cumsum(fi); Fi	          # Cumulative relative frequencies
# Using the summary function to calculate the quartiles, mean, median, minimum and maximum.
summary(Milimetros)
# Calculating the variance
var(Milimetros)
# Calculating the standard deviation
sd(Milimetros)
# plotting the histogram
hist(Milimetros,c(0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,16.0,18.0,20.0,23.0))
# Plotting the Boxplot
boxplot(Milimetros)


dados.nuvens <- read.csv("cloud_seeding.csv")

## Y ~ lognormal(mu, sigma_sq)
## log(Y) ~ normal(mu, sigma_sq)
hist(dados.nuvens$Seeded)
hist(log(dados.nuvens$Seeded))

X <- log(dados.nuvens$Seeded)

mean(X)
var(X)
sum((X-mean(X))^2)/26
sum((X-mean(X))^2)/25

x_bar <- mean(X)
S2_bar <- sum((X-mean(X))^2)/26

sqrt(26)/5

### P1 = Pr(|U| < 1/5 * sqrt(n))
### = Pr(U < 1/5 * sqrt(n))
#### U  = n * (mu_h - mu)^2/sigma_sq
a <- 1/5
p1 <- function(n){
 pchisq(q = a * sqrt(n), df = 1)
}
### P2 = Pr(0.64n < V < 1.44 n)
#### Pr(V < 1.44n) - Pr(V < 0.64n)
p2 <- function(n){
  pchisq(q = 1.44*n, df = n-1)-
    pchisq(q = 0.64*n, df = n-1)
}

par(mfrow = c(1, 2))
curve(p1, 1, 20, xlab = "n", main = "P_1(n)")
curve(p2, 1, 20, xlab = "n", main = "P_2(n)")

p3 <- function(n) p1(n)*p2(n)
ns <- 1:1500
tabelinha <- data.frame(
  n = ns,
  prob  = p3(ns)
)

head(tabelinha)

head(subset(tabelinha, prob >= 0.99))


## Vectorized operations continued

# Now we will use what we have learned to perform actual calculations that would otherwise be hella complicated

# For example

# What is the sum of the following equation:
1 + 1/2^2 + 1/3^2 + ... 1/100^2

# This is similar to
$\pi^2/6$.

# Now we will define an object that holds the values 1 to 100
1 + 1/2^2 + 1/3^2 + ... + 1/100^2

# Remember you can use vectorization to obtain the series with 1/x^2
# Now you just sum these vectors

x <- seq(1, 100)  # For example, define an object with values 1 to 100 and compute the sum
sum(1/x^2) # Sum the equation


# 1. Eucldian Distance
x1 <- rnorm(30)
x2 <- rnorm(30)
euc_dist <- dist(rbind(x1, x2), method = "euclidian")
x1
x2
euc_dist

# 2. Cosine Similarity
library(lsa)
vec1 <- c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0)
vec2 <- c(0, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0, 0)
cosine_similarity <- cosine(vec1, vec2)
cosine_similarity

# 3. Jaccard Similarity
library(clusteval)
vec1 <- c(1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0)
vec2 <- c(0, 0, 1, 1, 1, 1, 1, 0, 1, 0, 0, 0)
jaccard_similarity <- cluster_similarity(vec1, vec2, similarity = "jaccard")
jaccard_similarity

# 4. Pearson Correlation
cor(mtcars, method = "pearson")


#########################################
#########   Question 2.1      ###########
#########################################
#### data input
library("alr3")
ht <- htwt$Ht
wt <- htwt$Wt

#### 2.1.1 draw a scatterplot of ht and wt
plot(ht, wt)
fit <- lm(wt~ht)
abline(fit, col="blue")

#### 2.1.2
xbar <- mean(ht)
ybar <- mean(wt)
sxx <- sum((ht-xbar)^2)
syy <- sum((wt-ybar)^2)
sxy <- sum((ht-xbar)*(wt-ybar))
c(xbar, ybar, sxx, syy, sxy)
## estimate the slope(b1) and intercept(b0)
b1 <- sxy/sxx
b0 <- ybar-b1*xbar
c(b0, b1)
abline(b0, b1, col="red")

#### 2.1.3 estimate RSS and theta
##
n <- length(ht)
rss <- syy - b1^2*sxx
theta <- rss/(n-2)
##
se.b1 <- sqrt(theta/sxx)
se.b0 <- sqrt(theta*(1/n+xbar^2/sxx))
cov.b0b1 <- -theta*xbar/sxx
c(theta, se.b0, se.b1, cov.b0b1)
## t-test
t1 <- b1/se.b1
t0 <- b0/se.b0
## p.t <- 2*(1-pt(c(t0, t1), 8))
c(t0, t1)

#### 2.1.4 do f-test
##
ssreg <- sxy^2/sxx
f <- ssreg/theta
p.f <- 1-pf(f, 1, 8)
c(ssreg, f, p.f)
## show f=sqr(t)
ts <- t1^2
c(f, ts)
##
anova(fit)

########################################
##########   Question 2.5    ###########
########################################
#####   2.5.1
head("wblake")
fish.len <- wblake$Length
fish.age <- wblake$Age
fit.wblake <- lm(fish.len~fish.age)
predict(fit.wblake, data.frame(fish.age=c(2, 4, 6)), interval="confidence",level=0.95)

#####	2.5.2
predict(fit.wblake, data.frame(fish.age=c(9)), interval="confidence",level=0.95)

#####	2.5.3
plot(fish.age, fish.len)
abline(fit.wblake, col="green")
lines(lowess(wblake), col="red")

########################################
##########		Question 2.13 	########
########################################
#####	2.13.1
cspd <- wm1$CSpd
rspd <- wm1$RSpd
plot(rspd, cspd)
fit.wm <- lm(cspd~rspd)
abline(fit.wm, col="red")

####	2.13.2
summary(fit.wm)

####	2.13.3
predict(fit.wm, data.frame(rspd=7.4285), interval="confidence", level=0.95)

####	2.13.5
se <- function(m, n, xstar){
	cspd <- wm1$CSpd
	rspd <- wm1$RSpd
	cspd.bar <- mean(cspd)
	rspd.bar <- mean(rspd)
	sxx <- sum((cspd-cspd.bar)^2)
	syy <- sum((rspd-rspd.bar)^2)
	sxy <- sum((cspd-cspd)*(rspd-rspd))
	rss <- syy-sxy^2/sxx
	theta <- rss/(n-2)
	var.m <- theta/m+theta*(1/n+(xstar-rspd.bar)^2/sxx)
	return (var.m)
}
se(62039, 1116, 7.4285)


##### Chapter 6: Regression Methods -------------------

#### Part 1: Linear Regression -------------------

## Understanding regression ----
## Example: Space Shuttle Launch Data ----
launch <- read.csv("challenger.csv")

# estimate beta manually
b <- cov(launch$temperature, launch$distress_ct) / var(launch$temperature)
b

# estimate alpha manually
a <- mean(launch$distress_ct) - b * mean(launch$temperature)
a

# calculate the correlation of launch data
r <- cov(launch$temperature, launch$distress_ct) /
       (sd(launch$temperature) * sd(launch$distress_ct))
r
cor(launch$temperature, launch$distress_ct)

# computing the slope using correlation
r * (sd(launch$distress_ct) / sd(launch$temperature))

# confirming the regression line using the lm function (not in text)
model <- lm(distress_ct ~ temperature, data = launch)
model
summary(model)

# creating a simple multiple regression function
reg <- function(y, x) {
  x <- as.matrix(x)
  x <- cbind(Intercept = 1, x)
  solve(t(x) %*% x) %*% t(x) %*% y
}

# examine the launch data
str(launch)

# test regression model with simple linear regression
reg(y = launch$distress_ct, x = launch[3])

# use regression model with multiple regression
reg(y = launch$distress_ct, x = launch[3:5])

# confirming the multiple regression result using the lm function (not in text)
model <- lm(distress_ct ~ temperature + pressure + launch_id, data = launch)
model

## Example: Predicting Medical Expenses ----
## Step 2: Exploring and preparing the data ----
insurance <- read.csv("insurance.csv", stringsAsFactors = TRUE)
str(insurance)

# summarize the charges variable
summary(insurance$charges)

# histogram of insurance charges
hist(insurance$charges)

# table of region
table(insurance$region)

# exploring relationships among features: correlation matrix
cor(insurance[c("age", "bmi", "children", "charges")])

# visualing relationships among features: scatterplot matrix
pairs(insurance[c("age", "bmi", "children", "charges")])

# more informative scatterplot matrix
library(psych)
pairs.panels(insurance[c("age", "bmi", "children", "charges")])

## Step 3: Training a model on the data ----
ins_model <- lm(charges ~ age + children + bmi + sex + smoker + region,
                data = insurance)
ins_model <- lm(charges ~ ., data = insurance) # this is equivalent to above

# see the estimated beta coefficients
ins_model

## Step 4: Evaluating model performance ----
# see more detail about the estimated beta coefficients
summary(ins_model)

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

# add a higher-order "age" term
insurance$age2 <- insurance$age^2

# add an indicator for BMI >= 30
insurance$bmi30 <- ifelse(insurance$bmi >= 30, 1, 0)

# create final model
ins_model2 <- lm(charges ~ age + age2 + children + bmi + sex +
                   bmi30*smoker + region, data = insurance)

summary(ins_model2)

#### Part 2: Regression Trees and Model Trees -------------------

## Understanding regression trees and model trees ----
## Example: Calculating SDR ----
# set up the data
tee <- c(1, 1, 1, 2, 2, 3, 4, 5, 5, 6, 6, 7, 7, 7, 7)
at1 <- c(1, 1, 1, 2, 2, 3, 4, 5, 5)
at2 <- c(6, 6, 7, 7, 7, 7)
bt1 <- c(1, 1, 1, 2, 2, 3, 4)
bt2 <- c(5, 5, 6, 6, 7, 7, 7, 7)

# compute the SDR
sdr_a <- sd(tee) - (length(at1) / length(tee) * sd(at1) + length(at2) / length(tee) * sd(at2))
sdr_b <- sd(tee) - (length(bt1) / length(tee) * sd(bt1) + length(bt2) / length(tee) * sd(bt2))

# compare the SDR for each split
sdr_a
sdr_b

## Example: Estimating Wine Quality ----
## Step 2: Exploring and preparing the data ----
wine <- read.csv("whitewines.csv")

# examine the wine data
str(wine)

# the distribution of quality ratings
hist(wine$quality)

# summary statistics of the wine data
summary(wine)

wine_train <- wine[1:3750, ]
wine_test <- wine[3751:4898, ]

## Step 3: Training a model on the data ----
# regression tree using rpart
library(rpart)
m.rpart <- rpart(quality ~ ., data = wine_train)

# get basic information about the tree
m.rpart

# get more detailed information about the tree
summary(m.rpart)

# use the rpart.plot package to create a visualization
library(rpart.plot)

# a basic decision tree diagram
rpart.plot(m.rpart, digits = 3)

# a few adjustments to the diagram
rpart.plot(m.rpart, digits = 4, fallen.leaves = TRUE, type = 3, extra = 101)

## Step 4: Evaluate model performance ----

# generate predictions for the testing dataset
p.rpart <- predict(m.rpart, wine_test)

# compare the distribution of predicted values vs. actual values
summary(p.rpart)
summary(wine_test$quality)

# compare the correlation
cor(p.rpart, wine_test$quality)

# function to calculate the mean absolute error
MAE <- function(actual, predicted) {
  mean(abs(actual - predicted))
}

# mean absolute error between predicted and actual values
MAE(p.rpart, wine_test$quality)

# mean absolute error between actual values and mean value
mean(wine_train$quality) # result = 5.87
mean_abserror(5.87, wine_test$quality)

## Step 5: Improving model performance ----
# train a M5' Model Tree
library(RWeka)
m.m5p <- M5P(quality ~ ., data = wine_train)

# display the tree
m.m5p

# get a summary of the model's performance
summary(m.m5p)

# generate predictions for the model
p.m5p <- predict(m.m5p, wine_test)

# summary statistics about the predictions
summary(p.m5p)

# correlation between the predicted and true values
cor(p.m5p, wine_test$quality)

# mean absolute error of predicted and true values
# (uses a custom function defined above)
MAE(wine_test$quality, p.m5p)


#######################################################
### Gamma distribution with Lambda = 8, Alpha = 0.5 ###
#######################################################

## Sample the samples
nSamples <- 10000
lambda = 8
alpha = 0.5
xVal <- rgamma(nSamples, shape=lambda, rate=alpha)

## Calculate characteristics
xA1 <- mean(xVal) # mean
xM2 <- mean((xVal - xA1)^2) # biased sample variance
xS2 <- nSamples * xM2 / (nSamples - 1) # unbiased sample variance
xSigma <- sd(xVal) # standard deviation (sqrt(m2))
xSem <- xSigma / sqrt(nSamples) # error of mean
xMed <- median(xVal) # median
xMax <- max(xVal) # max value
xMin <- min(xVal) # min value
xQuant <- quantile(xVal) # quantiles
xIqr <- IQR(xVal) # interquartile range
xM3 <- mean((xVal - xA1)^3) # third central moment
xGamma1 <- xM3 / xSigma^3 # skewness
xM4 <- mean((xVal - xA1)^4) # forth central moment
xGamma2 <- xM4 / xSigma^4 # kurtosis

## Parameter estimation (moment method)
print('################################')
# E[x] = lambda / alpha; D[x] = lambda^2 / alpha
alphaEstMM <- xA1 / xM2
lambdaEstMM <- xA1^2 / xM2
print(paste0('Estimated alpha (MM): ', alphaEstMM))
print(paste0('Estimated lambda (MM): ', lambdaEstMM))

## Pearson's chi square test
print('################################')
rNum <- 15
stepSize <- 3
rSeq <- seq(1, rNum-1)
xCountsVect <- vector()
for (i in rSeq)
{
	desiredVals <- xVal[xVal > (stepSize * (i - 1))]
	desiredVals <- desiredVals[desiredVals < (stepSize * i)]
	xCountsVect <- c(xCountsVect, length(desiredVals))
}
desiredVals <- xVal[xVal > stepSize * rNum-1]
xCountsVect <- c(xCountsVect, length(desiredVals))
rSeq <- c(0, rSeq)

gammaCDFOnBreaks <- pgamma(stepSize * rSeq, lambdaEstMM, alphaEstMM)
gammaCDFOnBreaks <- c(gammaCDFOnBreaks, 1)
#print(gammaCDFOnBreaks)
pVect = gammaCDFOnBreaks[2:(rNum+1)] - gammaCDFOnBreaks[1:rNum]
#print(xCountsVect)
#print(round(nSamples * pVect))
numer = (xCountsVect - nSamples * pVect)^2
denom = nSamples * pVect
chiSquare = sum(numer / denom)
print(paste0('Chi square test: ', chiSquare))


### 多次元尺度構成法の例
### - Distances Between European Cities

## データの読み込み ("datasets::eudodist"を用いる)
data(eurodist)    # データセットの読み込み
help(eurodist)    # データセットの詳細を表示
class(eurodist)   # クラスの確認

## 多次元尺度(2次元)の構成
mds <- cmdscale(eurodist,k=2)

## 構成された尺度によるデータの表示: 図(a)
plot(mds,type='n',asp=1,xlab="",ylab="") # 点は打たずに座標軸だけ用意
text(mds,labels=rownames(mds),cex=.8)    # 点の位置に都市名を表示
abline(h=pretty(range(mds[,1]),10),      # ガイドラインを表示
       v=pretty(range(mds[,2]),10), col="lightgray")

## 実際の配置に合わせて南北を逆転: 図(b)
mds2 <- mds * rep(c(1,-1),each=nrow(mds))
plot(mds2,type='n',asp=1,xlab="",ylab="")
text(mds2,labels=rownames(mds2),cex=.8)
abline(h=pretty(range(mds2[,1]),10),
       v=pretty(range(mds2[,2]),10), col="lightgray")

## 3次元尺度構成 (第1,2軸): 図(c)
mds3 <- cmdscale(eurodist,k=3)  # 3次元への埋め込み
plot(mds3,type='n',asp=1,xlab="axis 1",ylab="axis 2")
text(mds3,labels=rownames(mds),cex=.8)
abline(h=pretty(range(mds3[,1]),10),
       v=pretty(range(mds3[,2]),10), col="lightgray")

## 3次元尺度構成 (第2,3軸): 図(d)
plot(mds3[,2:3],type='n',asp=1,xlab="axis 2",ylab="axis 3")
text(mds3[,2:3],labels=rownames(mds),cex=.8)
abline(h=pretty(range(mds3[,2]),10), # 縦横比の関係で第2軸を使用
       v=pretty(range(mds3[,2]),10), col="lightgray")

## 不安定な高次元への埋め込みの例
head(cmdscale(eurodist, k=20),n=3) # 指定した次元までの座標が計算できない
## 高次元への埋め込みの安定化
mds4 <- cmdscale(eurodist, k=20, add=TRUE) # 対角成分に定数を付加
head(mds4$points,n=3) # 推定された座標を表示


#' One-dimensional diffusion, constant boundary conditions
#'
#' @description Function to solve diffusion equation
#' using numerical implicit finite differences method,
#' applied in the condition where: a) the diffusion occurs
#' inside a slab of material unidimensionally,
#' or only along one axis, b) the coefficient of diffusion is constant,
#' and c) the boundary conditions are constant.
#'
#' @usage diff_1D(Lx, Tt, nt, nx, D, C_ini, C_lim)
#'
#' @param Lx Total length of slab in x direction, usually in mm.
#' @param Tt Total diffusion time, usually in second.
#' @param nt Number of time discretization.
#' @param nx Number of dimension x discretization
#' @param D Coefficient of diffusion. Must be constant value.
#' @param C_ini Initial concentration value inside the slab.
#' @param C_lim Boundary condition, written as a vector
#' with one or two elements. If there is only one element,
#' the other side of the slab will be presented as having
#' Neumann boundary condition with flux = 0. If there are
#' two elements, the first element is the dirichlet
#' concentration on the left side, while the second element
#' is the dirichlet concentration on the right side.
#'
#' @return A matrix with {nx+1} number of row and {nt}
#' number of column, profiling the diffusion on slab with Lx
#' length along the time Tt.
#'
#' @examples
#' Lx <- 5 #Length of slab, in mm
#' Tt <- 20 #Total measured diffusion time, in seconds
#' nt <- 100 #Number of time discretization, wherein the Tt will be divided into 100 equal parts (0, 0.2, 0.4, ..., 20)
#' nx <- 50 #Number of dimension discretization
#' D <- 0.05 #Coefficient of diffusion in mm^2/s.
#' C_ini <- 0.05 #Initial concentration inside the slab.
#' C_lim <- c(0.10,0.25) #Dirichlet boundary concentration diffusing into the slab
#' matC <- diff_1D(Lx, Tt, nt, nx, D, C_ini, C_lim)

diff_1D <- function(Lx,Tt,nt,nx,D,C_ini,C_lim){

    #1-Dimensional diffusion solver using implicit method, with border condition on its two extremities/sides

    ##Basic parameters
    if(length(C_lim) == 1){

        C_fin <- C_lim

    } else {

        if(length(C_lim == 2)){
          C_left <- C_lim[1]

          C_right <- C_lim[2]

        } else {

          stop('ERROR = Unfortunately, this function cannot take more than two condition limits coming from each side')

        }

    }

    dt <- Tt/nt #Size of one step in t

    dx <- Lx/(nx+1) #Size of one step in x

    ##Calculations
    s = D*dt/(dx^2)

    ##
    # Matrix A
    A = matrix(0, nrow = nx+1, ncol = nx+1)

    for (i in 2:nx) {

      A[i, i] <- (1+2*s) #Diagonal elements

      A[i, (i+1)] <- -s

      A[(i+1), i] <- -s

    }

    A[1,1] <- (1+2*s); A[nx+1,nx+1] <- A[1,1]

    A[2,1] <- -s; A[1,2] <- -s

    b <- matrix(0, nrow = nx+1, ncol = 1)

    #Conditioning
    if(length(C_lim) == 2){

        print("Boundary conditions: dirichlet in both sides")

        b[1] <- s*C_right #Final, right side

        b[nx+1] <- s*C_left #Final, left side

    } else {

        print("Boundary condition: dirichlet in one side and neumann in another")

        A[nx+1,nx] <- -2*s #For neumann boundary condition

        b[1] <- s*C_fin #Final, right side

        b[nx+1] <- 0 #Zero flux, neumann condition, left side

    }

    Cmat_i <- matrix(C_ini, nrow = nx+1, ncol = 1)

    Cmat_f <- matrix(0, nrow = nx+1, ncol = nt)

    t_n <- matrix(0, nrow = nt, ncol = 1)

    Cmat_f[,1] <- Cmat_i

    t_j <- 0 #Initial time

    t_n[1] <- t_j

    ######
    ##March solution in time

    for (j in 1:nt) {

      t_j <- t_j+dt

      if(j == 1){
        Cmat_j <- Cmat_i
      } else {
        Cmat_j <- Cmat_j_1
      }

      c <- Cmat_j + b

      Cmat_j_1 = solve(A,c)

      Cmat_f[,j] <- Cmat_j_1

      #Next time step
      t_n[j] <- t_j

    }

  return(Cmat_f)

}

#' Mean concentration values of one-dimensional diffusion during each time steps.
#'
#' @description A wrapper of \emph{diff_1D} function,
#' returning the mean values of concentration during each
#' time step of the diffusion.
#'
#' @usage diff_1D_Ct(Lx, Tt, nt, nx, D, C_ini, C_lim)
#'
#' @param Lx Total length of slab in x direction, usually in mm.
#' @param Tt Total diffusion time, usually in second.
#' @param nt Number of time discretization.
#' @param nx Number of dimension x discretization
#' @param D Coefficient of diffusion. Must be constant value.
#' @param C_ini Initial concentration value inside the slab.
#' @param C_lim Boundary condition, written as a vector with one or two elements. If there is only one element, the other side of the slab will be presented as having Neumann boundary condition with flux = 0. If there are two elements, the first element is the dirichlet concentration on the left side, while the second element is the dirichlet concentration on the right side.
#'
#' @return A vector with \strong{nt} number of elements with the values of mean concentration in the slab for each T\emph{i}.
#'
#' @examples
#' Lx <- 5 #Length of slab, in mm
#' Tt <- 20 #Total measured diffusion time, in seconds
#' nt <- 100 #Number of time discretization, wherein the Tt will be divided into 100 equal parts (0, 0.2, 0.4, ..., 20)
#' nx <- 50 #Number of dimension discretization
#' D <- 0.05 #Coefficient of diffusion in mm^2/s.
#' C_ini <- 0.05 #Initial concentration inside the slab.
#' C_lim <- c(0.10,0.25) #Dirichlet boundary concentration diffusing into the slab
#' meanCt <- diff_1D_Ct(Lx, Tt, nt, nx, D, C_ini, C_lim)

diff_1D_Ct <- function(Lx,Tt,nt,nx,D,C_ini,C_lim){

  #Mean concentration value during each time step of 1-dimensional diffusion.
  #Will be useful for plotting

  Cmat <- diff_1D(Lx,Tt,nt,nx,D,C_ini,C_lim)

  Ct <- vector(mode="numeric", length = nt)

  for (i in 1:nt) {

    Ct[i] <- mean(Cmat[,i])

  }

  return(Ct)

}


source("1-loadingdata-in-R.r")
head(Census.Data)
library(dplyr)
library(ggplot2)

str(Census.Data)
summary(Census.Data)

#EDA

boxplot(Census.Data[,2:5])

library(vioplot)
vioplot(Census.Data$Unemployed, Census.Data$Qualification, Census.Data$White_British, Census.Data$Low_Occupancy, ylim=c(0,100), col = "dodgerblue", rectCol="dodgerblue3", colMed="dodgerblue4")

vioplot(Census.Data$Unemployed, Census.Data$Qualification, Census.Data$White_British, Census.Data$Low_Occupancy, ylim=c(0,100), col = "dodgerblue", rectCol="dodgerblue3", colMed="dodgerblue4", names=c("Unemployed", "Qualifications", "White British", "Occupancy"))

#boxplot
library(reshape)
library(reshape2)
Census.Data.Vi <- melt(Census.Data,id.vars ='OA',measure.vars =c('White_British','Low_Occupancy','Unemployed','Qualification'))
head(Census.Data.Vi)

ggplot(Census.Data.Vi , aes(x= variable, y=value, color = variable))+
  geom_boxplot() +
  stat_summary(fun=mean, geom="point", shape=20, size=1, color="red", fill="red")+
  theme(axis.text.x = element_text(angle=0, vjust=0.5,hjust=0.5))+
  theme(legend.position = "none")

p <- ggplot(Census.Data, aes(Unemployed,Qualification))

p + geom_point(aes(colour = White_British, size = Low_Occupancy))

#correlallation

# Runs a Pearson's correlation
cor(Census.Data$Unemployed, Census.Data$Qualification)

data1 <- Census.Data[,2:5]

cor(data1)
round(cor(data1),2)

corr <- cor(data1)

# creates a qplot from our corr matrix
qplot(x=Var1, y=Var2, data=melt(corr), fill=value, geom="tile") +
  scale_fill_gradient2(limits=c(-1, 1))

library(corrplot)

# creates a lower triangular corrplot from our corr matrix
corrplot(corr, type="lower", tl.col="black", tl.srt=45)

# runs a regressions model (y ~ x, data frame)
model_1 <- lm(Qualification~ Unemployed, Census.Data)

plot(Census.Data$Unemployed, Census.Data$Qualification, xlab="% Unemployed", ylab="% With a Qualification") + abline (model_1)

summary(model_1)

predict(model_1,data.frame(Unemployed= 10), interval = "confidence")

# a multiple regression model
model_2 <- lm(Qualification ~ Unemployed + White_British, Census.Data)

summary(model_2)


library(repr) ; options(repr.plot.width = 5, repr.plot.height = 6) # Change plot sizes (in cm)

rm(list = ls())
graphics.off()

nll.slr <- function(par, dat, ...){
 args <- list(...)

 b0 <- par[1]
 b1 <- par[2]
 X <- dat$X
 Y <- dat$Y
 if(!is.na(args$sigma)){
  sigma <- args$sigma
 } else
  sigma <- par[3]

 mu <- b0+b1 * X

 return(-sum(dnorm(Y, mean=mu, sd=sigma, log=TRUE)))
}

set.seed(123)
n <- 30
b0 <- 10
b1 <- 3
sigma <- 2
X <- rnorm(n, mean=3, sd=7)
Y <- b0 + b1 * X + rnorm(n, mean=0, sd=sigma)
dat <- data.frame(X=X, Y=Y) # convert to a data frame

plot(X, Y)

N <- 50
b0s <- seq(5, 15, length=N)
mynll <- rep(NA, length=50)
for(i in 1:N){
 mynll[i] <- nll.slr(par=c(b0s[i],b1), dat=dat, sigma=sigma)
}

plot(b0s, mynll, type="l")
abline(v=b0, col=2)
abline(v=b0s[which.min(mynll)], col=3)

N0 <- 100
N1 <- 101
b0s <- seq(7,12, length=N0)
b1s <- seq(1,5, length=N1)

mynll <- matrix(NA, nrow=N0, ncol=N1)
for(i in 1:N0){
 for(j in 1:N1) mynll[i,j] <- nll.slr(par=c(b0s[i],b1s[j]), dat=dat, sigma=sigma)
}

ww <- which(mynll==min(mynll), arr.ind=TRUE)

b0.est <- b0s[ww[1]]
b1.est <- b1s[ww[2]]
rbind(c(b0, b1), c(b0.est, b1.est))

filled.contour(x = b0s, y = b1s, z= mynll, col=heat.colors(21),
    plot.axes = {axis(1); axis(2); points(b0,b1, pch=21);
       points(b0.est, b1.est, pch=8, cex=1.5); xlab="b0"; ylab="b1"})

par(mfrow=c(1,2), bty="n")
plot(b0s, mynll[,ww[2]], type="l", xlab="b0", ylab="NLL")
plot(b1s, mynll[ww[1],], type="l", xlab="b1", ylab="NLL")

fit <- optim(nll.slr, par=c(2, 1), method="L-BFGS-B", ## this is a n-D method
    lower=-Inf, upper=Inf, dat=dat, sigma=sigma)

fit

fit <- optim(nll.slr, par=c(2, 1, 5), method="L-BFGS-B", ## this is a n-D method
    lower=c(-Inf, -Inf, 0.1), upper=Inf, dat=dat, sigma=NA)
fit$par

plot(X, Y)
abline(a=fit$par[1], b=fit$par[2], col=2, lwd=2)

fit <- optim(nll.slr, par=c(2, 1), method="L-BFGS-B", hessian=TRUE, lower=-Inf, upper=Inf, dat=dat, sigma=sigma)

fisher_info <- solve(fit$hessian)
est_sigma <- sqrt(diag(fisher_info))
upper <- fit$par+1.96 * est_sigma
lower <- fit$par-1.96 * est_sigma
interval <- data.frame(value=fit$par, upper=upper, lower=lower)
interval

lmfit <- lm(Y~X)

summary(lmfit)$coeff


# KmeansClustering.r
#
# Simple description of K means clustering algorithm
#

## Functions

# Distance function - Euclidean

euclidean <- function(x,y) {
  return ( sqrt( (x[1] - y[1] )^2
                 + (x[2] - y[2])^2))}

# Objective function - J ( minimise the the sum of squares )

J <- function( data, centroids, groups) {

  sum <- 0

  for ( j in 1:nrow(centroids)) {

    index <- which(groups[,j]==1)

    for( n in 1:length(index)) {

      sum <- sum + euclidean(data[index[n],], centroids[j,])

    }

  }

  return( sum )

}

# kmean function - simple algorithim to demonstrate
# the principles

mykmeans <- function( df, k ) { # data is assumed to be in a
  # data frame

  # Convert data frame to matrix - using ".m" to remind
  # that working with matrices throughout.

  df.m <- matrix(as.numeric(unlist(df)), nrow=nrow(df))

  # Initialise matrices

  centroids.m <- matrix(0, nrow=k, ncol=ncol(df.m))

  groups.m  <-  matrix(0, nrow=nrow(df.m), ncol=k)

  dist.m <- matrix(0, nrow=nrow(df.m), ncol=k )

  # Initialise Error function and iteration

  error <- c()

  iter <- 1

  # Randomly select k points as initial cluster centers

  index <- sample(1:nrow(df.m), k, replace = FALSE)

  centroids.m <- df.m[index,]

  # Set oldcentroids.m which will be used to check convergence

  oldcentroids.m <- centroids.m

  # Start iteration

  while(TRUE) {

    # Calculate the distance between data and centroids

    for( i in 1:k) {

      dist.m[,i] <- apply(df.m, 1, FUN=function(x) euclidean(x,centroids.m[i,]))

    }

    # Allocate observations depending on the minimim
    # distance to the appropriate cluster - similar to argmin()

    for ( i in 1:nrow(df.m)) {

      # Note assuming that there is a unique minimum

      index <- which(dist.m[i,]==min(dist.m[i,]))

      groups.m[i,index] <- 1
      groups.m[i,-index] <- 0

    }

    # Calculate the new centroid position based on means

    for ( i in 1:k) {

      k.sum <- sum(groups.m[,i])

      index <- which(groups.m[,i]==1)

      for ( j in 1:k ) {

        centroids.m[i,j] <- ( 1/k.sum ) * sum(df.m[index,j])

      }

    }

    error[iter] <- J(df.m, centroids.m, groups.m)

    iter <- iter + 1

    # Check for convergence

    if(sum(abs(oldcentroids.m - centroids.m))==0) break

    oldcentroids.m <- centroids.m

    # Safety check - doesn't loop indefinately

    if ( iter > 100) break

  } # End of While loop

  # Convert results back to information in the data frame

  rownames(groups.m) <- rownames(df)

  colnames(centroids.m) <- colnames(df)

  # Return results in a list

  return (list(groups.m,centroids.m, error,iter))

}

## Data

# Medicines Data

weight <- c(1,2,4,5)
pH <- c(1,1,3,4)

med.data <- data.frame(Weight=weight, pHIndex=pH )

rownames(med.data) <- c("A","B","C","D")

# Scores on individuals

A <- c(1.0,1.5,3.0,5.0,3.5,4.5,3.5)

B <- c(1.0,2.0,4.0,7.0,5.0,5.0,4.5)

score.data <- data.frame(A=A, B=B)

## Uisng the functions with the data

myfit <- mykmeans(med.data, 2)

# Using R's function - kmeans

fit <- kmeans(med.data, 2 )    # Gets answer shown in the OHDs


#!/usr/bin/env Rscript

# dpois, ppois, qpois, rposi
# d-密度函数后分布律
# p-分布函数
# q-分布函数的反函数，即给定概率p下，求其下分为点
# r-仿真(产生相同分布随机数)

# eg.1
# Binom distribution
par(mfrow=c(3,3))
for (i in seq(.1, .9, .1)) {
    barplot(dbinom(0:5, 5, i))
    # p == that 使用list里面的变量值变换替换
    title(main=(substitute(p == that, list(that = i))))
}

# eg.2
# Possion distribution
# type = "b": both - 点线
# pch = n: 控制连接点的symbol
plot(dpois(0:20, 3), type="b", pch=15, xlab="k", ylab="p(k)")
points(dpois(0:20, 6), type="b", pch=17)
points(dpois(0:20, 10), type="b", pch=19)
# text 在指定坐标输入txt
text(c(3.5, 6.5, 11.5), c(.18, .14, .09),
     c(expression(lambda==3),
       expression(lambda==6),
       expression(lambda==10)))
title(main="Possion Distribution")

# eg.3 理解概率密度, 当连续型变量, 在某个值上的频数, 实际上非常小(因为连续分母很大)
x = rnorm(100000)
par(mfrow=c(2,2))
# hist: 按n分成相等的份, 在该区间的频数和
hist(x, 14, col="blue", xlab="", ylab="", main="Histogram 1")
hist(x, 50, col="blue", axes=FALSE, xlab="", ylab="", main="Histogram 2")
hist(x, 100, col="blue", xlab="", ylab="", main="Histogram 2")

# 正态分布x>4, y接近0 (因为sigma=1, mu=0, 3*sigma --> 99%)
# dnorm 是密度函数, 给定xs, 返回ys
xs = seq(-4, 4, l=1000)
ys = dnorm(xs)
plot(xs, ys, type="l", axes=FALSE, xlab="", ylab="", main="Density")
# 多边形填充
polygon(c(xs[xs>-4]), c(dnorm(c(xs[xs>-4]))), col="blue")

# eg.4 正态分布 不同值, 形状
xs = seq(-5, 5, .001)
par(mfrow=c(1,1))
ys1 = dnorm(xs, mean=-2, sd = .5)
ys2 = dnorm(xs, mean=0, sd = 1)
# lty: line type
plot(xs, ys1, type="l", lty=2, xlab="", ylab="")
lines(xs, ys2)
text(c(-2, 0), c(.3, .2), c("N(-2, 0.5)", "N(0,1)"))

# eg.5 pdf 密度函数积分(r1 --> r2)
xs = c(seq(-4, 4, length=1000))
ys = dnorm(xs)

r1 = 0.51
r2 = 1.57

xs2 = c(r1, r1, xs[xs>r1&xs<r2], r2, r2)
ys2 = dnorm(c(r1, xs[xs>r1&xs<r2], r2))
ys2 = c(0, ys2, 0)

par(mfrow=c(1,1))
plot(xs, ys, type="l", ylab=expression(phi(x)))
# 画底下一条线
abline(h = 0)
polygon(xs2, ys2, col="gray")

# eg6. 卡方分布
xs = seq(0, 10, l=1000)
ys1 = dchisq(xs, 2)
ys2 = dchisq(xs, 3)
ys3 = dchisq(xs, 5)

par(mfrow=c(1,1))
plot(xs, ys1, type="l", xlab="", ylab="")
lines(xs, ys2, lty=2)
lines(xs, ys3, lty=3)

text(c(0, 1, 7), c(.35, .2, .1),
     c(
       expression(chi^2(2)),
       expression(chi^2(3)),
       expression(chi^2(5))))

# eg7. t分布 -- 标准化过程中没有使用总体的标准差sigma, 而是使用了样本中的标准差s
xs = seq(-4, 4, l=1000)
ys1 = dnorm(xs)
ys2 = dt(xs, 1)

par(mfrow=c(1,1))
plot(xs, ys1, type="l", xlab="", ylab="")
lines(xs, ys2, lty=2)


#Let's first generate some data in 2 dimensions, and make them a little separated.
#Setting random seed, you make a matrix x, normally distributed with 20 observations in 2 classes on 2 variables.
#Then make y variable, which is going to be either -1 or 1, with 10 in each class.
#For y = 1, you move the means from 0 to 1 in each of the coordinates.
#Finally, you can plot the data and color code the points according to their response.
#The plotting character 19 gives you nice big visible dots coded blue or red according to whether the response is 1 or -1.

set.seed(10111)
x = matrix(rnorm(40), 20, 2)
y = rep(c(-1, 1), c(10, 10))
x[y == 1,] = x[y == 1,] + 1
plot(x, col = y + 3, pch = 19)

library(e1071)

#Make a dataframe of the data, turning y into a factor variable.
#Make a call to svm on this dataframe, using y as the response variable and other variables as the predictors.
#The dataframe will have unpacked the matrix x into 2 columns named x1 and x2.
#SVM that the kernel is linear, the tune-in parameter cost is 10, and scale equals false.
#In this example, no variables are standardize
#Printing the svmfit gives its summary

dat = data.frame(x, y = as.factor(y))
svmfit = svm(y ~ ., data = dat, kernel = "linear", cost = 10, scale = FALSE)
print(svmfit)

#See that the number of support vectors is 6 - they are the points that are close to the boundary
#or on the wrong side of the boundary.

plot(svmfit, dat)

#Make your own plot.
#To do is to create a grid of values or a lattice of values for x1 and x2 that covers the whole domain on a fairly fine lattice.
#Next, make a function called make.grid.
#It takes in your data matrix x, as well as an argument n which is the number of points in each direction.
#Now make a 75 x 75 grid.

#Within this function, apply function to get the range of each of the variables in x.
#Then for both x1 and x2, use the seq function to go from the lowest value to the upper value to make a grid of length n.
#Now, we have x1 and x2, each with length 75 uniformly-spaced values on each of the coordinates.
#Finally, use the function expand.grid, which takes x1 and x2 and makes the lattice.

make.grid = function(x, n = 75) {
  grange = apply(x, 2, range)
  x1 = seq(from = grange[1,1], to = grange[2,1], length = n)
  x2 = seq(from = grange[1,2], to = grange[2,2], length = n)
  expand.grid(X1 = x1, X2 = x2)
}

#Apply the make.grid function on x. Let's take a look at the first few values of the lattice from 1 to 10.
xgrid = make.grid(x)
xgrid[1:10,]

#Now we see, the grid goes through the 1st coordinate first, holding the 2nd coordinate fixed.

#Having made the lattice, we are going to make a prediction at each point in the lattice.
#With the new data xgrid, you use predict and call the response ygrid.
#Plot and color code the points according to the classification so that the decision boundary is clear.
#Put the original points on this plot using the points function.

#svmfit has a component called index that tells which are the support points.
#Plotting support points using the same function again.

ygrid = predict(svmfit, xgrid)
plot(xgrid, col = c("red","blue")[as.numeric(ygrid)], pch = 20, cex = .2)
points(x, col = y + 3, pch = 19)
points(x[svmfit$index,], pch = 5, cex = 2)

#See in the plot, the points in the boxes are close to the decision boundary and are instrumental in determining that boundary.

#Unfortunately, the svm function is not too friendly, in that you have to do some work to get back the linear coefficients.
#The reason is probably that this only makes sense for linear kernels, and the function is more general.
#So use a formula to extract the coefficients more efficiently.
#You extract beta and beta0, which are the linear coefficients.

beta = drop(t(svmfit$coefs)%*%x[svmfit$index,])
beta0 = svmfit$rho

#Replot the points on the grid, then put the points back in (including the support vector points).
#Use the coefficients to draw the decision boundary using a simple equation of the form:

#From that equation, you have to figure out a slope and an intercept for the decision boundary.
#Use the function abline with those 2 arguments.
#The subsequent 2 abline function represent the upper margin and the lower margin of the decision boundary, respectively.

plot(xgrid, col = c("red", "blue")[as.numeric(ygrid)], pch = 20, cex = .2)
points(x, col = y + 3, pch = 19)
points(x[svmfit$index,], pch = 5, cex = 2)
abline(beta0 / beta[2], -beta[1] / beta[2])
abline((beta0 - 1) / beta[2], -beta[1] / beta[2], lty = 2)
abline((beta0 + 1) / beta[2], -beta[1] / beta[2], lty = 2)

#NON LINEAR

load(file = "C:/Users/ADMIN/Downloads/ESL.mixture.rda")
names(ESL.mixture)

rm(x, y)
attach(ESL.mixture)

plot(x, col = y + 1)

dat = data.frame(y = factor(y), x)
fit = svm(factor(y) ~ ., data = dat, scale = FALSE, kernel = "radial", cost = 5)

xgrid = expand.grid(X1 = px1, X2 = px2)
ygrid = predict(fit, xgrid)

plot(xgrid, col = as.numeric(ygrid), pch = 20, cex = .2)
points(x, col = y + 1, pch = 19)

#Predicting Decision Boundries
func = predict(fit, xgrid, decision.values = TRUE)
func = attributes(func)$decision

xgrid = expand.grid(X1 = px1, X2 = px2)
ygrid = predict(fit, xgrid)
plot(xgrid, col = as.numeric(ygrid), pch = 20, cex = .2)
points(x, col = y + 1, pch = 19)

contour(px1, px2, matrix(func, 69, 99), level = 0, add = TRUE)
contour(px1, px2, matrix(func, 69, 99), level = 0.5, add = TRUE, col = "blue", lwd = 2)


#Fit a simple regression model
#Plug in new covariates and multiply by the coefficients
#Useful when the linear model is (nearly) correct
#Pros:

        #Easy to implement
#Easy to interpret
#Cons:

       # Often poor performance in nonlinear settings

#Example: Old faithful eruptions

library(caret);data(faithful); set.seed(333)
inTrain <- createDataPartition(y=faithful$waiting,
                               p=0.5, list=FALSE)
trainFaith <- faithful[inTrain,]; testFaith <- faithful[-inTrain,]
head(trainFaith)

#Eruption duration versus waiting time

plot(trainFaith$waiting,trainFaith$eruptions,pch=19,col="blue",xlab="Waiting",ylab="Duration")

#Fit a linear model

#$$ ED_i = b_0 + b_1 WT_i + e_i $$

        lm1 <- lm(eruptions ~ waiting,data=trainFaith)
summary(lm1)

#Model fit

plot(trainFaith$waiting,trainFaith$eruptions,pch=19,col="blue",xlab="Waiting",ylab="Duration")
lines(trainFaith$waiting,lm1$fitted,lwd=3)

#Predict a new value

#$$\hat{ED} = \hat{b}_0 + \hat{b}_1 WT$$

coef(lm1)[1] + coef(lm1)[2]*80
newdata <- data.frame(waiting=80)
predict(lm1,newdata)

#Plot predictions - training and test

par(mfrow=c(1,2))
plot(trainFaith$waiting,trainFaith$eruptions,pch=19,col="blue",xlab="Waiting",ylab="Duration")
lines(trainFaith$waiting,predict(lm1),lwd=3)
plot(testFaith$waiting,testFaith$eruptions,pch=19,col="blue",xlab="Waiting",ylab="Duration")
lines(testFaith$waiting,predict(lm1,newdata=testFaith),lwd=3)

## Get training set/test set errors

# Calculate RMSE on training
sqrt(sum((lm1$fitted-trainFaith$eruptions)^2))

# Calculate RMSE on test
sqrt(sum((predict(lm1,newdata=testFaith)-testFaith$eruptions)^2))

#Prediction intervals

pred1 <- predict(lm1,newdata=testFaith,interval="prediction")
ord <- order(testFaith$waiting)
plot(testFaith$waiting,testFaith$eruptions,pch=19,col="blue")
matlines(testFaith$waiting[ord],pred1[ord,],type="l",col=c(1,2,2),lty = c(1,1,1), lwd=3)

#Same process with caret

modFit <- train(eruptions ~ waiting,data=trainFaith,method="lm")
summary(modFit$finalModel)


y<-c(26 ,28 ,30, 37 ,33 ,30,
    29 ,39 ,49 ,31, 38 ,36,
    33 ,24, 34, 40 ,29, 41,
    40, 29, 35 ,44 ,32, 45,
    35 ,26, 42, 36 ,37 ,35)
mean_y<-sum(y)/length(y)
print(mean_y)
sample_variance <-(sum((y-mean_y)^2/(length(y)-1)))
print(sample_variance)
standard_deviation <-sqrt(sum((y-mean_y)^2/(length(y)-1)))
print(standard_deviation)
# we obtain an approximate value for s by dividing the range by 4:
s=(max(y)-min(y))/4;
print(s)


library(repr) ; options(repr.plot.width=6, repr.plot.height= 6) # Change plot sizes (in cm)

a <- 4  # store 4 as variable a

a # display it

a * a # product

a_squared <- a * a

sqrt(a_squared) # square root

v <- c(0, 1, 2, 3, 4)

v # Display the vector-valued variable you created

is.vector(v) # check if v's a vector

mean(v) # mean

var(v) # variance

median(v) # median

sum(v) # sum all elements

prod(v + 1) # multiply

length(v) # how many elements in the vector

wing.width.cm <- 1.2 #Using dot notation

wing.length.cm <- c(4.7, 5.2, 4.8)

li = list(c(1,2,3))

class(li)

v <- TRUE

v

class(v)

v <- 3.2
class(v)

v <- 2L
class(v)

v <- "A string"
class(v)

b <- NA
class(b)

is.na(b)

b <- 0/0
b

is.nan(b)

b <- 5/0
b

is.nan(b)

is.infinite(b)

is.finite(b)

is.finite(0/0)

as.integer(3.1)

as.numeric(4)

as.roman(155)

as.character(155)  # same as converting to string

as.logical(5)

as.logical(0)

1E4

1e4

5e-2

1E4^2

1 / 3 / 1e8

a <- 5
is.vector(a)

v1 <- c(0.02, 0.5, 1)
v2 <- c("a", "bc", "def", "ghij")
v3 <- c(TRUE, TRUE, FALSE)

v1;v2;v3

v1 <- c(0.02, TRUE, 1)
v1

v1 <- c(0.02, "Mary", 1)
v1

mat1 <- matrix(1:25, 5, 5)
mat1

print(mat1)

mat1 <- matrix(1:25, 5, 5, byrow=TRUE)
mat1

dim(mat1) #get the size of the matrix

arr1 <- array(1:50, c(5, 5, 2))
arr1[,,1]

print(arr1)

arr1[,,2]

mat1[1,1] <- "one"
mat1

Col1 <- 1:10
Col1

Col2 <- LETTERS[1:10]
Col2

Col3 <- runif(10) # 10 random numbers from a uniform distribution
Col3

MyDF <- data.frame(Col1, Col2, Col3)
MyDF

print(MyDF)

names(MyDF) <- c("MyFirstColumn", "My Second Column", "My.Third.Column")
MyDF

MyDF$MyFirstColumn

MyDF$My Second Column

colnames(MyDF)

colnames(MyDF)[2] <- "MySecondColumn"
MyDF

MyDF$My.Third.Column

MyDF[,1]

MyDF[1,1]

MyDF[c("MyFirstColumn","My.Third.Column")] # show two specific columns only

class(MyDF)

str(MyDF)

head(MyDF)

tail(MyDF)

MyList <- list(species=c("Quercus robur","Fraxinus excelsior"), age=c(123, 84))
MyList

MyList[[1]]

MyList[[1]][1]

MyList$species

MyList[["species"]]

MyList$species[1]

pop1<-list(species='Cancer magister',
           latitude=48.3,longitude=-123.1,
           startyr=1980,endyr=1985,
           pop=c(303,402,101,607,802,35))
pop1

pop1<-list(lat=19,long=57,
           pop=c(100,101,99))
pop2<-list(lat=56,long=-120,
           pop=c(1,4,7,7,2,1,2))
pop3<-list(lat=32,long=-10,
           pop=c(12,11,2,1,14))
pops<-list(sp1=pop1,sp2=pop2,sp3=pop3)
pops

pops$sp1 # check out species 1

pops$sp1["pop"] # sp1's population sizes

pops[[2]]$lat #latitude of second species

pops[[3]]$pop[3]<-102 #change population of third species at third time step
pops

MyMat = matrix(1:8, 4, 4)
MyMat

MyDF = as.data.frame(MyMat)
MyDF

object.size(MyMat) # returns size of an R object (variable) in bytes

object.size(MyDF)

years <- 1990:2009
years

years <- 2009:1990 # or in reverse order
years

seq(1, 10, 0.5)

MyVar <- c( 'a' , 'b' , 'c' , 'd' , 'e' )

MyVar[1] # Show element in first position

MyVar[4] # Show element in fourth position

MyVar[c(3,2,1)] # reverse order

MyVar[c(1,1,5,5)] # repeat indices

v <- c(0, 1, 2, 3, 4) # Create a vector named v

v[3] # access one element

v[1:3] # access sequential elements

v[-3] # remove elements

v[c(1, 4)] # access non-sequential indices

mat1 <- matrix(1:25, 5, 5, byrow=TRUE) #create a matrix
mat1

mat1[1,2]

mat1[1,2:4]

mat1[1:2,2:4]

mat1[1,] # First row, all columns

mat1[,1] # First column, all rows

a <- c(1,5) + 2
a

x <- c(1,2); y <- c(5,3,9,2)
x;y

x + y

x + c(y,1)

v <- c(0, 1, 2, 3, 4)
v2 <- v*2 # multiply whole vector by 2
v2

v * v2 # element-wise product

t(v) # transpose the vector

v %*% t(v) # matrix/vector product

v3 <- 1:7 # assign using sequence
v3

v4 <- c(v2, v3) # concatenate vectors
v4

species.name <- "Quercus robur" #You can alo use single quotes
species.name

paste("Quercus", "robur")

paste("Quercus", "robur",sep = "") #Get rid of space

paste("Quercus", "robur",sep = ", ") #insert comma to separate

paste('Year is:', 1990:2000)

strsplit("String; to; Split",';')# Split the string at ';'

set.seed(1234567)
rnorm(1)

rnorm(10)

set.seed(1234567)
rnorm(11)

setwd("../code/")

MyData <- read.csv("../data/trees.csv")

ls(pattern = "My*") # Check that MyData has appeared

class(MyData)

head(MyData) # Have a quick look at the data frame

str(MyData) # Note the data types of the three columns

MyData <- read.csv("../data/trees.csv", header = F) # Import ignoring headers

head(MyData)

MyData <- read.table("../data/trees.csv", sep = ',', header = TRUE) #another way

head(MyData)

MyData <- read.csv("../data/trees.csv", skip = 5) # skip first 5 lines

write.csv(MyData, "../results/MyData.csv")

dir("../results/") # Check if it worked

write.table(MyData[1,], file = "../results/MyData.csv",append=TRUE) # append

write.csv(MyData, "../results/MyData.csv", row.names=TRUE) # write row names

write.table(MyData, "../results/MyData.csv", col.names=FALSE) # ignore col names

source("basic_io.R")

a <- TRUE
if (a == TRUE){
    print ("a is TRUE")
    } else {
    print ("a is FALSE")
}

z <- runif(1) ## Generate a uniformly distributed random number
if (z <= 0.5) {print ("Less than a half")}

for (i in 1:10){
    j <- i * i
    print(paste(i, " squared is", j ))
}

1:10

for(species in c('Heliodoxa rubinoides',
                 'Boissonneaua jardini',
                 'Sula nebouxii')){
  print(paste('The species is', species))
}

v1 <- c("a","bc","def")
for (i in v1){
    print(i)
}

i <- 0
while (i < 10){
    i <- i+1
    print(i^2)
}

i <- 0 #Initialize i
    while(i < Inf) {
        if (i == 10) {
            break
             } # Break out of the while loop!
        else {
            cat("i equals " , i , " \n")
            i <- i + 1 # Update i
    }
}

for (i in 1:10) {
  if ((i %% 2) == 0) # check if the number is odd
    next # pass to next iteration of loop
  print(i)
}

source("boilerplate.R")

ls(pattern = "MyFun*")

class(MyFunction)

# Checks if an integer is even
is.even <- function(n = 2){
  if (n %% 2 == 0)
  {
    return(paste(n,'is even!'))
  }
  return(paste(n,'is odd!'))
}

is.even(6)

# Checks if a number is a power of 2
is.power2 <- function(n = 2){
  if (log2(n) %% 1==0)
  {
    return(paste(n, 'is a power of 2!'))
  }
  return(paste(n,'is not a power of 2!'))
}

is.power2(4)

# Checks if a number is prime
is.prime <- function(n){
  if (n==0){
    return(paste(n,'is a zero!'))
  }
  if (n==1){
    return(paste(n,'is just a unit!'))
  }
  ints <- 2:(n-1)
  if (all(n%%ints!=0)){
    return(paste(n,'is a prime!'))
  }
  return(paste(n,'is a composite!'))
}

is.prime(3)

a <- 1.0
class(a)

M <- matrix(runif(1000000),1000,1000)

SumAllElements <- function(M){
  Dimensions <- dim(M)
  Tot <- 0
  for (i in 1:Dimensions[1]){
    for (j in 1:Dimensions[2]){
      Tot <- Tot + M[i,j]
    }
  }
  return (Tot)
}

print("Using loops, the time taken is:")
print(system.time(SumAllElements(M)))

print("Using the in-built vectorized function, the time taken is:")
print(system.time(sum(M)))

NoPreallocFun <- function(x){
    a <- vector() # empty vector
    for (i in 1:x) {
        a <- c(a, i) # concatenate
        print(a)
        print(object.size(a))
    }
}

system.time(NoPreallocFun(10))

PreallocFun <- function(x){
    a <- rep(NA, x) # pre-allocated vector
    for (i in 1:x) {
        a[i] <- i # assign
        print(a)
        print(object.size(a))
    }
}

system.time(PreallocFun(10))

## Build a random matrix
M <- matrix(rnorm(100), 10, 10)

## Take the mean of each row
RowMeans <- apply(M, 1, mean)
print (RowMeans)

## Now the variance
RowVars <- apply(M, 1, var)
print (RowVars)

## By column
ColMeans <- apply(M, 2, mean)
print (ColMeans)

SomeOperation <- function(v){ # (What does this function do?)
  if (sum(v) > 0){ #note that sum(v) is a single (scalar) value
    return (v * 100)
  }
  return (v)
}

M <- matrix(rnorm(100), 10, 10)
print (apply(M, 1, SomeOperation))

######### Functions ##########

## A function to take a sample of size n from a population "popn" and return its mean
myexperiment <- function(popn,n){
    pop_sample <- sample(popn, n, replace = FALSE)
    return(mean(pop_sample))
}

## Calculate means using a FOR loop on a vector without preallocation:
loopy_sample1 <- function(popn, n, num){
    result1 <- vector() #Initialize empty vector of size 1
    for(i in 1:num){
        result1 <- c(result1, myexperiment(popn, n))
    }
    return(result1)
}

## To run "num" iterations of the experiment using a FOR loop on a vector with preallocation:
loopy_sample2 <- function(popn, n, num){
    result2 <- vector(,num) #Preallocate expected size
    for(i in 1:num){
        result2[i] <- myexperiment(popn, n)
    }
    return(result2)
}

## To run "num" iterations of the experiment using a FOR loop on a list with preallocation:
loopy_sample3 <- function(popn, n, num){
    result3 <- vector("list", num) #Preallocate expected size
    for(i in 1:num){
        result3[[i]] <- myexperiment(popn, n)
    }
    return(result3)
}

## To run "num" iterations of the experiment using vectorization with lapply:
lapply_sample <- function(popn, n, num){
    result4 <- lapply(1:num, function(i) myexperiment(popn, n))
    return(result4)
}

## To run "num" iterations of the experiment using vectorization with sapply:
sapply_sample <- function(popn, n, num){
    result5 <- sapply(1:num, function(i) myexperiment(popn, n))
    return(result5)
}

set.seed(12345)
popn <- rnorm(10000) # Generate the population
hist(popn)

n <- 100 # sample size for each experiment
num <- 10000 # Number of times to rerun the experiment

print("Using loops without preallocation on a vector took:" )
print(system.time(loopy_sample1(popn, n, num)))

print("Using loops with preallocation on a vector took:" )
print(system.time(loopy_sample2(popn, n, num)))

print("Using loops with preallocation on a list took:" )
print(system.time(loopy_sample3(popn, n, num)))

print("Using the vectorized sapply function (on a list) took:" )
print(system.time(sapply_sample(popn, n, num)))

print("Using the vectorized lapply function (on a list) took:" )
print(system.time(lapply_sample(popn, n, num)))

x <- 1:20 # a vector
x

y <- factor(rep(letters[1:5], each = 4))
y

tapply(x, y, sum)

attach(iris)
iris

by(iris[,1:2], iris$Species, colMeans)

by(iris[,1:2], iris$Petal.Width, colMeans)

replicate(10, runif(5))

Ricker <- function(N0=1, r=1, K=10, generations=50)
{
  # Runs a simulation of the Ricker model
  # Returns a vector of length generations

  N <- rep(NA, generations)    # Creates a vector of NA

  N[1] <- N0
  for (t in 2:generations)
  {
    N[t] <- N[t-1] * exp(r*(1.0-(N[t-1]/K)))
  }
  return (N)
}

plot(Ricker(generations=10), type="l")

doit <- function(x){
    temp_x <- sample(x, replace = TRUE)
    if(length(unique(temp_x)) > 30) {#only take mean if sample was sufficient
         print(paste("Mean of this sample was:", as.character(mean(temp_x))))
        }
    else {
        stop("Couldn't calculate mean: too few unique values!")
        }
    }

set.seed(1345) # again, to get the same result for illustration

popn <- rnorm(50)

hist(popn)

lapply(1:15, function(i) doit(popn))

result <- lapply(1:15, function(i) try(doit(popn), FALSE))

class(result)

result

result <- vector("list", 15) #Preallocate/Initialize
for(i in 1:15) {
    result[[i]] <- try(doit(popn), FALSE)
    }

rm(list=ls())

load("../data/KeyWestAnnualMeanTemperature.RData")

ls()

class(ats)

head(ats)

plot(ats)


# Preprocessing with PCA
#Correlated predictors
library(caret); library(kernlab); data(spam)
inTrain <- createDataPartition(y=spam$type,
                               p=0.75, list=FALSE)
training <- spam[inTrain,]
testing <- spam[-inTrain,]

M <- abs(cor(training[,-58]))
diag(M) <- 0
which(M > 0.8,arr.ind=T)

#Correlated predictors

names(spam)[c(34,32)]
plot(spam[,34],spam[,32])

#Basic PCA idea

#We might not need every predictor
#A weighted combination of predictors might be better
#We should pick this combination to capture the "most information" possible
#Benefits
#Reduced number of predictors
#Reduced noise (due to averaging)

#We could rotate the plot

#$$ X = 0.71 \times {\rm num 415} + 0.71 \times {\rm num857}$$

#$$ Y = 0.71 \times {\rm num 415} - 0.71 \times {\rm num857}$$

X <- 0.71*training$num415 + 0.71*training$num857
Y <- 0.71*training$num415 - 0.71*training$num857
plot(X,Y)

#Related problems

#You have multivariate variables $X_1,\ldots,X_n$ so $X_1 = (X_{11},\ldots,X_{1m})$

#Find a new set of multivariate variables that are uncorrelated and explain as much variance as possible.
#If you put all the variables together in one matrix, find the best matrix created with fewer variables (lower rank) that explains the original data.
#The first goal is statistical and the second goal is data compression.

#Related solutions - PCA/SVD

#SVD

#If $X$ is a matrix with each variable in a column and each observation in a row then the SVD is a "matrix decomposition"

#$$ X = UDV^T$$

#where the columns of $U$ are orthogonal (left singular vectors), the columns of $V$ are orthogonal (right singluar vectors)
#and $D$ is a diagonal matrix (singular values).

#PCA

#The principal components are equal to the right singular values if you first scale (subtract the mean, divide by the standard deviation) the variables.

#Principal components in R - prcomp

smallSpam <- spam[,c(34,32)]
prComp <- prcomp(smallSpam)
plot(prComp$x[,1],prComp$x[,2])

#Principal components in R - prcomp

prComp$rotation

#PCA on SPAM data

typeColor <- ((spam$type=="spam")*1 + 1)
prComp <- prcomp(log10(spam[,-58]+1))
plot(prComp$x[,1],prComp$x[,2],col=typeColor,xlab="PC1",ylab="PC2")

#PCA with caret

preProc <- preProcess(log10(spam[,-58]+1),method="pca",pcaComp=2)
spamPC <- predict(preProc,log10(spam[,-58]+1))
plot(spamPC[,1],spamPC[,2],col=typeColor)

#Preprocessing with PCA

preProc <- preProcess(log10(training[,-58]+1),method="pca",pcaComp=2)
trainPC <- predict(preProc,log10(training[,-58]+1))
modelFit <- train(training$type ~ .,method="glm",data=trainPC)

#Preprocessing with PCA

testPC <- predict(preProc,log10(testing[,-58]+1))
confusionMatrix(testing$type,predict(modelFit,testPC))

#Alternative (sets # of PCs)

modelFit <- train(training$type ~ .,method="glm",preProcess="pca",data=training)
confusionMatrix(testing$type,predict(modelFit,testing))


#load the datasets library to access the iris data set
library(datasets)

#load and view the iris dataset
data(iris)
head(iris)

#load ggplot 2 for plotting
#install.packages("ggplot2")
library(ggplot2)
#install.packages("GGally")
library(GGally)

ggplot(iris, aes(Petal.Length, Petal.Width, color=Species)) + geom_point()

set.seed(13)

#Since we know there are 3 species, we expect k=3 to give the best results
irisCluster <- kmeans(iris[, 3:4], 3, nstart = 35)
irisCluster

table(irisCluster$cluster, iris$Species)

#We can see that petal length and width are similar within the same species, but vary between different species
irisCluster$cluster <- as.factor(irisCluster$cluster)
ggplot(iris, aes(Petal.Length, Petal.Width, color = irisCluster$cluster)) + geom_point()

#Sepal length and width are not as easily distinguished between species
ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) + geom_point()

ggpairs(iris, columns = 1:5, mapping=aes(color=Species))

#find the errors
not.error <- unclass(iris$Species) == irisCluster$cluster
iris$noerror <- not.error

#See errors
ggplot(iris, aes(Petal.Length, Petal.Width, color = irisCluster$cluster)) +
  geom_point(size = 3, alpha = 0.5, aes(shape = iris$noerror))

#We can also look at other k values, just to see how that affects the clustering
#Since the starting assignments are random, we specify nstart = 35.
#This means that R will try 35 different random starting assignments and then select the one with the lowest within cluster variation.
irisCluster2 <- kmeans(iris[, 3:4], 2, nstart = 35)
irisCluster2

table(irisCluster2$cluster, iris$Species)

#We can see that petal length and width are similar within the same species, but vary between different species
irisCluster2$cluster <- as.factor(irisCluster2$cluster)
ggplot(iris, aes(Petal.Length, Petal.Width, color = irisCluster2$cluster)) + geom_point()

#Sepal length and width are not as easily distinguished between species
ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) + geom_point()

ggpairs(iris, columns = 1:5, mapping=aes(color=Species))

#find the errors
not.error <- unclass(iris$Species) == irisCluster2$cluster
iris$noerror <- not.error

#See errors
ggplot(iris, aes(Petal.Length, Petal.Width, color = irisCluster2$cluster)) +
  geom_point(size = 3, alpha = 0.5, aes(shape = iris$noerror))

irisCluster5 <- kmeans(iris[, 3:4], 5, nstart = 35)
irisCluster5

table(irisCluster5$cluster, iris$Species)

#We can see that petal length and width are similar within the same species, but vary between different species
irisCluster5$cluster <- as.factor(irisCluster2$cluster)
ggplot(iris, aes(Petal.Length, Petal.Width, color = irisCluster5$cluster)) + geom_point()

#Sepal length and width are not as easily distinguished between species
ggplot(iris, aes(Sepal.Length, Sepal.Width, color = Species)) + geom_point()

ggpairs(iris, columns = 1:5, mapping=aes(color=Species))

#find the errors
not.error <- unclass(iris$Species) == irisCluster5$cluster
iris$noerror <- not.error

#See errors
ggplot(iris, aes(Petal.Length, Petal.Width, color = irisCluster5$cluster)) +
  geom_point(size = 3, alpha = 0.5, aes(shape = iris$noerror))

# Let's see what the total distance is between data points and cluster centers

# initialize distance to zero
csum = 0

# for each data point: add the distance between its point and its cluster center
for (i in 1:nrow(iris)) {
  csum = csum + dist(rbind(iris[i,1:4],irisCluster$centers[irisCluster$cluster[i],]))
}

# get the total
csum[1]

#Now, let's compare the clusters with the species.
#We can only do this because we happen to know the species of each data point, usually this isn't an option
table(irisCluster$cluster, iris$Species)

#Let's try using only petal length and petal width
irisClusterPET <- kmeans(iris[,3:4], 2, nstart = 35)

#Again, we can compare the clusters with the species
table(irisClusterPET$cluster, iris$Species)

#We can see the cluster centroids, the clusters that each data point was assigned to, and the within cluster variation.
# Here's an example using a 3-cluster solution with just the petal factors
irisClusterPET

ggplot(iris, aes(Petal.Length, Petal.Width, color = irisClusterPET$cluster)) + geom_point()


newton.raphson <- function(f, ..., xguess=0, tol = 1e-5, n = 1000) {
    ## use newton raphson to find x where f(x, ...) = 0
    ## where "..." is a list of additional arguments needed by f, if any
    ## starts search from xguess

    ## following modified from https://rpubs.com/aaronsc32/newton-raphson-method
    library(numDeriv) # Package for computing f'(x)

    x0 <- xguess # Set start value to supplied guess
    k <- n       # Initialize for iteration results

    ## Check to see if xguess result in 0
    if (f(x0, ...) == 0.0) return(x0)

    ## iterate to find where f(x, ...) = 0
    for (i in 1:n) {
        dx <- genD(func = f, ..., x = x0)$D[1] # First-order derivative f'(x0)
        x1 <- x0 - (f(x0, ...) / dx)           # Calculate next guess x1
        k[i] <- x1                        # Store x1
        ## Once the difference between x0 and x1 becomes sufficiently small, output the results.
        if (abs(x1 - x0) < tol) {
            root.approx <- tail(k, n=1)
            res <- list('root approximation' = root.approx, 'iterations' = k)
            return(res)
        }
        ## If Newton-Raphson has not yet reached convergence set x1 as x0 and continue
        x0 <- x1
    }
    print('Too many iterations in method')
}

##  xtol_upper <- newton.raphson(function(x, parms=jparms, z=ztol_upper) john_z(x, parms) - z,
##                               xguess = xmax, tol=1E-10)


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

##### 8.3 ######
eigen(as.matrix(rbind(c(2,0,0),c(0,4,0),c(0,0,4))))

##### 8.6 #####
s = as.matrix(cbind(c(7476.45,303.62),c(303.62,26.19)))
eigen = eigen(s)

xbar =c(155.6,14.7)
plot(ellipse(s,centre =xbar),type = 'l',xlim=c(-100,400),ylim=c(0,30),xlab = "X1",ylab = "X2",main = "constant density ellipse")
points(xbar[1],xbar[2],pch = 17)
c = sqrt(1.4)
ax1=c*sqrt(eigen$values[1])*eigen$vectors[,1]
ax2=c*sqrt(eigen$values[2])*eigen$vectors[,2]
lines(c(xbar[1]-ax1[1],xbar[1]+ax1[1]),c(xbar[2]-ax1[2],xbar[2]+ax1[2]),lty=1)
lines(c(xbar[1]-ax2[1], xbar[1]+ax2[1]),c(xbar[2]-ax2[2],xbar[2]+ax2[2]),lty=2)
legend(x = "topleft", c("y1","y2"), lty = c(1,2))

##### 8.7 #####
p  = cov2cor(s)
eigen = eigen(p)

##### 8.18 #####
library(readr)
e8_18 <- read_delim("e8_18.txt", " ", escape_double = FALSE, trim_ws = TRUE)
nation = e8_18[,1]
X = as.matrix(e8_18[,2:8])
r = cor(X)
eigen = eigen(r)
firstpc = -1*eigen$vectors[,1]
stdX  <- scale(X)
new = stdX%*%firstpc
nation[(sort.int(new,index.return = TRUE))$ix,]

##### 8.27 #####
#assuming PCA output is based on correlation matrix (or variables of unit variance)
pc_correlations <- function(pca_output) {
  p <- ncol(pca_output$rotation)
  pccor=matrix(NA, nrow=p, ncol=p)
  for(i in 1:p){
    for(k in 1:p){
      pccor[k,i]=pca_output$rotation[k,i]*pca_output$sdev[i]
    }
  }
  colnames(pccor) <- paste0("PC", 1:p)
  rownames(pccor) <- rownames(pca_output$rotation)
  pccor
}
e8_27 <- read_delim("e8_27.txt",
                    " ", escape_double = FALSE, trim_ws = TRUE)
X = scale(as.matrix(e8_27))
pca <- prcomp(x = X, retx = TRUE, center = TRUE, scale. = TRUE)
summary(pca)
pc_correlations(pca)
screeplot(pca, type = "lines", pch = 19,
          main = "Screeplot of pulp and paper properties Data")
e8_27$y1 = X%*%pca$rotation[,1]
e8_27$y2 = X%*%pca$rotation[,2]
ggplot(data = e8_27, aes(x = y2, y = y1)) + geom_point()+ggtitle("Scatterplot of Y1hat and Y2hat")