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


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

}


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


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


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


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


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


### 6.2-2

experData <- c(28, 32, 15, 14, 38, 43, 19)
nSamples <- length(experData)
experMean <- mean(experData)

chiSquare <- sum((experData - experMean)^2 / experMean)
print(chiSquare)

### df = r - k - 1 = 7 - 1 = 6
chiSquareCritical <- qchisq(0.95, nSamples-1, ncp=0, lower.tail=TRUE, log.p=FALSE)
print(chiSquareCritical)

### chiSquare = 28.88889  ->  H0 is rejected (the dataset is not uniformly distributed)


# 2.2 a)
'''
Install the R-package astsa, load the package and the dataset varve. You may use
the following code:
	install.packages("astsa")
	library(astsa)
	data(varve)
Plot the glacial varve data.
The time series exhibits some nonstationarity that can be improved by transforming to
logarithms and some additional nonstationarity that can be corrected by
differencing the logarithms.
'''

install.packages("astsa")
library(astsa)
data(varve)

plot(varve)

#b)
'''
Argue that the glacial varves series, say Xt,
exhibits heteroscedasticity by computing the sample variance over the first half and the second half of the data.
Argue that the transformation Yt = log Xt stabilizes the variance over the series.
Plot the histograms of Xt and Yt to see whether the approximation to normality
is improved by transforming the data.
'''

hist(varve, breaks = 10)
#Not so different
for (i in c(0:9)){
	sample = sample.int(n=length(varve), size=0.5*length(varve))
	print(var(varve[sample]))
	print(var(varve[-sample]))
	print("********")
}

#different variance
subset = seq(from = 1,to = length(varve)/2, by = 1)
var(varve[subset])
var(varve[-subset])

#log-transformation
y = log(varve)
par(mfrow=c(1,2))
hist(y, breaks = 20, prob=TRUE)
lines(dt <- seq(0,150,0.1), dnorm(dt, mean(y), sd(y)), col=2, lty=2)
hist(varve, breaks=10, prob=TRUE)
lines(dt <- seq(0,150,0.1), dnorm(dt, mean(varve),sd(varve)), col=2, lty=2)

'''
heteroscedasticity is the variability of a variable is unequal across the range of values of a second variable that predicts it
After log transform - the variable is symmetic about its mean - so more normal.
'''

#c) Plot the series Yt
plot(log(varve),lty=1)

#d) Examine the sample ACF of Yt and comment.
acf(log(varve), lag.max= 40))
acf(log(varve), lag.max= 150))
acf(varve, lag.max= 150))

#looking at plot in c) Y_t oscilates, acf(y) oscilates and acf is declining
#So there is trend and seasonality

#e)
'''
Compute the difference Ut = Yt - Yt−1 , examine its time plot and sample ACF,
and argue that differencing the logged varve data produces a reasonably stationary
series. Can you think of a practical interpretation for Ut ?
'''

#U_t is the differenced (differenciated) time-series of Y_t - so without trend
U_t_x= diff(varve, lag = 1)
plot(U_t_x)
U_t= diff(y, lag = 1)
plot(U_t)

acf(U_t, lag.max=150)

#U_t is the definition of derivative when h=1. Since time discrete this is smallest h.

#f)
'''
Based on the sample ACF of the differenced transformed series computed in (d),
argue that the model in (1) below might be reasonable.

Assume U_t = mu + Z_t + theta*Z_t-1

is stationary when the inputs Zt are assumed independent with mean 0 and variance sigma_z**2
Then, show ACVF: (1+theta**2) , h=0, theta*sima_z**2, h=1, 0 else
'''

#see paper solution - its a MA(1) processs

# g)
'''
Based on part (f), use ρbU (1) and the estimate of the variance of Ut
, γ_U (1) ), to
derive estimates of θ and σ
2
Z
. This is an application of the method of moments
from classical statistics, where estimators of the parameters are derived by equating
sample moments to theoretical moments. You can calculate the empirical autocorrelation and autocovariance functions
using the acf function, by using the following syntax
	acf(u, type = "correlation")
	acf(u, type = "covariance")
'''

acf(U_t, type = "correlation")
acf(U_t, type = "covariance")

(a<-acf(U_t, plot=FALSE)$acf[2])
(b<-acf(U_t, type="covariance", plot=FALSE)$acf[1])
(theta <- (1 + c(-1,1) * sqrt(1 - 4 * a^2))/(2 * a))
(sigma2<- b / (1 + theta^2))
arima(U_t, order=c(0,0,1), include.mean=FALSE)

########
p <- as.vector(acf(Ut, type = "correlation", lag.max = 1, plot=FALSE)$acf[2]) #rho
g <- as.vector(acf(Ut, type = "covariance", lag.max = 0, plot=FALSE)$acf) #g=gamma

theta <- c((1+sqrt(1-4*p^2))/(2*p),(1-sqrt(1-4*p^2))/(2*p))
sigmasq <- g/(1+theta^2)

theta
sigmasq
#Need |theta| < 1 to be invertible, thus the solution is
#theta hat = -0.494 and sigmasq hat = 0.266


# Goal: Simulation to study size and power in a simple problem.

set.seed(101)

# The data generating process: a simple uniform distribution with stated mean
dgp <- function(N,mu) {runif(N)-0.5+mu}

# Simulate one FIXED hypothesis test for H0:mu=0, given a true mu for a sample size N
one.test <- function(N, truemu) {
  x <- dgp(N,truemu)
  muhat <- mean(x)
  s <- sd(x)/sqrt(N)
  # Under the null, the distribution of the mean has standard error s
  threshold <- 1.96*s
  (muhat < -threshold) || (muhat > threshold)
} # Return of TRUE means reject the null

# Do one experiment, where the fixed H0:mu=0 is run Nexperiments times with a sample size N.
# We return only one number: the fraction of the time that H0 is rejected.
experiment <- function(Nexperiments, N, truemu) {
  sum(replicate(Nexperiments, one.test(N, truemu)))/Nexperiments
}

# Measure the size of a test, i.e. rejections when H0 is true
experiment(10000, 50, 0)
# Measurement with sample size of 50, and true mu of 0.

# Power study: I.e. Pr(rejection) when H0 is false
# (one special case in here is when the H0 is actually true)

muvalues <- seq(-.15,.15,.01)
  # When true mu < -0.15 and when true mu > 0.15,
  # the Pr(rejection) veers to 1 (full power) and it's not interesting.

# First do this with sample size of 50
results <- NULL
for (truth in muvalues) {
  results <- c(results, experiment(10000, 50, truth))
}
par(mai=c(.8,.8,.2,.2))
plot(muvalues, results, type="l", lwd=2, ylim=c(0,1),
     xlab="True mu", ylab="Pr(Rejection of H0:mu=0)")
abline(h=0.05, lty=2)

# Now repeat this with sample size of 100 (should yield a higher power)
results <- NULL
for (truth in muvalues) {
  results <- c(results, experiment(10000, 100, truth))
}
lines(muvalues, results, lwd=2, col="blue")
legend(x=-0.15, y=.2, lwd=c(2,1,2), lty=c(1,2,1), cex=.8,
       col=c("black","black","blue"), bty="n",
       legend=c("N=50", "Size, 0.05", "N=100"))

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


# Introduction to Computational Finance and Financial Econometrics
# Assignment 2
# Paul-Gabriel Müller
# Topic: Probability

# question 1:
# Suppose X is a normally distributed random variable with mean 0.05 and variance (0.10)2. Compute the following.
# a) Pr(X>.10)
1- pnorm(0.1, mean=0.05, sd=0.1)

# question 2:
# Suppose X is a normally distributed random variable with mean 0.05 and variance (0.10)2. Compute the following.
# Pr(X<−.10)
pnorm(-0.1, mean=0.05, sd=0.1)

# question 3:
# Suppose X is a normally distributed random variable with mean 0.05 and variance (0.10)2. Compute the following.
# c) Pr(−0.05<X<0.15)
x = pnorm(-0.05, mean=0.05, sd=0.1)
y = pnorm(0.15, mean=0.05, sd=0.1)
y-x

#question 4:
#1% quantile, q.01
qnorm(0.01, mean=0.05, sd=0.1)

#question 5:
#  5% quantile, q.05
qnorm(0.05, mean=0.05, sd=0.1)

#question 6:
# 95% quantile, q.95
qnorm(0.95, mean=0.05, sd=0.1)

#question 7:
# 95% quantile, q.95
qnorm(0.99, mean=0.05, sd=0.1)

# question 8:
# Let X denote the monthly return on Microsoft Stock and let Y denote the monthly return on Starbucks stock.
#Assume that X∼N(0.05,(0.10)2) and Y∼N(0.025,(0.05)2).
# Using a grid of values between –0.25 and 0.35, plot the normal curves
# for X and Y. Make sure that both normal curves are on the same plot.
# Which stock has the higher risk?

intervals <- seq(-0.25, 0.35,length=100)
hx <- dnorm(intervals,0.05,0.1)
hy <- dnorm(intervals,0.025,0.05)
plot(intervals, hx, type="l", col="blue")
lines(intervals, hy, type="l", col="green")

# Question 9
# Let R denote the simple monthly return on Microsoft stock and let W0 denote the initial wealth to be invested
# over the month. Assume that R∼N(0.04,(0.09)^2)) and that W0=$100,000
# Determine the 1% and 5% value-at-risk (VaR) over the month on the investment.
# That is, determine the loss in investment value that may occur over the next month with 1% probability
# and with 5% probability.

w0 = 100000
qnorm(0.01, mean=0.04, sd=0.09) * w0
qnorm(0.05, mean=0.04, sd=0.09) * w0

# Question 10
# Let the r denote the continuously compounded monthly return on Microsoft stock and let W0
# denote the initial wealth to be invested over the month. Assume that r∼iid N(0.04,(0.09)2)
# and that W0=$100,000.
# Determine the 1% and 5% value-at-risk (VaR) over the month on the investment.
# That is, determine the loss in investment value that may occur over the next month
#  with 1% probability and with 5% probability.
#(Hint: compute the 1% and 5% quantile from the Normal distribution for r and then convert
# continuously compounded return quantile to a simple return quantile using the transformation R=er−1)

w0 = 100000;
# R = (e^r) -1 <=> r = ln(1+R)
r.01 = qnorm(0.01, mean=0.04, sd=0.09)
r.05 = qnorm(0.05, mean=0.04, sd=0.09)

R.01 = exp(r.01) -1
R.05 = exp(r.05) -1

R.01*w0
R.05*w0

#Question 11
# For the following questions:

# Consider a one month investment in two Northwest stocks: Amazon and Costco.
# Suppose you buy Amazon and Costco at the end of September at P(A,t−1)=$38.23, P(C,t−1)=$41.11 and then sell
# at the end of October for P(A,t)=$41.29, P(C,t)=$41.74. (Note: these are actual closing prices for 2004 taken
# from Yahoo!)
# What are the simple monthly returns for the two stocks?

R.A = (41.29 - 38.23) / 38.23
R.C = (41.74 - 41.11) / 41.11
# Question 12
# What are the continuously compounded returns for the two stocks?
r.A = log(1 + R.A)
r.C = log(1 + R.C)
r.A
r.C

# Question 13
# Suppose Amazon paid a $0.10 per share cash dividend at the end of October.
# What is the monthly simple total return on Amazon? What is the monthly dividend yield?

Rsimple = (41.29 + 0.1 - 38.23) / 38.23
divYield = 0.01 / 38.23
Rsimple * 100
divYield * 100

#question 14
# Suppose the monthly returns on Amazon from question 12 above are the same every month for 1 year.
# Compute the simple annual returns, as well as the continuously compounded annual returns.
# r is always smaller than R
R.month = (41.29 - 38.23) / 38.23
R.year = ((1+R.month)^12) -1
R.year*100

r.year = log(1+R.year)
r.year*100
# Question 15
Question 15
# At the end of September 2004, supposed you have $10,000 to invest in Amazon and Costco over the next month.
# If you invest $8,000 in Amazon and $2,000 in Costco, what are your portfolio shares, xA and xC.

# Question 16
# Continuing with the previous question, compute the monthly simple return on the portfolio.
# Assume than no dividends are paid.

R.total = 0.8 * R.A + 0.2*R.C
R.total*100


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

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

require("minpack.lm") # for Levenberg-Marquardt nlls fitting

powMod <- function(x, a, b) {
 return(a * x^b)
}

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

head(MyData)

Data2Fit <- subset(MyData,Suborder == "Anisoptera")

Data2Fit <- Data2Fit[!is.na(Data2Fit$TotalLength),] # remove NA's

plot(Data2Fit$TotalLength, Data2Fit$BodyWeight)

library("ggplot2")

ggplot(Data2Fit, aes(x = TotalLength, y = BodyWeight)) +
geom_point(size = (3),color="red") + theme_bw() +
labs(y="Body mass (mg)", x = "Wing length (mm)")

PowFit <- nlsLM(BodyWeight ~ powMod(TotalLength, a, b), data = Data2Fit, start = list(a = .1, b = .1))

summary(PowFit)

Lengths <- seq(min(Data2Fit$TotalLength),max(Data2Fit$TotalLength),len=200)

coef(PowFit)["a"]
coef(PowFit)["b"]

Predic2PlotPow <- powMod(Lengths,coef(PowFit)["a"],coef(PowFit)["b"])

Exercisesplot(Data2Fit$TotalLength, Data2Fit$BodyWeight)
lines(Lengths, Predic2PlotPow, col = 'blue', lwd = 2.5)

confint(PowFit)

QuaFit <- lm(BodyWeight ~ poly(TotalLength,2), data = Data2Fit)

Predic2PlotQua <- predict.lm(QuaFit, data.frame(TotalLength = Lengths))

plot(Data2Fit$TotalLength, Data2Fit$BodyWeight)
lines(Lengths, Predic2PlotPow, col = 'blue', lwd = 2.5)
lines(Lengths, Predic2PlotQua, col = 'red', lwd = 2.5)

RSS_Pow <- sum(residuals(PowFit)^2) # Residual sum of squares
TSS_Pow <- sum((Data2Fit$BodyWeight - mean(Data2Fit$BodyWeight))^2) # Total sum of squares
RSq_Pow <- 1 - (RSS_Pow/TSS_Pow) # R-squared value

RSS_Qua <- sum(residuals(QuaFit)^2) # Residual sum of squares
TSS_Qua <- sum((Data2Fit$BodyWeight - mean(Data2Fit$BodyWeight))^2) # Total sum of squares
RSq_Qua <- 1 - (RSS_Qua/TSS_Qua) # R-squared value

RSq_Pow
RSq_Qua

n <- nrow(Data2Fit) #set sample size
pPow <- length(coef(PowFit)) # get number of parameters in power law model
pQua <- length(coef(QuaFit)) # get number of parameters in quadratic model

AIC_Pow <- n + 2 + n * log((2 * pi) / n) + n * log(RSS_Pow) + 2 * pPow
AIC_Qua <- n + 2 + n * log((2 * pi) / n) + n * log(RSS_Qua) + 2 * pQua
AIC_Pow - AIC_Qua

AIC(PowFit) - AIC(QuaFit)

alb <- read.csv(file="../data/albatross_grow.csv")
alb <- subset(x=alb, !is.na(alb$wt))
plot(alb$age, alb$wt, xlab="age (days)", ylab="weight (g)", xlim=c(0, 100))

logistic1 <- function(t, r, K, N0){
 N0 * K * exp(r * t)/(K+N0 * (exp(r * t)-1))
}

vonbert.w <- function(t, Winf, c, K){
 Winf * (1 - exp(-K * t) + c * exp(-K * t))^3
}

scale <- 4000

alb.lin <- lm(wt/scale ~ age, data = alb)

alb.log <- nlsLM(wt/scale~logistic1(age, r, K, N0), start=list(K=1, r=0.1, N0=0.1), data=alb)

alb.vb <- nlsLM(wt/scale~vonbert.w(age, Winf, c, K), start=list(Winf=0.75, c=0.01, K=0.01), data=alb)

ages <- seq(0, 100, length=1000)

pred.lin <- predict(alb.lin, newdata = list(age=ages)) * scale

pred.log <- predict(alb.log, newdata = list(age=ages)) * scale

pred.vb <- predict(alb.vb, newdata = list(age=ages)) * scale

plot(alb$age, alb$wt, xlab="age (days)", ylab="weight (g)", xlim=c(0,100))
lines(ages, pred.lin, col=2, lwd=2)
lines(ages, pred.log, col=3, lwd=2)
lines(ages, pred.vb, col=4, lwd=2)

legend("topleft", legend = c("linear", "logistic", "Von Bert"), lwd=2, lty=1, col=2:4)

par(mfrow=c(3,1), bty="n")
plot(alb$age, resid(alb.lin), main="LM resids", xlim=c(0,100))
plot(alb$age, resid(alb.log), main="Logisitic resids", xlim=c(0,100))
plot(alb$age, resid(alb.vb), main="VB resids", xlim=c(0,100))

n <- length(alb$wt)
list(lin=signif(sum(resid(alb.lin)^2)/(n-2 * 2), 3),
 log= signif(sum(resid(alb.log)^2)/(n-2 * 3), 3),
 vb= signif(sum(resid(alb.vb)^2)/(n-2 * 3), 3))

aedes <- read.csv(file="../data/aedes_fecund.csv")

plot(aedes$T, aedes$EFD, xlab="temperature (C)", ylab="Eggs/day")

quad1 <- function(T, T0, Tm, c){
 c * (T-T0) * (T-Tm) * as.numeric(T<Tm) * as.numeric(T>T0)
}

briere <- function(T, T0, Tm, c){
 c * T * (T-T0) * (abs(Tm-T)^(1/2)) * as.numeric(T<Tm) * as.numeric(T>T0)
}

scale <- 20

aed.lin <- lm(EFD/scale ~ T, data=aedes)

aed.quad <- nlsLM(EFD/scale~quad1(T, T0, Tm, c), start=list(T0=10, Tm=40, c=0.01), data=aedes)

aed.br <- nlsLM(EFD/scale~briere(T, T0, Tm, c), start=list(T0=10, Tm=40, c=0.1), data=aedes)

t <- seq(0, 22, 2)
N <- c(32500, 33000, 38000, 105000, 445000, 1430000, 3020000, 4720000, 5670000, 5870000, 5930000, 5940000)

set.seed(1234) # set seed to ensure you always get the same random sequence

data <- data.frame(t, N * (1 + rnorm(length(t), sd = 0.1))) # add some random error

names(data) <- c("Time", "N")

head(data)

ggplot(data, aes(x = Time, y = N)) +
 geom_point(size = 3) +
 labs(x = "Time (Hours)", y = "Population size (cells)")

data$LogN <- log(data$N)

# visualise
ggplot(data, aes(x = t, y = LogN)) +
 geom_point(size = 3) +
 labs(x = "Time (Hours)", y = "log(cell number)")

(data[data$Time == 10,]$LogN - data[data$Time == 6,]$LogN)/(10-6)

diff(data$LogN)

max(diff(data$LogN))/2 # 2 is the difference in any successive pair of timepoints

lm_growth <- lm(LogN ~ Time, data = data[data$Time > 2 & data$Time < 12,])
summary(lm_growth)

logistic_model <- function(t, r_max, K, N_0){ # The classic logistic equation
 return(N_0 * K * exp(r_max * t)/(K + N_0 * (exp(r_max * t) - 1)))
}

# first we need some starting parameters for the model
N_0_start <- min(data$N) # lowest population size
K_start <- max(data$N) # highest population size
r_max_start <- 0.62 # use our estimate from the OLS fitting from above

fit_logistic <- nlsLM(N ~ logistic_model(t = Time, r_max, K, N_0), data,
      list(r_max=r_max_start, N_0 = N_0_start, K = K_start))

summary(fit_logistic)

timepoints <- seq(0, 22, 0.1)

logistic_points <- logistic_model(t = timepoints,
         r_max = coef(fit_logistic)["r_max"],
         K = coef(fit_logistic)["K"],
         N_0 = coef(fit_logistic)["N_0"])
df1 <- data.frame(timepoints, logistic_points)
df1$model <- "Logistic equation"
names(df1) <- c("Time", "N", "model")

ggplot(data, aes(x = Time, y = N)) +
 geom_point(size = 3) +
 geom_line(data = df1, aes(x = Time, y = N, col = model), size = 1) +
 theme(aspect.ratio=1)+ # make the plot square
 labs(x = "Time", y = "Cell number")

ggplot(data, aes(x = Time, y = LogN)) +
 geom_point(size = 3) +
 geom_line(data = df1, aes(x = Time, y = log(N), col = model), size = 1) +
 theme(aspect.ratio=1)+
 labs(x = "Time", y = "log(Cell number)")

ggplot(data, aes(x = N, y = LogN)) +
 geom_point(size = 3) +
 theme(aspect.ratio = 1)+
 labs(x = "N", y = "log(N)")

gompertz_model <- function(t, r_max, K, N_0, t_lag){ # Modified gompertz growth model (Zwietering 1990)
 return(N_0 + (K - N_0) * exp(-exp(r_max * exp(1) * (t_lag - t)/((K - N_0) * log(10)) + 1)))
}

N_0_start <- min(data$LogN) # lowest population size, note log scale
K_start <- max(data$LogN) # highest population size, note log scale
r_max_start <- 0.62 # use our previous estimate from the OLS fitting from above
t_lag_start <- data$Time[which.max(diff(diff(data$LogN)))] # find last timepoint of lag phase

diff(data$LogN) # same as what we did above - get differentials

diff(diff(data$LogN)) # get the differentials of the differentials (approx 2nd order derivatives)

which.max(diff(diff(data$LogN))) # find the timepoint where this 2nd order derivative really takes off

data$Time[which.max(diff(diff(data$LogN)))] # This then is a good guess for the last timepoint of the lag phase

fit_gompertz <- nlsLM(LogN ~ gompertz_model(t = Time, r_max, K, N_0, t_lag), data,
      list(t_lag=t_lag_start, r_max=r_max_start, N_0 = N_0_start, K = K_start))

summary(fit_gompertz)

timepoints <- seq(0, 24, 0.1)

logistic_points <- log(logistic_model(t = timepoints,
          r_max = coef(fit_logistic)["r_max"],
          K = coef(fit_logistic)["K"],
          N_0 = coef(fit_logistic)["N_0"]))

gompertz_points <- gompertz_model(t = timepoints,
         r_max = coef(fit_gompertz)["r_max"],
         K = coef(fit_gompertz)["K"],
         N_0 = coef(fit_gompertz)["N_0"],
         t_lag = coef(fit_gompertz)["t_lag"])

df1 <- data.frame(timepoints, logistic_points)
df1$model <- "Logistic model"
names(df1) <- c("Time", "LogN", "model")

df2 <- data.frame(timepoints, gompertz_points)
df2$model <- "Gompertz model"
names(df2) <- c("Time", "LogN", "model")

model_frame <- rbind(df1, df2)

ggplot(data, aes(x = Time, y = LogN)) +
 geom_point(size = 3) +
 geom_line(data = model_frame, aes(x = Time, y = LogN, col = model), size = 1) +
 theme_bw() + # make the background white
 theme(aspect.ratio=1)+ # make the plot square
 labs(x = "Time", y = "log(Abundance)")

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

set.seed(54321)

## 50 draws with each p
pp <- c(0.1, 0.5, 0.8)
N <- 20
reps <- 50

## histograms + density here
x <- seq(0, 50, by=1)
par(mfrow=c(1,3), bty="n")

# Write more code here

## MOM estimators for 3 simulated sets

## MoM estimates, histogram

pp <- .25
N <- 10
reps <- 10
## Make one set of data

## the likelihood is always exactly zero
## at p=0,1, so I skip those values
ps <- seq(0.01, 0.99, by=0.01)

## Likelihood

## MLE/MoM estimators

## now plot the negative log likelihood profile

WL.data <- read.csv("../data/MidgeWingLength.csv")
Y <- WL.data$WingLength
n <- length(Y)

hist(Y,breaks=10,xlab="Wing Length (mm)")

m <- sum(Y)/n
s2 <- sum((Y-m)^2)/(n-1)
round(c(m, s2), 3)

x <- seq(1.4,2.2, length=50)
hist(Y,breaks=10,xlab="Wing Length (mm)", xlim=c(1.4, 2.2), freq=FALSE)
lines(x, dnorm(x, mean=m, sd=sqrt(s2)), col=2)

tau.post <- function(tau, tau0, n){n * tau + tau0}
mu.post <- function(Ybar, mu0, sig20, sig2, n){
 weight <- sig2+n * sig20

 return(n * sig20 * Ybar/weight + sig2 * mu0/weight)
}

mu0 <- 1.9
s20 <- 0.8
s2 <- 0.025 ## "true" variance

mp <- mu.post(Ybar=m, mu0=mu0, sig20=s20, sig2=s2, n=n)
tp <- tau.post(tau=1/s2, tau0=1/s20, n=n)

x <- seq(1.3,2.3, length=1000)
hist(Y,breaks=10,xlab="Wing Length (mm)", xlim=c(1.3, 2.3),
  freq=FALSE, ylim=c(0,8))
lines(x, dnorm(x, mean=mu0, sd=sqrt(s20)), col=2, lty=2, lwd=2) ## prior
lines(x, dnorm(x, mean=mp, sd=sqrt(1/tp)), col=4, lwd=2) ## posterior
legend("topleft", legend=c("prior", "posterior"), col=c(2,4), lty=c(2,1), lwd=2)

# Load libraries
require(rjags) # does the fitting
require(coda) # makes diagnostic plots
##require(mcmcplots) # another option for diagnostic plots

model1 <- "model{

 ## Likelihood
 for(i in 1:n){
 Y[i] ~ dnorm(mu,tau)
 }

 ## Prior for mu
 mu  ~ dnorm(mu0,tau0)

} ## close model
"

model <- jags.model(textConnection(model1),
     n.chains = 1, ## usually do more
     data = list(Y=Y,n=n, ## data
        mu0=mu0, tau0=1/s20, ## hyperparams
        tau = 1/s2 ## known precision
        ),
     inits=list(mu=3) ## setting an starting val
     )

samp <- coda.samples(model,
  variable.names=c("mu"),
  n.iter=1000, progress.bar="none")

plot(samp)

update(model, 10000, progress.bar="none") # Burnin for 10000 samples

samp <- coda.samples(model,
  variable.names=c("mu"),
  n.iter=20000, progress.bar="none")

plot(samp)

summary(samp)

x <- seq(1.3,2.3, length=1000)
hist(samp[[1]], xlab="mu", xlim=c(1.3, 2.3),
  freq=FALSE, ylim=c(0,8), main ="posterior samples")
lines(x, dnorm(x, mean=mu0, sd=sqrt(s20)), col=2, lty=2, lwd=2) ## prior
lines(x, dnorm(x, mean=mp, sd=sqrt(1/tp)), col=4, lwd=2) ## posterior
legend("topleft", legend=c("prior", "analytic posterior"), col=c(2,4), lty=c(2,1), lwd=2)

model2 <- "model{

 # Likelihood
 for(i in 1:n){
 Y[i] ~ dnorm(mu,tau) T(0,) ## truncates at 0
 }

 # Prior for mu
 mu ~ dnorm(mu0,tau0)

 # Prior for the precision
 tau ~ dgamma(a, b)

 # Compute the variance
 s2  <- 1/tau
}"

## hyperparams for tau
a <- 0.01
b <- 0.01

m2 <- jags.model(textConnection(model2),
     n.chains = 1,
     data = list(Y=Y, n=n,
        mu0=mu0, tau0=1/s20, ## mu hyperparams
        a=a, b=b ## tau hyperparams
        ),
     inits=list(mu=3, tau=10) ## starting vals
    )

samp <- coda.samples(m2,
  variable.names=c("mu","s2"),
  n.iter=1000, progress.bar="none")

plot(samp)

summary(samp)

par(mfrow=c(1,2), bty="n")

hist(samp[[1]][,1], xlab="samples of mu", main="mu")
lines(x, dnorm(x, mean=mu0, sd=sqrt(s20)),
  col=2, lty=2, lwd=2) ## prior

x2 <- seq(0, 200, length=1000)
hist(1/samp[[1]][,2], xlab="samples of tau", main="tau")
lines(x2, dgamma(x2, shape = a, rate = b),
  col=2, lty=2, lwd=2) ## prior

plot(as.numeric(samp[[1]][,1]), samp[[1]][,2], xlab="mu", ylab="s2")

require(R2jags) # fitting
require(coda) # diagnostic plots
set.seed(1234)

Aaeg.data <- read.csv("../data/AeaegyptiTraitData.csv")

head(Aaeg.data)

mu.data <- subset(Aaeg.data, trait.name == "mu")
lf.data <- subset(Aaeg.data, trait.name == "1/mu")
par(mfrow=c(1,2), bty="l")
plot(trait ~ T, data = mu.data, ylab="mu")
plot(trait ~ T, data = lf.data, ylab="1/mu")

mu.data.inv <- mu.data # make a copy of the mu data
mu.data.inv$trait <- 1/mu.data$trait # take the inverse of the trait values to convert mu to lifespan
lf.data.comb <- rbind(mu.data.inv, lf.data) # combine both lifespan data sets together

plot(trait ~ T, data = lf.data.comb, ylab="1/mu")

sink("quad.txt") # create a file
cat("
 model{

 ## Priors
 cf.q ~ dunif(0, 1)
 cf.T0 ~ dunif(0, 24)
 cf.Tm ~ dunif(25, 45)
 cf.sigma ~ dunif(0, 1000)
 cf.tau <- 1 / (cf.sigma * cf.sigma)

 ## Likelihood
 for(i in 1:N.obs){
 trait.mu[i] <- -1 * cf.q * (temp[i] - cf.T0) * (temp[i] - cf.Tm) * (cf.Tm > temp[i]) * (cf.T0 < temp[i])
 trait[i] ~ dnorm(trait.mu[i], cf.tau)
 }

 ## Derived Quantities and Predictions
 for(i in 1:N.Temp.xs){
 z.trait.mu.pred[i] <- -1 * cf.q * (Temp.xs[i] - cf.T0) * (Temp.xs[i] - cf.Tm) * (cf.Tm > Temp.xs[i]) * (cf.T0 < Temp.xs[i])
 }
 } # close model
",fill=T)
sink()

# Parameters to Estimate
parameters <- c("cf.q", "cf.T0", "cf.Tm","cf.sigma", "z.trait.mu.pred")

# Initial values for the parameters
inits <- function(){list(
 cf.q = 0.01,
 cf.Tm = 35,
 cf.T0 = 5,
 cf.sigma = rlnorm(1))}

# MCMC Settings: number of posterior dist elements = [(ni - nb) / nt ] * nc
ni <- 25000 # number of iterations in each chain
nb <- 5000 # number of 'burn in' iterations to discard
nt <- 8 # thinning rate - jags saves every nt iterations in each chain
nc <- 3 # number of chains

# Temperature sequence for derived quantity calculations
Temp.xs <- seq(0, 45, 0.2)
N.Temp.xs <- length(Temp.xs)

### Fitting the trait thermal response; Pull out data columns as vectors
data <- lf.data.comb # this lets us reuse the same generic code: we only change this first line
trait <- data$trait
N.obs <- length(trait)
temp <- data$T

# Bundle all data in a list for JAGS
jag.data <- list(trait = trait, N.obs = N.obs, temp = temp, Temp.xs = Temp.xs, N.Temp.xs = N.Temp.xs)

lf.fit <- jags(data=jag.data, inits=inits, parameters.to.save=parameters,
    model.file="quad.txt", n.thin=nt, n.chains=nc, n.burnin=nb,
    n.iter=ni, DIC=T, working.directory=getwd())

lf.fit.mcmc <- as.mcmc(lf.fit)

lf.fit$BUGSoutput$summary[1:5,]

plot(lf.fit.mcmc[,c(1,3,4)])

plot(trait ~ T, xlim = c(0, 45), ylim = c(0,42), data = lf.data.comb, ylab = "Lifespan for Ae. aegypti", xlab = "Temperature")
lines(lf.fit$BUGSoutput$summary[6:(6 + N.Temp.xs - 1), "2.5%"] ~ Temp.xs, lty = 2)
lines(lf.fit$BUGSoutput$summary[6:(6 + N.Temp.xs - 1), "97.5%"] ~ Temp.xs, lty = 2)
lines(lf.fit$BUGSoutput$summary[6:(6 + N.Temp.xs - 1), "mean"] ~ Temp.xs)

Temp.xs[which.max(as.vector(lf.fit$BUGSoutput$summary[6:(6 + N.Temp.xs - 1), "mean"]))]

lf.grad <- lf.fit$BUGSoutput$sims.list$z.trait.mu.pred
dim(lf.grad) # A matrix with 7500 iterations of the MCMC chains at 226 temperatures

require(R2jags) # does the fitting
require(coda) # makes diagnostic plots
library(IDPmisc) # makes nice colored pairs plots to look at joint posteriors

dat <- read.csv("../data/lb_ab_temps.csv")
head(dat)

d2 <- dat[which(dat$EXP==2),2:8]
d2 <- d2[which(d2$TEMP==12),]
summary(d2)

Temps <- seq(0,max(d2$DAY)-1, by=0.05)
mycol <- 1
my.ylim <- c(0, 0.5)
my.title <- "LB-AB isolate, T=12C"

plot(d2$DAY-1, d2$OD, xlim=c(0,max(Temps)), ylim=my.ylim,
 pch=(mycol+20),
 xlab="time (days)", ylab="",
 main=my.title,
 col=mycol+1, cex=1.5)

sink("jags-logistic.bug")
cat("
 model {

 ## Likelihood
 for (i in 1:N) {
  Y[i] ~ dlnorm(log(mu[i]), tau)
  mu[i] <- K * Y0/(Y0+(K-Y0) * exp(-r * t[i]))
 }

 ## Priors
 r~dexp(1000)
 K ~ dunif(0.01, 0.6)
 Y0 ~ dunif(0.09, 0.15)
 tau <- 1/sigma^2
 sigma ~ dexp(0.1)

 } # close model
 ",fill=T)
sink()

# Parameters to Estimate
parameters <- c('Y0', 'K', 'r', 'sigma')

# Initial values for the parameters
inits <- function(){list(
 Y0 = 0.1,
 K = 0.4,
 r = 0.1,
 sigma = rlnorm(1))}

# MCMC Settings: number of posterior dist elements = [(ni - nb) / nt ] * nc
ni <- 6000 # number of iterations in each chain
nb <- 1000 # number of 'burn in' iterations to discard
nt <- 1 # thinning rate - jags saves every nt iterations in each chain
nc <- 5 # number of chains

# Pull out data columns as vectors
data <- d2 # this lets us reuse the same generic code: we only change this first line
Y <- data$OD
N <- length(Y)
t <- data$DAY

# Bundle all data in a list for JAGS
jag.data <- list(Y = Y, N = N, t = t)

# Run JAGS
OD.12C <- jags(data=jag.data, inits=inits, parameters.to.save=parameters,
    model.file="jags-logistic.bug", n.thin=nt, n.chains=nc, n.burnin=nb,
    n.iter=ni, DIC=T, working.directory=getwd())

OD.12C.mcmc <- as.mcmc(OD.12C)

OD.12C$BUGSoutput$summary

plot(OD.12C.mcmc[,c(1,2,4)])

s1 <- as.data.frame(OD.12C.mcmc[[1]])
par(mfrow=c(2,2))
for(i in 2:5) acf(s1[,i], lag.max=20)

source("../code/mcmc_utils.R")

samps <- NULL
for(i in 1:nc){
 samps <- rbind(samps, as.data.frame(OD.12C.mcmc[[i]]))
}

samps <- samps[,c(5,2,3,4)]

priors <- list()
priors$names <- c("Y0", "K", "r","sigma")
priors$fun <- c("uniform", "uniform", "exp","exp")
priors$hyper <- matrix(NA, ncol=4, nrow=3)
priors$hyper[,1] <- c(0.09, 0.15, NA)
priors$hyper[,2] <- c(0.01, 0.6, NA)
priors$hyper[,3] <- c(1000, NA, NA)
priors$hyper[,4] <- c(0.1, NA, NA)

plot.hists(samps, my.par=c(2,2), n.hists=4, priors=priors, mai=c(0.5, 0.5, 0.25, 0.2))

ipairs(s1[,2:5], ztransf = function(x){x[x<1] <- 1; log2(x)})

my.logistic <- function(t, Y0, K, r){
 return(K * Y0/(Y0+(K-Y0) * exp(-r * t)))
}

ts <- seq(0, 40, length=100)
ss <- seq(1, dim(samps)[1], by=10)
my.curves <- matrix(NA, nrow=length(ss), ncol=length(ts))

for(i in 1:length(ss)){
 my.curves[i,] <- my.logistic(t=ts, Y0=samps$Y0[i], K=samps$K[i], r=samps$r[i])
}

plot(ts, my.curves[1,], col=1, type="l", ylim=c(0.09, 0.36),
  ylab="predicted OD", xlab="time (days)")
for(i in 2:length(ss)) lines(ts, my.curves[i,], col=i)

m.log <- apply(my.curves, 2, mean)
l.log <- apply(my.curves, 2, quantile, probs=0.025)
u.log <- apply(my.curves, 2, quantile, probs=0.975)

hpd.log <- NULL
for(i in 1:length(ts)){
 hpd.log <- cbind(hpd.log, as.numeric(HPDinterval(mcmc(my.curves[,i]))))
}

my.ylim <- c(0.09, 0.45)
my.title <- "LB-AB isolate, T=12C"

plot(d2$DAY-1, d2$OD, xlim=c(0,max(Temps)), ylim=my.ylim,
 pch=(mycol+20),
 xlab="time (days)", ylab="",
 main=my.title,
 col="grey", cex=1.5)
lines(ts, m.log, col=1, lwd=2)
lines(ts, l.log, col=2, lwd=2, lty=2)
lines(ts, u.log, col=2, lwd=2, lty=2)

lines(ts, hpd.log[1,], col=3, lwd=2, lty=3)
lines(ts, hpd.log[2,], col=3, lwd=2, lty=3)


#' @title e
#'
#' @description Calculates the Nash-Sutcliffe modelling efficiency (E)
#' from observed and predicted values.
#'
#' @param observed Numeric vector of observed values
#'
#' @param predicted Numeric vector of predicted values. The length shall be
#' the same as for observed.
#'
#' @return The Nash-Sutcliffe modelling efficiency (E) calculated from observed and
#' predicted values.
#'
#' @details E = 1 - sum(observed - predicted)/sum(observed - mean (observed))
#'
#' @references Nash, J. E., & Sutcliffe, J. V. (1970). River flow forecasting
#' through conceptual models part I—A discussion of principles. Journal of
#' hydrology, 10(3), 282-290.
#'
#' @examples
#' o<-1:5
#' p<-c(2,2,4,3,5)
#' e(observed=o, predicted=p)
#'
#' @export
e<-function(observed, predicted){
  return(1-(sum((observed-predicted)^2)/sum((observed-mean(observed))^2)))
}