##Loading the necessary libraries
library(deSolve)

### Rosenzweig-MacArthur model###

## ODE system to be integrated
RM <- function(t, y, parms){
    with(as.list(c(y, parms)),
         {
             dR = r*R*(1-R/K) - a*R*C/(1+a*h*R)
             dC = e*a*R*C/(1 + a*h*R) - d*C
             return(list(c(R=dR,C=dC)))
         })
}

##initial parameters
parms1 = c(r=1, K=10, a=1, h=0.1, e=0.1, d=0.1)

##initial population sizes
y0 = c(R=1,C=1)

##running the numerical solution from time 1 to 1000
out = ode(y=y0, times = seq(from=1, to=1000, by=0.5), func = RM, parms = parms1)

##plotting the solution
## In a R console the code enclosed between #'s are enough.
## For the current version of ipython it is necessary to enclose it within
## a with() statement, see https://github.com/takluyver/IRkernel/issues/23
with(.GlobalEnv, {
    #########################################################################
    matplot(x=out[,1], y=out[,2:3], type = "l", lwd=2, lty=1,
            col=c("blue", "darkgreen"), xlab="Time", ylab="Population size")
    legend("topright", legend = c("Resource","Consumer"),
           lty = 1, lwd=2, col=c("blue", "darkgreen"))
    #########################################################################
}
     )

## Phase space flow and fixed points
##first we need to calculate the coordinates for the vectors
xs = seq(from=0.9, to=1.3, length.out=7)
ys = seq(from=0.94, to=1.04, length.out=7)
coords = expand.grid(R=xs, C=ys)
## And then loop over all coordinates to calculate the derivatives at that points
dvs = matrix(NA, ncol=2, nrow=nrow(coords))
for(i in 1:nrow(coords))
    dvs[i,] = unlist(RM(t=1, y = coords[i,], parms = parms1))

##now we plot the trajectory
    plot(x=out[,2], y=out[,3], type="l", lwd=2, col="blue",
        xlab="Resource",ylab="Consumer", xlim=c(0.9,1.3), ylim=c(0.94,1.04))
    ##and add the vector field
    arrows(x0=coords[,1], y0=coords[,2], x1=coords[,1]+dvs[,1]*0.5,
           y1=coords[,2]+dvs[,2]*0.5, length=0.1, lwd=2)

# now K = 15
##Messing a little with the parameters
parms2 = c(r=1, K=15, a=1, h=0.1, e=0.1, d=0.1)

out2 = ode(y=y0, times = seq(from = 1, to = 1000, by=0.5), func = RM, parms = parms2)

##plotting the solution
with(.GlobalEnv,{
    #####################################################################################
    matplot(x=out2[,1], y=out2[,2:3], type = "l", lwd=2, lty=1,col=c("blue", "darkgreen"),
            xlab="Time", ylab="Population size")
    legend("topleft", legend = c("Resource","Consumer"), lty = 1, lwd=2,
           col=c("blue", "darkgreen"))
    #####################################################################################
    })

##calculating the vectors again
xs = seq(from=0,to=6,length.out=8)
ys = seq(from=0,to=2,length.out=8)
coords = expand.grid(R=xs,C=ys)
dvs = matrix(NA, ncol=2, nrow=nrow(coords))
for(i in 1:nrow(coords))
    dvs[i,] = unlist(RM(t=1, y = coords[i,], parms = parms2))

##The trajectory
with(.GlobalEnv,{
    #####################################################################################
    plot(x=out2[,2],y=out2[,3], type="l", lwd=2, col="blue",
         xlab="Resource", ylab="Consumer", xlim=c(0,6),ylim=c(0,2))
    ##and vectors
    arrows(x0=coords[,1], y0=coords[,2], x1=coords[,1]+dvs[,1]*0.5,
           y1=coords[,2]+dvs[,2]*0.5, length=0.1, lwd=2)
    #####################################################################################
    })

##plotting minimum and maximum population sizes with different K values

##object with the line numbers we will use for the following plot
lines = (nrow(out)-500):nrow(out)

##creating an empty plot
with(.GlobalEnv,{
    #####################################################################################
    plot(0.1, type="n", xlim=c(0,20), ylim=range(out2[lines,2:3]), log="y",
         xlab="K", ylab="Min and Max population")

##points for the K = 10
    points(x = c(10,10), y = range(out[lines,3]), pch=21,bg="darkgreen", cex=3)
    points(x = c(10,10), y = range(out[lines,2]), pch=21,bg="blue", cex=3)

##points for the K = 15
    points(c(15,15), range(out2[lines,3]), pch=21,bg="darkgreen", cex=3)
    points(c(15,15), range(out2[lines,2]), pch=21,bg="blue", cex=3)
    #####################################################################################
    })

## this block calculates solutions for many K's, it should take some time
KK = seq(from = 0.5, to=25, by=0.5)
rminmax = matrix(NA, ncol=2, nrow=length(KK))#resource minimum and maximum
cminmax = matrix(NA, ncol=2, nrow=length(KK))#consumer minimux ans maximum

## Loop over all values of K andd get min and max population sizes
for(i in 1:length(KK)){
    parmsi = c(r=1, K=KK[i], a=1, h=0.1, e=0.1, d=0.1)
    y0 = c(R=1,C=1)
    out3 = ode(y=y0, times = seq(from = 1, to = 1000, by=0.5), func = RM, parms = parmsi)
    rminmax[i,] = range(out3[(nrow(out3)-500):nrow(out3),2])
    cminmax[i,] = range(out3[(nrow(out3)-500):nrow(out3),3])
}
with(.GlobalEnv,{
    #####################################################################################
    ## Plot of bifurcation digram with min and max population sizes
    plot(x=KK, y=rminmax[,1], type="l", lwd=2, col="blue",ylim=range(rminmax), log="y",
         xlab="K", ylab="Min and Max population")
    points(x=KK, y=rminmax[,2], type="l", lwd=2, col="blue")
    points(x=KK, y=cminmax[,1], type="l", lwd=2, col="darkgreen",ylim=range(rminmax))
    points(x=KK, y=cminmax[,2], type="l", lwd=2, col="darkgreen",ylim=range(rminmax))
    #####################################################################################
    })

### Consumer-resource dynamics in a seasonal environment ###
## time sequence
time <- seq(0, 2000, by = .5)

## parameters: a named vector
parameters <- c(r0=1, alpha=0.1, T=80, K=10, a=1, h=0.1, e=0.1, d=0.1)

## initial conditions: a named vector
state <- c(R = 1, C = 1)

## R function to calculate the value of the derivatives at each time value
## Use the names of the variables as defined in the vectors above
RM2 <- function(t, state, parameters){
    with(as.list(c(state, parameters)), {
        r = r0 * (1 + alpha*sin(2*pi*t/T))
        dR = R * ( r*(1 - R/K) - a*C / (1 + a*h*R) )
        dC = e*a*R*C / (1 + a*h*R) - d*C
        return(list(c(dR, dC)))
    })
}

## Integration with 'ode'
out <- ode(y = state, times = time, func = RM2, parms = parameters)

## Ploting with matplot
with(.GlobalEnv,{
    #####################################################################################
    matplot(x = out[,1], y = out[,2:3], type="l", lwd=2, lty = 1,
            col=c("blue", "darkgreen"), xlab = "Time", ylab = "Population size")
    legend("topright", c("Resource", "Consumer"), lty=1, lwd=2, col=c("blue", "darkgreen"))
    #####################################################################################
    })

## A resonance diagram ##
## New time sequence
time <- seq(0, 6000, by = 1)
## Sequence of values of T
TT <- seq(1, 80, by = 2)
## A matrix to store the results
results <- matrix(ncol=4, nrow=length(TT),
                  dimnames=list(NULL, c("R.min","R.max","C.min","C.max")))
## Loop over all values in TT
for(i in 1:length(TT)){
    parameters <- c(r0=1, alpha=0.1, T=TT[i], K=10, a=1, h=0.1, e=0.1, d=0.1)
    tmp1 <- ode(y = state, times = time, func = RM2, parms = parameters)
    results[i,1:2] <- range(tmp1[1001:nrow(tmp1), 2])
    results[i,3:4] <- range(tmp1[1001:nrow(tmp1), 3])
}

## Plot of resonance diagram
with(.GlobalEnv,{
    #####################################################################################
    plot(R.min ~ TT , data=results, type="l", lwd=2, lty = 1,
         col="blue", xlab = "T", ylab = "Min / Max population size",
         log="y", ylim = range(results))
    lines(R.max ~ TT, data=results,  type="l", lwd=2, lty = 1, col=c("blue"))
    lines(C.min ~ TT, data=results,  type="l", lwd=2, lty = 1, col=c("darkgreen"))
    lines(C.max ~ TT, data=results,  type="l", lwd=2, lty = 1, col=c("darkgreen"))
    legend("topright", c("Resource", "Consumer"), lty=1, lwd=2, col=c("blue", "darkgreen"))
    #####################################################################################
    })

Qualitative analysis and Bifurcation diagram Tutorial - R.r


## 1. Calculating Grades In R ##

print((90 + 81 + 92)/3)

## 2. Performing Multiple Calculations ##

print((84 + 95 + 79)/3)
print((95 + 86 + 93)/3)

## 3. Performing Calculations using Arithmetic Operators ##

print((77 + 85 + 90)/3)
print((92 + 90 + 91)/3)
print((85 + 88 + 95)/3)

## 4. Performing Calculations with Order of Operations ##

print(88 - ((88 + 87.66667 + 86 + 91.33333 + 84 + 91 + 89.33333)/7))

## 5. Creating Comments ##

# Operations

print(
    88 - ((88 + 87.66667 + 86 + 91.33333 + 84 + 91 + 89.33333)/7)
)

## 6. Assigning Values to a Variable ##

math <- 88

# Add your code below
chemistry <- 87.66667
writing <-  86
art <- 91.33333
history <- 84
music <- 91
physical_education <- 89.33333

## 7. Performing Calculations Using Variables ##

math <- 88
chemistry <- 87.66667
writing <-  86
art <- 91.33333
history <- 84
music <- 91
physical_education <- 89.33333

gpa <- (math + chemistry + writing + art + history + music + physical_education)/7

history_difference <- history - gpa

## 8. Creating Vectors ##

math <- 88
chemistry <- 87.66667
writing <-  86
art <- 91.33333
history <- 84
music <- 91
physical_education <- 89.33333

final_scores <- c(math, chemistry, writing, art, history, music, physical_education)

## 9. Calculating the Mean ##

final_scores <- c(math, chemistry, writing, art, history, music, physical_education)

gpa <- mean(final_scores)

## 10. Performing Operations on Vectors ##

final_scores <- c(math, chemistry, writing, art, history, music, physical_education)

highest_score <- max(final_scores)
lowest_score <- min(final_scores)
num_classes <- length(final_scores)

R Fundamentals/Introduction to R Programming-310.r


# Case diagnostics

brain <- read.table('brain.txt',as.is=T, header=T)

brain$loggest <- log(brain$gest)
brain$logbrain <- log(brain$brain)
brain$logbody <- log(brain$body)
brain$loglitter <- log(brain$litter)

brain.lm <- lm(logbrain ~ logbody + loglitter + loggest, data=brain)

rstandard(brain.lm)
# internally standardized residuals

rstudent(brain.lm)
#  externally studentized residuals (use MSE(-i))

influence.measures(brain.lm)
# computes (and prints) DFBETA's, DFFITS, Cook's D and Hii
#  also computes the covariance ratio, which I don't use,
#  but it's there if in case you want it.

# result of influence.measures has class infl.
# can access each bit (e.g. to plot) by burrowing into the infl
#  class structure, or you can access each diagnostic by specific
#  functions.

# N.B. A plot of only one thing uses 1:N as the X axis

plot(dffits(brain.lm))
plot(cooks.distance(brain.lm))
plot(hatvalues(brain.lm))

dfb <- dfbetas(brain.lm)
# there are four columns because k=3,
# plot each column of dfbetas
oldpar <- par(mfrow=c(2,2), mar=c(3,4,2,1)+0.1)
for (i in 1:4) { plot(dfb[,i]); title(dimnames(dfb)[[2]][i])}
par(oldpar)

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


library(deSolve)
library(rootSolve)
library(phaseR)

sirmod = function(t, y, parms) {
    # Pull state variables from y vector
    S = y[1]
    I = y[2]
    R = y[3]
    # Pull parameter values from parms vector
    beta = parms["beta"]
    mu = parms["mu"]
    gamma = parms["gamma"]
    N = parms["N"]
    # Define equations
    dS = mu * (N - S) - beta * S * I/N
    dI = beta * S * I/N - (mu + gamma) * I
    dR = gamma * I - mu * R
    res = c(dS, dI, dR)
    # Return list of gradients
    list(res)
}

times = seq(0, 26, by = 1/10)
parms = c(mu = 0, N = 1, beta = 2, gamma = 1/2)
start = c(S = 0.999, I = 0.001, R = 0)

out = ode(y = start, times = times, func = sirmod,
     parms = parms)
out=as.data.frame(out)
head(round(out, 3))

plot(x = out$time, y = out$S, ylab = "Fraction",
     xlab = "Time", type = "l")
lines(x = out$time, y = out$I, col = "red")
lines(x = out$time, y = out$R, col = "green")

#Calculate R0
R0 = parms["beta"]/(parms["gamma"]+parms["mu"])

#Adjust margins to accommodate a second right axis
par(mar = c(5,5,2,5))
#Plot state variables
plot(x = out$time, y = out$S, ylab = "Fraction",
     xlab = "Time",  type = "l")
lines(x = out$time, y = out$I, col = "red")
lines(x = out$time, y = out$R, col = "green")

#Add vertical line at turnover point
xx = out$time[which.max(out$I)]
lines(c(xx,xx), c(1/R0,max(out$I)), lty = 3)

#prepare to superimpose 2nd plot
par(new = TRUE)
#plot effective reproductive ratio (w/o axes)
plot(x = out$time, y = R0*out$S, type = "l", lty = 2,
     lwd = 2, col = "black", axes = FALSE, xlab = NA,
     ylab = NA, ylim = c(-.5, 4.5))
lines(c(xx, 26), c(1,1), lty = 3)
#Add right-hand axis for RE
axis(side = 4)
mtext(side = 4, line = 4, expression(R[E]))
#Add legend
legend("right", legend = c("S", "I", "R",
     expression(R[E])), lty = c(1,1,1, 2),
     col = c("black", "red", "green", "black"))

equil=runsteady(y=c(S=1-1E-5, I=1E-5, R=0),
times=c(0,1E5), func=sirmod, parms=parms)
round(equil$y, 3)

#Candidate values for R0 and beta
R0 = seq(0.1, 5, length=50)
betas= R0 * 1/2
#Vector of NAs to be filled with numbers
f = rep(NA, 50)
#Loop over i from 1, 2, ..., 50
for(i in seq(from=1, to=50, by=1)){
     equil=runsteady(y=c(S=1-1E-5, I=1E-5,
       R=0), times=c(0,1E5), func=sirmod,
       parms=c(mu=0, N=1, beta=betas[i], gamma=1/2))
     f[i]=equil$y["R"]
}
plot(R0, f, type="l", xlab=expression(R[0]))
curve(1-exp(-x), from=1, to=5, add=TRUE, col="red")

#Define function
fn=function(x, R0){
 exp(-(R0*(1-x))) - x
}
1-uniroot(fn, lower = 0, upper = 1-1E-9,
     tol = 1e-9, R0=2)$root
#check accuracy of approximation:
exp(-2)-uniroot(fn, lower = 0, upper = 1-1E-9,
     tol = 1e-9, R0=2)$root

times  = seq(0, 52*50, by=.1)
parms  = c(mu = 1/(50*52), N = 1, beta =  2,
     gamma = 1/2)
start = c(S=0.19, I=0.01, R = 0.8)
out = as.data.frame(ode(y=start, times=times,
     func=sirmod, parms=parms))
par(mfrow=c(1,2)) #Make room for side-by-side plots
plot(times, out$I, ylab="Fraction", xlab="Time",
     type="l")
plot(out$S, out$I, type="l", xlab="Susceptible",
     ylab="Infected")

simod = function(t, y, parameters) {
    S = y[1]
    I = y[2]

    beta = parameters["beta"]
    mu = parameters["mu"]
    gamma = parameters["gamma"]
    N = parameters["N"]

    dS = mu * (N - S) - beta * S * I/N
    dI = beta * S * I/N - (mu + gamma) * I
    res = c(dS, dI)
    list(res)
}

#Plot vector field
fld = flowField(simod, xlim = c(0.15,0.35),
     ylim = c(0,.01), parameters = parms, system = "two.dim",
     add = FALSE, ylab = "I", xlab = "S")
#Add trajectory
out = as.data.frame(ode(y = c(S = 0.19, I = 0.01),
     times =  seq(0, 52*100, by = .1), func = simod, parms = parms))
 lines(out$S, out$I, col = "red")
#Add S-isocline
curve(parms["mu"]*(1/x-1)/parms["beta"], 0.15, 0.35,
     xlab = "S", ylab = "I", add = TRUE)
#Add I-isocline
icline = (parms["gamma"] + parms["mu"])/parms["beta"]
lines(rep(icline, 2), c(0,0.01))
legend("topright", legend = c("Transient", "Isoclines"),
     lty = c(1, 1), col = c("red", "black"))

# Pull values from parms vector
gamma = parms["gamma"]
beta = parms["beta"]
mu = parms["mu"]
N = parms["N"]
# Endemic equilibrium
Sstar = (gamma + mu)/beta
Istar = mu * (beta/(gamma + mu) - 1)/beta
eq1 = list(S = Sstar, I = Istar)

# Define equations
dS = expression(mu * (N - S) - beta * S * I/N)
dI = expression(beta * S * I/N - (mu + gamma) * I)
# Differentiate w.r.t. S and I
j11 = D(dS, "S")
j12 = D(dS, "I")
j21 = D(dI, "S")
j22 = D(dI, "I")

#Evaluate Jacobian at equilibrium
J=with(data=eq1, expr=matrix(c(eval(j11),eval(j12),
     eval(j21),eval(j22)), nrow=2, byrow=TRUE))
#Calculate eigenvalues
eigen(J)$values

2 * pi/(Im(eigen(J)$values[1]))

eq2=list(S=1,I=0)
J=with(eq2,
     matrix(c(eval(j11),eval(j12),eval(j21),
     eval(j22)), nrow=2, byrow=TRUE))
eigen(J)$values

chainSIR = function(t, logx, params){
x = exp(logx)
u = params["u"]
S = x[1]
I = x[2:(u+1)]
R = x[u+2]
with(as.list(params),{
  dS = mu * (N - S)  - sum(beta * S * I) / N
  dI = rep(0, u)
  dI[1] = sum(beta * S * I) / N - (mu + u*gamma) * I[1]
  if(u>1){
     for(i in 2:u){
         dI[i] = u*gamma * I[i-1] - (mu+u*gamma)* I[i]
      }
   }
  dR = u*gamma * I[u] - mu * R
  res = c(dS/S, dI/I, dR/R)
  list(res)
})
}

times = seq(0, 10, by=1/52)
paras2 = c(mu = 1/75, N = 1, beta =  625,
     gamma = 365/14, u=1)
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001,
     paras2["u"]-1)), R = 0.0001))
out = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
plot(times, exp(out[,3]), ylab = "Infected", xlab =
     "Time", ylim = c(0, 0.01), type = 'l')

paras2["u"] = 2
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001/
     paras2["u"], paras2["u"]-1)), R = 0.0001))
out2 = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
lines(times, apply(exp(out2[,-c(1:2,length(out2))]),
     1 ,sum), col = 'blue')

paras2["u"] = 73
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001/
     paras2["u"], paras2["u"]-1)), R = 0.0001))
out3 = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
lines(times, apply(exp(out3[,-c(1:2,length(out3))]),
     1, sum), col='red', lwd=2, lty=2)

paras2["u"] = 500
xstart2 = log(c(S = .06, I = c(0.001, rep(0.0001/
     paras2["u"], paras2["u"]-1)), R = 0.0001))
out4 = as.data.frame(ode(xstart2, times, chainSIR,
     paras2))
lines(times, apply(exp(out4[,-c(1:2,length(out4))]),
     1,sum, na.rm = TRUE), col = 'green')

legend("topright", legend = c("SIR", "u=2", "u=500",
     "u=73 (H-S)"), lty = c(1,1,1,2), lwd = c(1,1,1, 2),
     col = c("black", "blue", "green", "red"))


# Goals: Scare the hell out of children with the Cauchy distribution.

# A function which simulates N draws from one of two distributions,
# and returns the mean obtained thusly.
one.simulation <- function(N=100, distribution="normal") {
  if (distribution == "normal") {
    x <- rnorm(N)
  } else {
    x <- rcauchy(N)
  }
  mean(x)
}

k1 <- density(replicate(1000, one.simulation(20)))
k2 <- density(replicate(1000, one.simulation(20, distribution="cauchy")))

xrange <- range(k1$x, k2$x)
plot(k1$x, k1$y, xlim=xrange, type="l", xlab="Estimated value", ylab="")
grid()
lines(k2$x, k2$y, col="red")
abline(v=.5)
legend(x="topleft", bty="n",
       lty=c(1,1),
       col=c("black", "red"),
       legend=c("Mean of Normal", "Mean of Cauchy"))
# The distribution of the mean of normals collapses into a point;
# that of the cauchy does not.

# Here's more scary stuff --
for (i in 1:10) {
  cat("Sigma of distribution of 1000 draws from mean of normal - ",
      sd(replicate(1000, one.simulation(20))), "\n")
}
for (i in 1:10) {
  cat("Sigma of distribution of 1000 draws from mean of cauchy - ",
      sd(replicate(1000, one.simulation(20, distribution="cauchy"))), "\n")
}

# Exercise for the reader: Compare the distribution of the median of
# the Normal against the distribution of the median of the Cauchy.

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


n <- 1000 # assigns the value of one thousand to n
+ x <- seq(1,n) # the above is how a sequence is created
+ sum(x) # this is a list of numbers and sum adds them together

# what I've in math and more in programming is that we say we evaluate a function when arguments are replaced specific values
# for example if we type log2(16) we evaluate the log2 function to get the log base 2 of 16 which will return 4
log2(16)

# from experience in R it is useful to evaluate a function inside another function
# for example sqrt(log2(16)) which will calculate the log to the base 2 of 16 and then compute the square root of that returned value
sqrt(log2(16))

# so the first evaluation returns 4 and this is then evaluated by sqrt to give the final answer of 2

x <-5 # 5 is a random number that I chose for testing
log(exp(x)) # this will always return the numeric value stored in x


## coef effect sizes from association tests of features
## se standard errors of the coefficients
## mat input data matrix (features x samples)
ivwfe.stats <- function(coef, se, mat=NULL, rho=NULL) {
    ## From James Staley:
    ##     Here is the link to Stephen Burgess’ paper we discussed on
    ## Thursday last week:
    ## http://onlinelibrary.wiley.com/doi/10.1002/sim.6835/full
    ##     I have taken a look at the maths and Stouffer’s test statistic
    ## weighted by 1/SE is the same as IVW FE meta-analysis beta/SE. So, the
    ## generalised linear model approach in Stephen’s paper which is based on
    ## IVW FE meta-analysis would probably be very similar to your Stouffer’s
    ## method corrected for correlated Z-statistics.
    ##     The test statistic would be: T = B/S ~ N(0,1)
    ## where B = (1^TΩ^-11)^-11^TΩ^-1β and S = sqrt((1^TΩ^-11)^-1) where β are
    ## the effect estimates, Ω is the variance-covariance matrix of the CpGs
    ## and 1 is a vector of 1’s the same length as the number of CpGs.

    if (is.null(rho)) {
        stopifnot(!is.null(mat))
        rho <- ivwfe.rho(mat)
    }
    ## The second diagonal matrix is the 'nudge' matrix to ensure matrix inversion

    ## remove missing values
    na <- is.na(coef) | is.na(se)
    if (sum(na) > 0) {
        if (sum(na) == length(coef))
            return(c(B=NA, S=NA))

        coef <- coef[!na]
        se <- se[!na]
        rho <- rho[!na,!na,drop=F]
    }

    omega <- (se%*%t(se))*rho
    omega.inv <- solve(omega)
    one <- matrix(1,nrow=nrow(omega.inv), ncol=1)
    S2 <- 1/(t(one) %*% omega.inv %*% one)
    c(B=S2 * (t(one) %*% omega.inv) %*% coef,
      S=sqrt(S2))
}

ivwfe.getz <- function(coef, se, mat=NULL, rho=NULL) {
    stats <- ivwfe.stats(coef, se, mat, rho)
    as.vector(stats["B"]/stats["S"])
}

ivwfe.rho <- function(mat) {
    mat <- t(mat)
    rho <- cor(mat, use="p") + diag(x=0.05,ncol(mat),ncol(mat))
}

ivwfe.ma <- function(estimates, se) {
    weights <- 1/se^2
    se <- sqrt(1/rowSums(weights, na.rm=T))
    estimates <- rowSums(estimates * weights, na.rm=T)/rowSums(weights, na.rm=T)
    z <- estimates/se
    p <- 2*pnorm(-abs(z), lower.tail=T)
    data.frame(estimate=estimates,
               se=se,
               z=z,
               p.value=p)
}


source('./libraries.R')

#### Functions ----
T_hotelling_radial <- function(r, phi, critical, norm_data, n, p){
  n * r^2 * (t(c(cos(phi), sin(phi))) %*% solve(cov(norm_data)) %*% (c(cos(phi), sin(phi)))) * ((n - p)/(p * (n - 1))) - critical
}

T_likelihood_phi <- function(r, phi, rho, sigma_x, sigma_y, n, critical){
  ((n) / (1 - rho**2)) *
    (((r * cos(phi)) / (sigma_x))**2 +
       ((r * sin(phi)) / (sigma_y))**2 -
       (2 * rho * ((r * cos(phi)) / (sigma_x)) * ((r * sin(phi)) / (sigma_y)))
    ) - critical
}

mvnormSample_2d <- function(mu_x = 0, mu_y = 0, n = 20, rho = 0.5, sigma_x = 1, sigma_y = 1){
  mu <- c(mu_x , mu_y)
  names(mu) <- c('mu_x', 'mu_y')
  Sigma <- matrix(c(sigma_x^2,
                    sigma_x * sigma_y * rho,
                    sigma_x * sigma_y * rho,
                    sigma_y^2),
                  2, 2, byrow = TRUE)
  sample <- mvrnorm(n = n, mu = mu, Sigma = Sigma) %>% as.data.frame()
  names(sample) <- c('x', 'y')
  return(sample)
}

Hotelling_radial_cr <- function(data, len_out=180, signf_lvl = 0.05){
  n <- nrow(data)
  p <- ncol(data)
  critical <- qf(1 - signf_lvl, df1 = p, df2 = n - p)
  col_means <- colMeans(data)

  vred <- data.frame(phi = seq(0, 2 * pi, length.out = len_out)) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = T_hotelling_radial,
      phi = phi,
      critical = critical,
      norm_data = data,
      n = n,
      p = p,
      interval = c(0, 400)
    )$root) %>%
    ungroup() %>%
    transmute(x = col_means[1] + r * cos(phi), y = col_means[2] + r * sin(phi))
  return(vred)
}

Likelihood_radial_cr <- function(data, len_out = 180, signf_lvl = 0.05){
  n = nrow(data)
  col_sd <- apply(data, 2, sd)
  col_means <- colMeans(data)
  hat_rho <- cor(data)[1,2]
  critical <- qchisq(1 - signf_lvl, df = 2)
  vred <- data.frame(phi = seq(0, 2 * pi, length.out = len_out)) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = T_likelihood_phi,
      phi = phi,
      rho = hat_rho,
      sigma_x = col_sd[1],
      sigma_y = col_sd[2],
      n = n,
      critical = critical,
      interval = c(0,400)
    )$root) %>%
    ungroup() %>%
    transmute(x = col_means[1] + r * cos(phi), y = col_means[2] + r * sin(phi))
  # return points to plot
  return(vred)
}

# 3D sample
mvnormSample_3d <- function(n = 20){
  mu <- c(0,0,0)
  names(mu) <- c('mu_x', 'mu_y', 'mu_z')
  Sigma <- matrix(c(1, 0.5, 0.5,
                    0.5, 1, 0.5,
                    0.5, 0.5, 1),
                  3, 3, byrow = TRUE)
  sample <- mvrnorm(n = n, mu = mu, Sigma = Sigma) %>% as.data.frame()
  names(sample) <- c('x', 'y', 'z')
  return(sample)
}

# Hotelling 3D
Hot_pivot <-  function(r, phi_1, phi_2, n, p, data, critical){
  n * r^2 *
     t(c(
       cos(phi_1),
       sin(phi_1) * cos(phi_2),
       sin(phi_1) * sin(phi_2)
     )) %*%
     solve(cov(data)) %*%
     c(
       cos(phi_1),
       sin(phi_1) * cos(phi_2),
       sin(phi_1) * sin(phi_2)
     ) *
     ((n - p)/(p * (n - 1))) - critical
}

Hot_cr_3d <- function(data, len_out=180, signf_lvl = 0.05){
  len_2 <- floor(sqrt(len_out/2))
  len_1 <- 2 * len_2
  n <- nrow(data)
  p <- ncol(data)
  critical <- qf(1-signf_lvl, df1 = p, df2 = n-p)
  col_means <- colMeans(data)
  phi_1 = seq(0, pi, length.out = len_1)
  phi_2 = seq(0, 2 * pi, length.out = len_2)
  vred <- expand_grid(phi_1, phi_2) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = Hot_pivot,
      phi_1 = phi_1,
      phi_2 = phi_2,
      critical = critical,
      data = data,
      n = n,
      p = p,
      interval = c(0, 400)
    )$root) %>%
    ungroup() %>%
    transmute(x = col_means[1] + r * cos(phi_1), y = col_means[2] + r * sin(phi_1) * cos(phi_2), z = col_means[3] + r * sin(phi_1) * sin(phi_2))
  return(vred)
}

# Likelihood  3D
ell_0 <- function(x, mu_hat, k, Sigma_inv, Sigma_det){
  -(1/2) * (
    t(x - mu_hat) %*%
      Sigma_inv %*%
      (x - mu_hat)
  ) -
    (k/2) * log(2* pi) - (1/2) * log(Sigma_det)
}

ell <- function(r, x, phi_1, phi_2, mu_hat, k, Sigma_inv, Sigma_det){
  -(1/2) * (
    t(x - mu_hat - r *
        c(
          cos(phi_1),
          sin(phi_1) * cos(phi_2),
          sin(phi_1) * sin(phi_2)
        )
      ) %*%
      Sigma_inv %*%
      (x - mu_hat - r *
         c(
           cos(phi_1),
           sin(phi_1) * cos(phi_2),
           sin(phi_1) * sin(phi_2)
         )
      )
    ) -
    (k/2) * log(2* pi) - (1/2) * log(Sigma_det)
}

Lik_pivot <- function(r, phi_1, phi_2, mu_hat, k, critical, Sigma_inv, Sigma_det, data){

  ells <- data %>%
    rowwise() %>%
    transmute(
      var_ell = ell(
        r = r,
        x = c(x, y, z),
        phi_1 = phi_1,
        phi_2 = phi_2,
        mu_hat = mu_hat,
        k = k,
        Sigma_inv = Sigma_inv,
        Sigma_det = Sigma_det
      ),
      var_ell_0 = ell_0(
        x = c(x, y, z),
        mu_hat = mu_hat,
        k = k,
        Sigma_inv = Sigma_inv,
        Sigma_det = Sigma_det
      )
    ) %>%
    ungroup() %>%
    summarise(sum_ell = sum(var_ell),
              sum_ell_0 = sum(var_ell_0))
  value <- -2 * (ells$sum_ell - ells$sum_ell_0) - critical
  return(value)
}

Lik_cr_3d <- function(data, len_out=180, signf_lvl=0.05){
  k <- ncol(data)
  n <- nrow(data)
  cov_mtrx <- cov(data)
  Sigma_inv <- solve(cov_mtrx)
  Sigma_det <- det(cov_mtrx)
  critical <- qchisq(1-signf_lvl, df = k)
  mu_hat <- colMeans(data)
  len_2 <- floor(sqrt(len_out/2))
  len_1 <- 2 * len_2

  phi_1 = seq(0, pi, length.out = len_1)
  phi_2 = seq(0, 2 * pi, length.out = len_2)
  vred <- expand_grid(phi_1, phi_2) %>%
    rowwise() %>%
    mutate(r = uniroot(
      f = Lik_pivot,
      phi_1 = phi_1,
      phi_2 = phi_2,
      mu_hat = mu_hat,
      k = k,
      critical = critical,
      Sigma_inv = Sigma_inv,
      Sigma_det = Sigma_det,
      data = data,
      interval = c(0, 400)
    )$root) %>%
    ungroup() %>%
    transmute(x = mu_hat[1] + r * cos(phi_1), y = mu_hat[2] + r * sin(phi_1) * cos(phi_2), z = mu_hat[3] + r * sin(phi_1) * sin(phi_2))
  return(vred)

}

#### 2D example ----
# Generate 2D data

data_2d <- mvnormSample_2d(n = 20)
mu_hat <- colMeans(data_2d)
cr_2d_hot <- Hotelling_radial_cr(data = data_2d, len_out = 180) %>% slice(chull(x, y))
cr_2d_lik <- Likelihood_radial_cr(data = data_2d, len_out = 180) %>% slice(chull(x, y))

data_2d %>% ggplot(aes(x = x, y = y)) +
  geom_point() +
  geom_point(aes(x = mu_hat[1], y = mu_hat[2]), size = 3, alpha = .5, color = 'red') +
  geom_polygon(data = cr_2d_hot, alpha = 0.3, fill='darkgreen') +
  geom_polygon(data = cr_2d_lik, alpha = 0.3, fill='yellow')

#### 3D example ----
cr_plot <- function(data, colour){
  chul_3d <- convhulln(data, options = 'FA')
  mesh_3d <- mesh3d(chul_3d$p)
  mesh_3d$it <- chul_3d$hull %>% t()
  mesh_3d$ib <- NULL
  wire3d(mesh_3d, col = colour, alpha = 0.4)
  shade3d(mesh_3d, col = colour, alpha = 0.1, override = T)
}

run_3d <- function(n_pts, n_bnry_pts){

  data_3d <- mvnormSample_3d(n = n_pts)
  mean_3d <- colMeans(data_3d) %>% t()

  # confidence regions
  data_3d_cr_hot <-
    Hot_cr_3d(data = data_3d,
              len_out = n_bnry_pts,
              signf_lvl = 0.05)
  data_3d_cr_lik <-
    Lik_cr_3d(data = data_3d,
              len_out = n_bnry_pts,
              signf_lvl = 0.05)

  # plot points, mu and estimates
  points3d(data_3d, alpha = 0.5)
  axes3d(c('x', 'y', 'z'))
  points3d(data_3d,
           size = 20,
           alpha = 0.2,
           col = 'grey')
  points3d(mean_3d, size = 3, col = 'red')
  points3d(mean_3d,
           size = 20,
           alpha = 0.3,
           col = 'red')

  # original
  points3d(data.frame(x = 0, y = 0, z = 0), size = 3, col = 'orange')
  points3d(
    data.frame(x = 0, y = 0, z = 0),
    size = 20,
    alpha = 0.3,
    col = 'orange'
  )

  # CR
  cr_plot(data = data_3d_cr_hot, colour = 'green')
  cr_plot(data = data_3d_cr_lik, colour = 'blue')
}
run_3d(n_pts = 20, n_bnry_pts = 180)


#Example  :  2.2A    Chapter  :   2.2    page no : 50
#Pivots and Multipliers in converting matrix to upper traingular system
matrix(c(1,-1,0,-1,2,-1,0,-1,2),ncol=3)->A
A
print(paste("First pivot is",A[1,1]))
l21<-A[2,1]/A[1,1]
print(paste("Multiplier L21 to convert the second row first element to 0 is",l21))
A[2,]<-A[2,]-l21*A[1,]
A
print(paste("The second pivot is ",A[2,2]))
l32<-A[3,2]/A[2,2]
A[3,]<-A[3,]-l32*A[2,]
print("The equivalent Upper traingular system for the matrix A is ")
A


'''
1.17 (Brockwell et al., 2016, p. 36)

Load the dataset deaths in R using the read.table function. Plot the data. Also create a histogram of
the data using the R function hist. Plot the sample autocorrelation function using the acf function. The
presence of a strong seasonal component with period 12 is evident in the graph of the data and in the sample
autocorrelation function.
'''

data = read.table("C:/prosjekt/Time_Series_stat211/data/deaths.txt", skip = 9, header=FALSE)
names(data) = c("month","year","deaths")
data$time = as.Date(paste(data$year,data$month,"15",sep="-"))
attach(data)
plot(time,deaths/1000, type="l", xlab="", ylab = "deaths (thousands)")

acf(deaths ,lag.max = 24) #computes (and by default plots) estimates of the autocovariance or autocorrelation function

hist(deaths, breaks = 15)

'''
Problem 1.6
[BD, Exercise 1.18, page 37]
We are still studying the dataset deaths. In this exercise, you are supposed to reproduce the figures 1-24 and 1-25 in [BD, pp. 27-28] .
In 1.17, we found a period of length 12.
Fit a seasonal component using the procedure described in section 1.5.2.1 on page 26.
You may use the following functions or write your own:
'''
# Function for calculating a moving average when d is even
ma <- function(x, n=12){filter(x,c(.5,rep(1,n-1),.5)/n, sides=2)}
# Function for finding the seasonal component
seasonal.component <- function(x){ # x-  deaths
	# First step: detrending
	detrended <- x - ma(x)
	# Second step: Calculating sesonal component from detrended data
	wt <- rowMeans(matrix(detrended[!is.na(detrended)], nrow=12,byrow=FALSE))
	st<-(wt - mean(wt))[c(7:12,1:6)] #seasonal component
	return(st)
}

#sol
library(itsmr)
detrended <- deaths - seasonal.component(deaths) #season(deaths, 12) #removing season

'''
Plot the deseasonalized data (as in figure 1-24). Fit a quadratic trend (polynomial of
order two) to the deseasonalized data and add the curve to the plot you just created. The
trend should be mb = 9952 − 71.82t + 0.8260t2 for 1 ≤ t ≤ 72. This can be done using the
following code:
'''

M <- poly(1:72, degree=2, raw=TRUE)
trend <- lm(detrended ~ M) # Re-estimating trend of the detrended data
'''
Plot the sample autocorrelation function of Yt. Forecast the data for the next 24 months
without allowing for this dependence, based on the assumption that the estimated seasonal
and trend components are true values and that Yt is a white noise sequence with zero
mean. Calculate sb72+k for k = 1, . . . , 24 and do the forecasting by
Xbt = mb 72+k + sb72+k, k = 1, . . . , 24.
'''

#solution
plot(data$time, detrended/1000, type="b", xlab="",ylab="(thousands)") #plotting deseasonalized data

lines(data$time, trend(detrended, 2)/1000, col=2)

plot(data$time,season(deaths,12)/1000, type="b",xlab="",ylab="(thousands)") # Plotting seasonal component
abline(h=0) # adding horizontal line at zero

##########
'''
Plot the original data with the forecasts appended. Later we shall see how to improve on
these forecasts by taking into account the dependence in the series Yt. Hint: To calculate
mb 72+k the following code may be useful:
'''
M <- poly(72 + 1:24, 2, raw=TRUE)
yhat <- predict(trend, newdata= M)

#######
p.time <- seq(as.Date("1979-01-15"),by="month",length.out=24)

#plot(time,deaths/1000,xlim=range(time,p.time),type="b",
plot(time,detrended/1000,xlim=range(time,p.time),type="b",
	#ylim = range(deaths, yhat)/1000,
	ylim = range(trend(detrended, 2), yhat)/1000,
	ylab = "(thousands)", xlab ="")

lines(data$time, trend(detrended, 2)/1000, col=2)
lines(p.time,yhat/1000, type="b", col = "blue")

'''
References
Peter J Brockwell and Richard A Davis. Introduction to time series and forecasting;
3rd ed. Springer texts in statistics. Springer, Cham, 2016. doi: 10.1007/
'''


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

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

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

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

#get wd
getwd()

#Top six lines
tail(spruce.df)

#Plot the points
windows()

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

plot(quad.lm, which=1)

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

summary(quad.lm)

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

ciReg(quad.lm)

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

anova(spruce.lm,quad.lm)

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

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

height.qfit=fitted(quad.lm)

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

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

MSS/TSS

cooks20x(quad.lm)

#Now remove the 24th datum and reanalyze data

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

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

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

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

# Find the coefficients
coef(quad.lm)

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

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

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

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

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

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

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

abline(spruce.lm)

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

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

RSS

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

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

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

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

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

summary(spruce.lm)

#obtain coefft values
coef(spruce.lm)

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

anova(spruce.lm)

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

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

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

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

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

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


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

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

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

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

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

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


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

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

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

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

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

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

  prod <- 1L
  sum <- 0L

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

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

  return(sum %% prod)
}

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

chinese_remainder(n, a)


# confidence interval for indpendent sample

n1= 10
n2= 9
y1bar = 8.27
y2bar=6.78
s1=2.956
s2=2.565
# common standard deviation
sp=sqrt(((n1-1)*s1*s1+(n2-1)*s2*s2)/(n1+n2-2))

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


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

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


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

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

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

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

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

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

  list(alpha = alpha_star, var_pool = var_pool)
}

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

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

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

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


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

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

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

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

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

# Calculate VARIANCE
average_squared_difference <- mean(squared_differences)

# Calculate standard deviation
standard_deviation <- sqrt(average_squared_difference)

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


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

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

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

  ll <- log.priors + log.like

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

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

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

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

  ll <- log.priors + log.like

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

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


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

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

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

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

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

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


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


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

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


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

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

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

library(ggplot2)

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

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

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

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

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

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

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

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

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

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

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

q7_q8_q9

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

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

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

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

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

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

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

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

plot(x, pch = y+2)

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

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

abline(-3, 7)

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

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

# Got Q11 wrong

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

fit$tot.nSV

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

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

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

summary(Eins)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

summary(t(q16)*100)

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

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

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

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

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

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

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

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


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

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

## Tests of function

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


# Preparing Dataset for the Time Series Analysis

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

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

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

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

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

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

  plotSeasFac(decom.x12)

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

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

#### ASX ordinaries Price Index

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

#### Gold Price (AUD)

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

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

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

#### Copper (USD/tonne)

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

#### Whole Dataset

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

ASX_TS_lambda = BoxCox.lambda(ASX_TS)
ASX_TS_lambda

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

gold_TS_lambda = BoxCox.lambda(gold_TS)
gold_TS_lambda

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

oil_TS_lambda = BoxCox.lambda(oil_TS)
oil_TS_lambda

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

copper_TS_lambda = BoxCox.lambda(copper_TS)
copper_TS_lambda

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

## Differencing

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

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

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

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

## Decomposition
decom(ASX_TS)

decom(gold_TS)

decom(oil_TS)

decom(copper_TS)

# The most accurate and suitable distributed lag model

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

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

## Finite Distributed Lag Models.

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

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

## Polynomial Distributed Lag Model

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

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

## Koyck Distributed Lag Model

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

## Autoregressive Distributed Lag Model

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

# ardlDLM(1,5)

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

# ardlDLM(2,5)

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

# ardlDLM(3,5)

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


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

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

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

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


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


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

sieve(1000)


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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


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


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

obs.tram.number <- 100

k <- 10

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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


y1bar=25.1
y2bar=23.5
y3bar=37.8

MSE=10.278
sigma=sqrt(MSE)

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

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


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

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

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

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

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

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

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

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

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

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

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

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

autoplot(mod1)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

plot(gam1)

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

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

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

summary(mod2)

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

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

gam.check(mod2)

check_model(mod2)

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

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

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

summary(mod2)

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

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

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

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

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

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

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

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


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

# fit a loess regression

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

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

# compare predicted values with those from a quadratic model

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

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

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

# trick loess into giving you a quadratic regression

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

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

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

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

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

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

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

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

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

# the result of cut() is a factor

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


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