## defaults for matrix size and cp for synthetic wavefront construction

nrow.default <- 640
ncol.default <- nrow.default
cp.default <- list(xc=320.5, yc=320.5, rx=319.5, ry=319.5, obstruct=0)

## create a unit aperture inside a matrix of arbitrary size
## note the parameter cp is a list with components (xc, yc, rx, ry, obstruct) as returned by pupil.pars()

pupil <- function(zcoef=NULL, maxorder=14L, isoseq=FALSE,
                  phi=0, piston=NULL,
                  nrow=nrow.default, ncol=ncol.default,
                  cp=cp.default) {

  prt <- pupil.rhotheta(nrow, ncol, cp)
  rho <- prt$rho
  theta <- prt$theta
  rho.v <- rho[!is.na(rho)]
  theta.v <- theta[!is.na(rho)] - pi*phi/180
  wf.v <- numeric(length(rho.v))
  if (cp$obstruct > 0) {
    use.circ <- FALSE
  } else {
    use.circ <- TRUE
  }
  if (!is.null(zcoef)) {
    if (!is.null(piston)) {
      zcoef <- c(piston, zcoef)
    }
    if (isoseq) {
      if (use.circ) {
        wf.v <- zpm_cart(x=rho.v*cos(theta.v), y=rho.v*sin(theta.v), maxorder=maxorder) %*% zcoef
      } else {
        wf.v <- zapm_cart(x=rho.v*cos(theta.v), y=rho.v*sin(theta.v), maxorder=maxorder) %*% zcoef
      }
    } else {
      if (use.circ) {
        wf.v <- zpm(rho.v, theta.v, maxorder = maxorder) %*% zcoef
      } else {
        wf.v <- zapmC(rho.v, theta.v, maxorder = maxorder) %*% zcoef
      }
    }
  }
  wf <- matrix(NA, nrow=nrow, ncol=ncol)
  wf[!is.na(rho)] <- wf.v
  class(wf) <- c("pupil", class(wf))
  wf
}

pupil.arb <- function(zcoef=NULL, zlist=makezlist(),
                      phi=0, piston=0,
                      nrow=nrow.default, ncol=ncol.default,
                      cp=cp.default) {

  prt <- pupil.rhotheta(nrow, ncol, cp)
  rho <- prt$rho
  theta <- prt$theta
  rho.v <- rho[!is.na(rho)]
  theta.v <- theta[!is.na(rho)]
  wf.v <- numeric(length(rho.v))
  if (!is.null(zcoef)) {
    wf.v <- zpm.arb(rho.v, theta.v, phi, zlist=zlist) %*% zcoef
  }
  wf <- matrix(NA, nrow=nrow, ncol=ncol)
  wf[!is.na(rho)] <- wf.v
  wf <- wf+piston
  class(wf) <- c("pupil", class(wf))
  wf
}

## estimate of rms over pupil

pupilrms <- function(pupil) {
    sd(as.vector(pupil), na.rm=TRUE)
}

## estimate of p-v over pupil

pupilpv <- function(pupil) {
    max(pupil, na.rm=TRUE) - min(pupil, na.rm=TRUE)
}

#' Zygo's "robust" PV
#'
#' A peak to valley error estimate that reduces the effect of noise and artifacts
#'
#' @param wf.zfit matrix containing the smoothed Zernike fit wavefront
#' @param wf.residual matrix of the difference between the raw wavefront
#'  and the Zernike fit. These values are returned by [wf_net()]
#' @return the estimated PVr
#' @references
#'  Evans, C. (2009) Optical Engineering 48(4), 43605.
#'  <https://doi.org/10.1117/1.3119307>
#'
#' @details
#'  no check is performed on the wavefronts, so it's the user's
#'  responsibility to make sure these come from the same source
PVr <- function(wf.zfit, wf.residual) {
  pvr <- pupilpv(wf.zfit) + 3*sd(wf.residual, na.rm=TRUE)
  pvr
}

## Mahajan's approximation to Strehl ratio

strehlratio <- function(rms) {
    exp(-(2*pi*rms)^2)
}

## a summary method for pupils

summary.pupil <- function(wf, digits=3) {
	cat("Size:   ",nrow(wf), "x",ncol(wf),"\n")
	cat("RMS    =", format(pupilrms(wf), digits=digits), "\n")
	cat("P-V    =", format(pupilpv(wf), digits=digits), "\n")
	cat("Strehl =", format(strehlratio(pupilrms(wf)), digits=digits), "\n")
}

## a plot method for pupils

plot.pupil <- function(wf, cp=NULL, col=topo.colors(256), addContours=TRUE,
                       cscale=FALSE, eqa=FALSE, zlim=NULL, ...) {
    nr <- nrow(wf)
    nc <- ncol(wf)
    if(is.null(zlim)) zlim <- range(wf, finite=TRUE)
    if(eqa) wfcdf <- ecdf(wf[!is.na(wf)])
    if (cscale) {
        mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
        on.exit(par(par.orig))
        w <- (3 + mar.orig[2]) * par("csi") * 2.54
        layout(matrix(c(2, 1), ncol = 2), widths = c(1, lcm(w)))
        par(las = 1)
        mar <- mar.orig
        mar[4] <- mar[2]
        mar[2] <- 1
        par(mar = mar)
        levels <- seq(zlim[1], zlim[2], length=length(col)+1)
        plot.new()
        plot.window(xlim=c(0,1),ylim=range(levels), xaxs="i", yaxs="i")
        if (eqa) {
            vcol <- col[round((length(col)-1)*wfcdf(seq(zlim[1],zlim[2],length=length(col)))+1)]
        } else vcol <- col
	rect(0, levels[-length(levels)], 1, levels[-1], col=vcol, density=NA)
        axis(4)
        box()
        mar <- mar.orig
        mar[4] <- 0
        par(mar = mar)
    }
    if (is.null(cp)) {
        axis1 <- 1:nr
        axis2 <- 1:nc
    } else {
        axis1 <- ((1:nr)-cp$xc)/cp$rx
        axis2 <- ((1:nc)-cp$yc)/cp$ry
    }
    if (eqa) {
        iwf <- wfcdf(wf[!is.na(wf)])
        iwfm <- wf
        iwfm[!is.na(iwfm)] <- iwf
        zlim <- wfcdf(zlim)
        col1 <- round((length(col)-1)*zlim[1]+1)
        col2 <- round((length(col)-1)*zlim[2]+1)
        image(axis1, axis2, iwfm, zlim=zlim, asp=1, col=col[col1:col2],
              xlab="X", ylab="Y", useRaster=TRUE, ...)
    } else {
        image(axis1, axis2, wf, zlim=zlim, asp=1, col=col,
                  xlab="X", ylab="Y", useRaster=TRUE, ...)
    }
    if (addContours) contour(axis1, axis2, wf, add=TRUE)
}

## RGL animated 3D plot

## administrative stuff needed to make this a method for class "pupil"

wf3d <- function(wf, ...) UseMethod("wf3d", wf)

col3d <- function(wf, surf.col=topo.colors(256), zlim = NULL, eqa=FALSE) {
	if (is.null(zlim)) zlim <- range(wf, na.rm=TRUE)
    if (eqa) {
        wfcdf <- ecdf(wf[!is.na(wf)])
        iwf <- wfcdf(wf[!is.na(wf)])
        wf[!is.na(wf)] <- iwf
        zlim <- wfcdf(zlim)
    }
    surf.col[(length(surf.col)-1)*(wf-zlim[1])/(zlim[2]-zlim[1])+1]
}

wf3d.pupil <- function(wf, cp=NULL, zoom.wf=1, surf.col=topo.colors(256), bg.col="black",
                eqa=FALSE) {
    require(rgl)
    zlim <- range(wf, na.rm=TRUE)
    col <- col3d(wf, surf.col, zlim, eqa)
    if (is.null(cp)) {
        axis1 <- seq(-1, 1, length=nrow(wf))
        axis2 <- seq(-1, 1, length=ncol(wf))*(ncol(wf)/nrow(wf))
    } else {
        axis1 <- ((1:nrow(wf))-cp$xc)/cp$rx
        axis2 <- ((1:ncol(wf))-cp$yc)/cp$ry
    }

    rgl.bg(sphere=FALSE, fogtype="exp2", color=bg.col)
    rgl.surface(-axis1, axis2, wf*zoom.wf, color=col, shininess=100)
    rgl.lines(c(-1,-1.25)*max(axis1),c(0,0),c(0,0),color="red", lit=FALSE)
    rgl.lines(c(0,0),c(0,0),c(1,1.25)*max(axis2),color="red", lit=FALSE)
    rgl.texts(-1.3*max(axis1),0,0, "X", color="red")
    rgl.texts(0,0,1.3*max(axis2), "Y", color="red")
}

## polar coordinates inside the unit radius pupil

pupil.rhotheta <- function(nrow, ncol, cp) {
	xs <- ((1:nrow)-cp$xc)/cp$rx
	ys <- ((1:ncol)-cp$yc)/cp$ry
	rho <- function(x,y) sqrt(x^2+y^2)
	theta <- function(x,y) atan2(y,x)
	rho.mat <- outer(xs, ys, rho)
	theta.mat <- outer(xs,ys,theta)
	rho.mat[rho.mat>1] <- NA
	rho.mat[rho.mat<cp$obstruct] <- NA
	theta.mat[is.na(rho.mat)] <- NA
	list(rho=rho.mat, theta=theta.mat)
}


Poisson_Process <- function(beta, Texp){
    # Generates a Poisson process with a truncated last step.
    # Constructor. Sets dt:
    # dt (array-like): Waiting times between arrivals (exponential random variables).
    #     The last waiting time is shrunk so that its arrival coincides with Texp.
    #     A 0 is inserted in the beginning so that the indices match the reference paper.
    #
    # Args:
    #     beta (numeric): Parameter for exponential random variable.
    #     Texp (numeric): Expiry. The Poisson process is generated up to this point.

    # Generate exponential random variables until their sum adds to more than Texp
    total <- dt <- 0
    while (total < Texp){
        random_exponential <- rexp(1, beta)
        total <- total + random_exponential
        dt <- c(dt, random_exponential)
    }
    # Change the last exponential so that the sum of all exponentials equals Texp
    dt[length(dt)] <- dt[length(dt)] - (total - Texp)

    return(dt)
}

# An example to show how the class works. Keep this commented out unless testing the function.
# print(Poisson_Process(1,3))


# Code for samplers use in Beer sodium examples and the summary plots

beers <- read.table("beer_data.txt", header=T)
sodium.mat <- matrix(beers$Sodium,ncol=8,byrow=T)
sodium <- apply(sodium.mat,1,mean)

nsamp <- 5000
tau <- (0:4000)/100
sigma <- 0.846140/sqrt(8)
Vmu <- (sigma^2+tau^2)/6
muhat <- mean(sodium)

logpost <- tau*0

for (i in 1:length(tau)) {
  logpost[i] <- 0.5*log(Vmu[i]) -3*log(sigma^2+tau[i]^2) - sum((sodium-muhat)^2)/(sigma^2+tau[i]^2)/2
  }
post <- exp(logpost)

tausim <- sample(tau,nsamp,T,post)
Vmuk <- (sigma^2 + tausim^2)/6
musim <- rnorm(nsamp,muhat,sqrt(Vmuk))
thetasim <- matrix(0,ncol=6,nrow=nsamp)
for(i in 1:6) {
  vari <- sigma^2*tausim^2/(sigma^2 + tausim^2)
  meani <- (sodium[i]/sigma^2 + musim/tausim^2)*vari
  thetasim[,i] <- rnorm(nsamp,meani,sqrt(vari))
}

sodium.res <-sodium.mat
yrep <- array(0,c(nsamp,6,8))
r <- matrix(0, nrow=6, ncol=8)
corr <- rep(0,nsamp)
corrdat <- rep(0,nsamp)
vr <- rep(0,nsamp)
vrdat <- rep(0,nsamp)
for(i in 1:nsamp) {
  for(j in 1:6) {
    yrep[i,j,] <- rnorm(8,thetasim[i,j],sigma)
    r[j,] <- yrep[i,j,] - thetasim[i,j]
    sodium.res[j,] <- sodium.mat[j,] - thetasim[i,j]
  }
  corr[i] <- cor(sort(as.vector(r)),qnorm((1:48)/49))
  corrdat[i] <- cor(sort(as.vector(sodium.res)),qnorm((1:48)/49))
  vari <- apply(yrep[i,,],1,var)
  vr[i] <- max(vari)/min(vari)
  varidat <- apply(sodium.res,1,var)
  vrdat[i] <- max(varidat)/min(varidat)
}

sum(corr >= corrdat)/length(corr)
sum(vr >= vrdat)/length(vr)

fill.lm <- lm(Sodium ~ Beer, data=beers)
corrobs <- cor(sort(residuals(fill.lm)),qnorm((1:48)/49))

postscript("../beerdata.eps",horiz=F,width=6,height=4)
par(mfrow=c(1,1), pty="m", mar=c(4,4,2,1)+0.1)

plot(beers$Beer,beers$Sodium,pch=16, xlab="Beer", ylab="Sodium")
points(1:6,sodium,pch=16,col=2)
dev.off()

postscript("../beerhyper.eps",horiz=F,width=8,height=5)
par(mfrow=c(1,2), pty="m", mar=c(4,4,2,1)+0.1)

hist(tausim,prob=T,xlim=c(0,30), xlab=expression(tau),main="")
lines(tau,post/mean(post)/40,col=2)

hist(musim,prob=T, xlab=expression(mu),xlim=c(10,30),main="")

dev.off()

postscript("../beertheta.eps",horiz=F,width=8,height=5)
par(mfrow=c(2,3), pty="m", mar=c(4,4,2,1)+0.1)

hist(thetasim[,1],prob=T, xlab=expression(theta[1]),
  main="Beer 1")
points(sodium[1],0,pch=16,col=2)
points(mean(thetasim[,1]),0,pch=16,col=4)
hist(thetasim[,2],prob=T, xlab=expression(theta[2]),
  main="Beer 2")
points(sodium[2],0,pch=16,col=2)
points(mean(thetasim[,2]),0,pch=16,col=4)
hist(thetasim[,3],prob=T, xlab=expression(theta[3]),
  main="Beer 3")
points(sodium[3],0,pch=16,col=2)
points(mean(thetasim[,3]),0,pch=16,col=4)
hist(thetasim[,4],prob=T, xlab=expression(theta[4]),
  main="Beer 4")
points(sodium[4],0,pch=16,col=2)
points(mean(thetasim[,4]),0,pch=16,col=4)
hist(thetasim[,5],prob=T, xlab=expression(theta[5]),
  main="Beer 5")
points(sodium[5],0,pch=16,col=2)
points(mean(thetasim[,5]),0,pch=16,col=4)
hist(thetasim[,6],prob=T, xlab=expression(theta[6]),
  main="Beer 6")
points(sodium[6],0,pch=16,col=2)
points(mean(thetasim[,6]),0,pch=16,col=4)
dev.off()

postscript("../beercheck.eps",horiz=F,width=8,height=3.5)
par(mfrow=c(1,2), pty="m", mar=c(4,4,2,1)+0.1)

hist(corr,prob=T, xlab="Correlation",
  main="")
abline(v=corrobs,col=2)
hist(vr,prob=T, xlab="Variance Ratio",
  main="")
abline(v=vrdat,col=2)
dev.off()


analyze_bivariate_data <- function(matrix, explanatory_variable, response_variable) {
    relationship <- "linear"
    r <- cor(matrix[,1], matrix[,2])

    exponential_r <- cor(matrix[,1], log(matrix[,2]))
    if (exponential_r > r) {
        relationship <- "exponential"
        r <- exponential_r
    }

    logarithmic_r <- cor(log(matrix[,1]), matrix[,2])
    if (logarithmic_r > r) {
        relationship <- "logarithmic"
        r <- logarithmic_r
    }

    power_r <- cor(log(matrix[,1]), log(matrix[,2]))
    if (power_r > r) {
        relationship <- "power"
        r <- power_r
    }

    r <- round(r, 4)

    inc_or_dec <- if (r > 0) "increase" else "decrease"

    linear_description <- ""
    if (abs(r) < 0.5) {
        linear_description <- "weakly"
    } else if (abs(r) < 0.8) {
        linear_description <- "moderately"
    } else if (abs(r) <= 1) {
        linear_description <- "strongly"
    }

    title <- paste(c(explanatory_variable, "vs.", response_variable), collapse = " ")

    plot(matrix[,1], matrix[,2], main = title, xlab = explanatory_variable, ylab = response_variable)

    if (relationship == "linear") {
        abline(lm(matrix[,2] ~ matrix[,1]))
    }

    return(paste(c("As ", explanatory_variable, " increases, ", response_variable, " tends to ", inc_or_dec, ". The association is ", linear_description, " ", relationship, ", as evidenced by r = ", r, "."), collapse = ""))
}


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

## Get 6 contracts of the crude curve
crude.tickers <- c("CHRIS/CME_CL1", "CHRIS/CME_CL2", "CHRIS/CME_CL3",
                 "CHRIS/CME_CL4", "CHRIS/CME_CL5", "CHRIS/CME_CL6")
settle.field <- "Settle"
crude.prices <- Quandl(crude.tickers[1], type="xts")[,settle.field]
for (i in 2:length(crude.tickers)) {
    crude.tmp <- Quandl(crude.tickers[i], type="xts")[,settle.field]
    crude.prices <- cbind(crude.prices, crude.tmp)
}
colnames(crude.prices) <- paste("CL", 1:6, sep="")

crude.returns <- na.omit(diff(log(crude.prices)))
pc.crude <- princomp(crude.returns)
summary(pc.crude)
loadings(pc.crude)

## Get 6 contracts of the natgas curve
natgas.tickers <- c("CHRIS/CME_NG1", "CHRIS/CME_NG2", "CHRIS/CME_NG3",
                 "CHRIS/CME_NG4", "CHRIS/CME_NG5", "CHRIS/CME_NG6")
settle.field <- "Settle"
natgas.prices <- Quandl(natgas.tickers[1], type="xts")[,settle.field]
for (i in 2:length(natgas.tickers)) {
    natgas.tmp <- Quandl(natgas.tickers[i], type="xts")[,settle.field]
    natgas.prices <- cbind(natgas.prices, natgas.tmp)
}
colnames(natgas.prices) <- paste("NG", 1:6, sep="")

natgas.returns <- na.omit(diff(log(natgas.prices)))
pc.natgas <- princomp(natgas.returns)
summary(pc.natgas)
loadings(pc.natgas)


rm(list=ls(all=TRUE))

prior_heads = 10
prior_tails = 10
heads = 3
tails = 7

post_heads = prior_heads + heads
post_tails = prior_tails + tails
epost_heads = prior_heads + (2 * heads)
epost_tails = prior_tails + (2 * tails)

q = seq(0, 1, 0.005)
prior = dbeta(q, prior_heads, prior_tails)
post = dbeta(q, post_heads, post_tails)
epost = dbeta(q, epost_heads, epost_tails)
ymax = max(epost) + (0.02 * max(epost))

post_prob_unfair_heads = pbeta(0.5, post_heads, post_tails,
                               lower.tail = F)
epost_prob_unfair_heads = pbeta(0.5, epost_heads, epost_tails,
                                lower.tail = F)
post_mode = (post_heads - 1) / (post_heads + post_tails - 2)
epost_mode = (epost_heads - 1) / (epost_heads + epost_tails - 2)
cat(paste('post prob unfair heads: ', post_prob_unfair_heads, '\n'))
cat(paste('emp post prob unfair heads: ', epost_prob_unfair_heads, '\n'))
cat(paste('post mode: ', post_mode, '\n'))
cat(paste('emp post mode: ', epost_mode, '\n'))

pdf('coin_flip.pdf', width=7.087, height=4.5)
par(yaxs="i", xaxs="i", cex.lab=1.2, cex.axis=1.0, mgp=c(2.2, 0.7, 0),
    oma=c(0, 0, 0.2, 0.5), mar=c(3.2, 3.2, 0.5, 0.1))
plot(x=c(), y = c(), xlab=bquote(theta), ylab='Density', xlim=c(0,1),
     ylim=c(0, ymax))
lines(q, prior)
lines(q, post, col='blue')
lines(q, epost, col='red')
dev.off()


#1

#perform the ANOVA and save the results to plantanova
plantanova<-aov(weight~group, PlantGrowth)

#view the ANOVA data
anova(plantanova)

#p-value = 0.0159. p-value is less than the significance level of 0.05, So we can reject the null hypothesis that the mean growth is the same for all treatments.

#p-value = 0.0159.This means that, if the effect of all three treatments were the same, we would have less than 2% chance of seeing differences between groups as large or larger than this

coef(plantanova)

#Control treatment gives an average weight of 5.032. The effect of treatment 1 (trt1) is to reduce weight by an average of -0.371 units compared to the control method, and the effect of treatment 2 (trt2) is to increase weight by an average of 0.494 units compared to the control method.

#2

bottles<-read.csv("bottles.csv")
ks.test(bottles$Volume, "pnorm", 500, 25)

#The p-value for the one-sample Kolmogorov-Smirnov test is 0.2108. As this is not less than the significance level of 0.05, we can not reject the null hypothesis. This means that there is no evidence that the bottle volumes are not drawn from the normal distribution.

#3

dbinom(2,10,1/6)
#The probability of throwing exactly two sixes, when a fair die is rolled 10 times is 0.29071 or 29.071%

#4

dpois(18,20)
# the probability that exactly eighteen lobsters will be ordered tomorrow is 8.4%

#5

airquality_dataset<-as.data.frame(airquality)
summary(airquality_dataset)
airquality_dataset=na.omit(airquality_dataset)

max_data<-apply(airquality_dataset,2,max)
min_data<-apply(airquality_dataset,2, min)
data_scaled<-scale(airquality_dataset,center=min_data,scale=max_data-min_data)
summary(data_scaled)

#6

airquality_dataset<-as.data.frame(airquality)
summary(airquality_dataset)
airquality_dataset=na.omit(airquality_dataset)

mean_data<-apply(airquality_dataset, 2, mean)
std_data<-apply(airquality_dataset, 2, sd)

data_scaled<-scale(airquality_dataset, center=mean_data, scale=std_data)
summary(data_scaled)

R Community/R Stats_Basics Part 2/programs.r


=begin
  # sample-polynomial02.rb

  require "algebra"
  P = Polynomial(Integer, "x", "y", "z")
  x, y, z = P.vars
  p((-x + y + z)*(x + y - z)*(x - y + z))
  #=> -z^3 + (y + x)z^2 + (y^2 - 2xy + x^2)z - y^3 + xy^2 + x^2y - x^3

((<_|CONTENTS>))
=end


findfactors <- function(n) {
  d <- c()
  div <- 2; nxt <- 3; rest <- n
  while( rest != 1 ) {
    while( rest%%div == 0 ) {
      d <- c(d, div)
      rest <- floor(rest / div)
    }
    div <- nxt
    nxt <- nxt + 2
  }
  d
}

print(findfactors(1005025))


## Output : A matrix such that the
##          column sums are item log-likelihood values, and
##          row sums are person log-likelihood values.
log.prob <- function(U.data, th, a, b) {
        ## Step 1: Build the matrix of probabilities
        ##         (see Post 2 for details)
        term.1     <- outer(th, a)
        term.2     <- matrix(rep(a*b, P.persons), nrow=P.persons,
                             byrow=TRUE)
        P.prob <- plogis(term.1 - term.2) #### 1/(1 + exp(term.2 - term.1))

        ## Step 2: Build the likelihood from Equation 1 on the log scale
        log.bernoulli <- log(P.prob^U.data) + log((1-P.prob)^(1-U.data))
        return(log.bernoulli)
}


 explicit.to.implicit.2d.line = function ( p1, p2 ) {

# LINE_EXP2IMP_2D converts an explicit line to implicit form in 2D.
#%      A * X + B * Y + C = 0
  dx = p1[1] - p2[1]
  dy = p1[2] - p2[2]
  slope = dy/dx
  # slope =  (p1[2] - Y) / (p1[1] - X)
  # slope * (p1[1]-X) = (p1[2]-Y)
  # slope * p1[1] - slope * X - p1[2] + Y = 0
  # - slope * X + Y + slope*p1[1] - p1[2] = 0
  A = -slope
  B = 1
  C = slope * p1[1] - p1[2]
  out = as.matrix( cbind( A,B,C) )
  return( out )

}


library(polynom)
library(orthopolynom)

legendre.coeff <- function(x,y,l, xlim=range(x)) {
	a <- (xlim[2] - xlim[1])/2
	b <- xlim[1] + a
	x_ <- (x-b)/a

	n <- length(y)
	coeffs <- NULL

	for (i in 1:length(l)) {
		coeffs <- cbind(coeffs, 2 * sum(y * predict(l[[i]], x_))/n)
	}
	# Return a vector of coefficients
	#print(coeffs)
	coeffs
}

legendre.var <- function(x,y,xlim) {

	n <- length(y)
	k <- ceiling(n/4)
	l <- legendre.polynomials(length(y), normalized=T)
	coeffs <- legendre.coeff(x,y,l,xlim)
	#print(coeffs)
	v <- 4 * sum(coeffs[(n-k+1):n] * coeffs[(n-k+1):n])
	print(v)
	v
}

legendre.R <- function(J,x,y,xlim) {
	n <- length(y)
	l <- legendre.polynomials(J, normalize=T)
	coeffs <- legendre.coeff(x,y,l,xlim)
	v <- legendre.var(x,y,xlim)

	j <- c(1:n)
	R <- J*(v/n) + sum(coeffs[J+1:n] - (v * j[J+1:n]))

	R
}

legendre.choose.R <- function(x,y,xlim) {
	Js <- c(1:length(y))
	print(Js)
	Rs <- sapply(Js, function(j){legendre.R(j,x,y,xlim)})
	print(Rs)
	J.min <- which.min(Rs)
}

legendre.eval <- function(x, coeffs, l, xlim=range(x)) {
	a <- (xlim[2] - xlim[1])/2
	b <- xlim[1] + a
	x_ <- (x-b)/a

	y <- 0
	for (i in 1:length(l)) {
		y <- y + coeffs[i] * predict(l[[i]], x_)
	}
	y
}

legendre.trial <- function() {
	x <- seq(2,10,by=0.001)
	y <- sin(2*x)

	plot(x,y)
	l <- legendre.polynomials(3, normalized = TRUE)
	g <- legendre.coeff(x,y,l)
	lines(x, legendre.eval(x,g,l), col="orange")

	g <- legendre.coeff(x,y,l)
	lines(x, legendre.eval(x,g,l), col="orange")

}


# O(N)
square_sum <- 0
sum_of_squares <- 0
rng = 1:100

for (i in rng) {
    square_sum <- square_sum + i
    sum_of_squares <- sum_of_squares + i*i
}

square_sum <- square_sum * square_sum

print(square_sum - sum_of_squares)

# O(1)
sm <- 100 * (100+1)/ 2
squared <- (100 * (100 + 1) * (2 * 100 + 1)) / 6

result <- sm * sm - squared

print(result)


### SPOTTING A VOLATILE TIME SERIES

# Compute the length n of djx
n <- length(djx)

#  Generate a normal sample of size n with parameters given by npars
ndata <- rnorm(n)*npars[2] + npars[1]

# Generate a t-distributed sample of size n with paramaters given by tpars
tdata <- rt(n, df = tpars[1])*tpars[3] + tpars[2]

# Make ndata and tdata into xts objects
ndatax <- xts(ndata, time(djx))
tdatax <- xts(tdata, time(djx))

# Merge djx, ndatax, and tdatax and plot
alldata <- merge(djx,ndatax, tdatax)
plot.zoo(alldata, type = "h", ylim = range(alldata))

### COMPUTING VaR and ES for NORMAL DISTRIBUTION

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

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

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

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

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

### Examining risk factors for international equity portfolio

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

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

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

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

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

# Partition plotting area into 3 pieces
par(mfrow = c(1, 3))

# Plot djx_extremes
plot(djx_extremes, type = "h")

# Compute the spaces between the times of the extremes
djx_spaces <- diff(time(djx_extremes))

# Make a histogram of these spaces
hist(as.numeric(djx_spaces))

# Make a Q-Q plot of djx_spaces against exp_quantiles
qqplot(exp_quantiles, djx_spaces)

# Carry out the previous 4 steps for iid_extremes
plot(iid_extremes, type="h")
iid_spaces <- diff(time(iid_extremes))
hist(as.numeric(iid_spaces))
qqplot(exp_quantiles, iid_spaces)

# Make a time series plot of indexes with plot.zoo and a pairwise scatterplot with pairs
plot.zoo(indexes)
pairs(as.zoo(indexes))

# Calculate the sample correlation matrix of indexes
cor(indexes)

# Plot the sample acfs and cross-correlation functions for the returns in indexes
acf(indexes)

# Plot the sample acfs and cross-correlations functions for the absolute values of indexes
acf(abs(indexes))

# Plot fx and fx_w
plot.zoo(fx, type = "h")
plot.zoo(fx_w, type = "h")

# Make acf plots of fx and the absolute values of fx
acf(fx)
acf(abs(fx))

# Apply the Ljung-Box test to the components of fx and their absolute values
apply(fx, 2, Box.test, lag = 10, type = "Ljung")
apply(abs(fx), 2, Box.test, lag = 10, type = "Ljung")

# Make acf plots of fx_w and the absolute values of fx_w
acf(fx_w)
acf(abs(fx_w))

# Apply the Ljung-Box test to the components of fx_w and their absolute values
apply(fx_w, 2, Box.test, lag = 10, type = "Ljung")
apply(abs(fx_w), 2, Box.test, lag = 10, type = "Ljung")


#' Computes Moran's I correlation index
#'
#' Natively built for computing Moran's I on \code{dgCMatrix} objects, this
#' routine allows computing the I on large sparse matrices (graphs). Part of
#' its implementation was based on \code{\link[ape:Moran.I]{ape::Moran.I}},
#' which computes the I for dense matrices.
#'
#' @param x Numeric vector of size \eqn{n}.
#' @param w Numeric matrix of size \eqn{n\times n}{n * n}. Weights. It can be
#'  either a object of class \code{\link{matrix}} or \code{\link[Matrix:dgCMatrix-class]{dgCMatrix}}
#'  from the \code{\link[Matrix]{Matrix}} package.
#' @param normalize.w Logical scalar. When TRUE normalizes rowsums to one (or zero).
#' @param alternative	Character String. Specifies the alternative hypothesis that
#' is tested against the null of no autocorrelation; must be of one \code{"two.sided"},
#' \code{"less"}, or \code{"greater"}.
#' @export
#' @details
#' In the case that the vector \code{x} is close to constant (degenerate random
#' variable), the statistic becomes irrelevant, and furthermore, the standard error
#' tends to be undefined (\code{NaN}).
#'
#' @family statistics
#' @family Functions for inference
#' @return A list of class \code{diffnet_moran} with the following elements:
#' \item{observed}{Numeric scalar. Observed correlation index.}
#' \item{expected}{Numeric scalar. Expected correlation index equal to \eqn{-1/(N-1)}.}
#' \item{sd}{Numeric scalar. Standard error under the null.}
#' \item{p.value}{Numeric scalar. p-value of the specified \code{alternative}.}
#' @references
#'
#' Moran's I. (2015, September 3). In Wikipedia, The Free Encyclopedia.
#' Retrieved 06:23, December 22, 2015, from \url{https://en.wikipedia.org/w/index.php?title=Moran\%27s_I&oldid=679297766}
#'
#' @examples
#'
#' if (require("ape")) {
#'
#'   # Generating a small random graph
#'   set.seed(123)
#'   graph <- rgraph_ba(t = 4)
#'   w <- approx_geodesic(graph)
#'   x <- rnorm(5)
#'
#'   # Computing Moran's I
#'   moran(x, w)
#'
#'   # Comparing with the ape's package version
#'   ape::Moran.I(x, as.matrix(w))
#'
#' }
#'
#' @author George G. Vega Yon
moran <- function(x, w, normalize.w=TRUE, alternative = "two.sided") {
  if (!inherits(w, "matrix") & !inherits(w, "dgCMatrix"))
    stop("-w- must be either a matrix or a dgCMatrix.")

  if (any(!is.finite(x)))
    stop("-x- must have only numbers.")

  if (inherits(w, "matrix"))
    w <- methods::as(w, "dgCMatrix")

  if (normalize.w)
    w <- w/(rowSums(w) + 1e-20)

  res <- moran_cpp(x, w)

  # Computing pval
  pv  <- with(res, pnorm(observed, mean = expected, sd = sd))

  # Checking alternatives
  alternative <- match.arg(
    alternative, c("two.sided", "less", "greater")
    )

  if (alternative == "two.sided")
    pv <- if (res$observed <= res$expected)
      2 * pv
  else 2 * (1 - pv)
  if (alternative == "greater")
    pv <- 1 - pv

  # Returning
  structure(
    c(res, p.value = pv),
    class = "diffnet_moran"
  )

}


#
# Exemplo 2
#

# Série de taylor que desenvolve
# a série até encontrar erro menor
# que 0.01
taylor <- function(a, x) {
    n <- 0
    tay <- 0
    valor <- exp(x)
    while (abs(valor - tay) > 0.01) {
        termo <- exp(a) / factorial(n) * (x - a)^n
        tay <- tay + termo
        n <- n + 1
    }
    cat("Taylor=", tay, "Numero de interacoes=", n, "\n")
}
# executa a série em torno de a=2 para x=1
taylor(2, 1)


#!/usr/bin/Rscript
# Task 1
#-------------------------------------------------------------------------------
# Initial data
#-------------------------------------------------------------------------------
S0=1; r=0.05; sigma=0.2; T=2; K=0.8;
#-------------------------------------------------------------------------------
Call <- function(S0,r, sigma, T, K){
  d1=(log(S0/K)+T*(r+(sigma^2)/2))/(sigma*sqrt(T))
  d2=d1-sigma*sqrt(T)
  C=S0*pnorm(d1)-K*exp(-r*T)*pnorm(d2)
  return (C)
}

ImpliedVola <- function(S0, r, T, K, C){
  vola=uniroot(function(sigma) Call(S0, r, sigma, T, K) - C, c(0,5))
  return (vola$root)
}

C=Call(S0,r,sigma,T,K)
C
ImpliedVola(S0,r,T,K,C)
#-------------------------------------------------------------------------------
Data=read.csv("data/option_values.csv",header=F,sep=";")
Maturities=as.numeric(Data[1,]/12); Interests=as.numeric(Data[2,])

S0=2890.62; K=c(2700, 2800, 2900, 3000, 3100, 3200, 3300)
vola=matrix(rep(0,42), 7, 6)
for(i in 1:7)
  for(j in 1:6)
    vola[i, j] = ImpliedVola(S0, Interests[j], Maturities[j], K[i], Data[i+2,j])

persp(K,Maturities,vola,theta=60,col="green")


=begin
= 代数パッケージ

2006.09.16

*Version: 0.72
*著者: 原 信一郎
*e-mail: sinara@blade.nagaokaut.ac.jp
*Home Page: ((<URL:http://blade.nagaokaut.ac.jp/~sinara/ruby/math/>))

== これは、、、

1変数あるいは多変数の多項式を計算するためのライブラリです。
数学的対象を自然に Ruby で表現可能にする事を目的にしています。
スピードはありませんが、スクリプト言語なのでアルゴリズムを見る事
ができます。

* 一変数多項式
  * 加法、乗法、商／剰余等の演算
  * 因数分解
  * Galois 群
* 多変数多項式
  * 加法、乗法等の演算
  * 因数分解
  * グレブナ基底の生成、グレブナ基底による商／剰余の演算
* 代数系
  * 商体の生成
  * 剰余環の生成
  * 行列環の生成
  * 置換群の計算
* 集合と写像

== インストール

このパッケージを利用するにはまず、オブジェクト指向スクリプト言語 Ruby
(((<URL:http://www.ruby-lang.org/>))参照) が必要です。

更に、アーカイブの展開後

  ruby install.rb

とすれば、lib ディレクトリ以下を、ロード可能なディレクトリにコピーし、
インストールが完了します。

速度の点から、有理数は標準添付の rational.rb ではなく、拡張ライブラリ
(((<URL:http://blade.nagaokaut.ac.jp/~sinara/ruby/rational/>))
を使うことを勧めます。

== 使い方・サンプル

doc ディレクトリの ((<index-ja.html|URL:index-ja.html>)) を見てください。
マニュアルやサンプルがあります。

== 参考
* D.コックス, J.リトル and D.オシー, "グレブナ基底と代数多様体入門（上・下）",
  2000,シュプリンガー・フェアラーク東京
* 児玉宏児, "Polynomial", ((<URL:http://www.math.kobe-u.ac.jp/HOME/kodama/tips-RubyPoly.html>))
* H.Anai, M.Noro and K.Yokoyama, "Computation of the splitting fields and the Galois groups of polynomials", Progres in Mathematics, 28-50, Vo.143, 1996

=end


#----------------------------------------------------------------
# test function
#----------------------------------------------------------------

library(inline)

body <- "std::cout << \"It works\" << std::endl;"
test <- cxxfunction(signature(), body=body, plugin="Rcpp")

test()

#----------------------------------------------------------------
# Estimating pi
#----------------------------------------------------------------

mcsim_pi_r <- function(n){
  r <- 0L

  for (i in 1:n){
    u <- runif(1)
    v <- runif(1)

    if (u^2 + v^2 <= 1)
      r <- r + 1
  }

  return( 4*r/n )
}

mcsim_pi_r_vectorized <- function(n){
  x <- matrix(runif(n * 2), ncol=2)
  r <- sum(rowSums(x^2) <= 1)

  return( 4*r/n )
}

library(inline)
cxx_pi <- cxxfunction(signature(n_="int"), body='
    int i, r = 0;
    int n = Rcpp::as<int >(n_);
    double u, v;

    for (i=0; i<n; i++){
      u = R::runif(0, 1);
      v = R::runif(0, 1);

      if (u*u + v*v <= 1)
        r++;
    }

    return Rcpp::wrap( (double) 4.*r/n );

  ',plugin="Rcpp"
)

mcsim_pi_r_rcpp <- function(n){
  cxx_pi(as.integer(n))
}

library(rbenchmark)

n <- 50000

benchmark(R.loops = mcsim_pi_r(n),
          R.vectorized = mcsim_pi_r_vectorized(n),
          Rcpp = mcsim_pi_r_rcpp(n),
          columns=c("test", "replications", "elapsed", "relative"))

#----------------------------------------------------------------
# Cosine similarity
#----------------------------------------------------------------

### cosine function from lsa package
cosine <- function (x, y = NULL){
   if (is.matrix(x) && is.null(y)) {
       co = array(0, c(ncol(x), ncol(x)))
       f = colnames(x)
       dimnames(co) = list(f, f)
       for (i in 2:ncol(x)) {
           for (j in 1:(i - 1)) {
               co[i, j] = cosine(x[, i], x[, j])
           }
       }
       co = co + t(co)
       diag(co) = 1
       return(as.matrix(co))
   }
   else if (is.vector(x) && is.vector(y)) {
       return(crossprod(x, y)/sqrt(crossprod(x) * crossprod(y)))
   }
   else {
       stop("argument mismatch. Either one matrix or two vectors needed as input.")
   }
}

### Improved R solution
cosine2 <- function(x){
  cp <- crossprod(x)
  dg <- diag(cp)

  co <- matrix(0.0, length(dg), length(dg))

  for (j in 2L:length(dg)){
    for (i in 1L:(j-1L)){
      co[i, j] <- cp[i, j] / sqrt(dg[i] * dg[j])
    }
  }

  co <- co + t(co)
  diag(co) <- 1.0

  return( co )
}

### Rcpp
library(inline)

fill_loop <- cxxfunction(
  signature(cp_="matrix", dg_="numeric"),
  body='
    // Shallow copies
    Rcpp::NumericMatrix cp(cp_);
    Rcpp::NumericVector dg(dg_);

    // Allocate return
    Rcpp::NumericMatrix co(cp.nrow(), cp.ncol());

    int i, j;

    for (j=0; j<co.ncol(); j++){
      for (i=0; i<co.nrow(); i++){
        if (i == j)
          co(i, j) = 1.0;
        else
          co(i, j) = cp(i, j) / std::sqrt(dg[i] * dg[j]);
      }
    }

    return co;
  ',plugin="Rcpp"
)

cosine_Rcpp <- function(x){
  cp <- crossprod(x)
  dg <- diag(cp)

  co <- fill_loop(cp, dg)

  return( co )
}

### Rcpp improved
fill_loop2 <- cxxfunction(
  signature(cp_="matrix", dg_="numeric"),
  body='

    // Shallow copies
    Rcpp::NumericMatrix cp(cp_);
    Rcpp::NumericVector dg(dg_);

    const unsigned int n = cp.nrow();

    // Allocate return
    Rcpp::NumericMatrix co(n, n);

    int i, j;

    // Fill diagonal
    for (j=0; j<n; j++)
      co(j, j) = 1.0;

    // Fill lower triangle
    for (j=0; j<n; j++){
      for (i=0; i<j; i++)
        co(i, j) = cp(i, j) / std::sqrt(dg[i] * dg[j]);
    }

    // Copy lower triangle to upper
    for (j=0; j<n; j++){
      for (i=j+1; i<n; i++)
        co(i, j) = co(j, i);
    }

    return co;
  ',plugin="Rcpp"
)

cosine_Rcpp2 <- function(x){
  cp <- crossprod(x)
  dg <- diag(cp)

  co <- fill_loop2(cp, dg)

  return( co )
}

#----------------------------------------------------------------
# RcppArmadillo
#----------------------------------------------------------------

f <- function(x) list(outer=x %*% t(x), inner=t(x) %*% x)

body <- '
  arma::mat v = Rcpp::as<arma::mat>(vs);
  arma::mat op = v * v.t();
  arma::mat ip = v.t()*v;

  return Rcpp::List::create(
    Rcpp::Named("outer")=op, Rcpp::Named("inner") = ip);
'

library(inline)
g <- cxxfunction(signature(vs="matrix"), plugin="RcppArmadillo", body=body)

x <- matrix(1:30, 10)
all.equal(f(x), g(x))

#----------------------------------------------------------------
# RcppGSL
#----------------------------------------------------------------

includes <- '
  #include <gsl/gsl_matrix.h>
  #include <gsl/gsl_blas.h>
'

body <- '
  RcppGSL::matrix<double> M = sM;
  int k = M.ncol();
  Rcpp::NumericVector n(k);

  for (int j = 0; j < k; j++) {
      RcppGSL::vector_view<double> colview = gsl_matrix_column(M, j);
      n[j] = gsl_blas_dnrm2(colview);
  }

  M.free() ;
  return n;
'

library(inline)
g <- cxxfunction(signature(sM="matrix"), plugin="RcppGSL", body=body, inc=includes)


## data https://github.com/n0acar/eigenfaces
library(pixmap)

list files in a gihub directory

url <- "https://github.com/n0acar/eigenfaces/tree/master/lfw_cropped_gray_eigenfaces"

pg <- xml2::read_html(url)
library(magrittr)
library(rvest)
tst <- pg %>%  html_nodes("div") %>% html_nodes("span") %>% html_nodes("a") %>% html_text()
celebs <- tst[grep(".pgm",tst)]
base <- "https://raw.githubusercontent.com/n0acar/eigenfaces/master/lfw_cropped_gray_eigenfaces/"

for(i in 1:length(celebs)){
    download.file(paste(base, celebs[i], sep = ""), destfile  = celebs[i])
}

imgs <- list.files("./", pattern = ".pgm", full = TRUE)
pix <- lapply(imgs,read.pnm)
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pix)){
    plot(pix[[i]])
    nm <- strsplit(strsplit(imgs[i],"//")[[1]][2],"_")[[1]]
    legend("bottom", bty = "n", paste(nm[-length(nm)],  collapse = " "))
}

## names
tst <- sapply(imgs, function(x) strsplit(strsplit(x,"//")[[1]][2],"_")[[1]])
names <-  sapply(tst, function(y) paste(y[-length(y)],  collapse = " ")); names(names) <- NULL
## collapse the grey matrix
faces <- lapply(pix, function(x) c(x@grey))
## each column is a face
faces <- do.call('cbind',faces)
colnames(faces) <- names

## center around mean
mean <- apply(faces, 1, mean)
mean_face <- pixmapGrey(mean, 64, 64, bbox = c(0, 0, 64, 64))
plot(mean_face)
centered <- apply(faces, 2, function(x) x - mean)
## centered imags
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pix)){
    plot(pixmapGrey(centered[,i], 64, 64, bbox = c(0, 0, 64, 64)))
    legend("bottom", bty = "n", paste(names[i], "centered", sep = " "))
}

pca <- prcomp(centered)
library(ggbiplot)
ggbiplot(pca, alpha = 0.1) +
    theme(legend.direction = 'horizontal', legend.position = 'top')

## eigen faces
pcs <- pca$x
eigenfaces <- apply(pcs,2, function(x)  pixmapGrey(x, 64, 64, bbox = c(0, 0, 64, 64)))
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(eigenfaces)){
    plot(eigenfaces[[i]])
    legend("bottom", bty = "n", paste("PC", i, sep = " "))
}

## reconstruction
## each face is a weighted (loadings) combintation of the eigen faces (PCs) above
## but how many PCs (eigenfaces) do we keep
plot(pca)
pca$rotation
## 2 PCs
n_pc <- 2

recon <- pixm <- list()
for (i in 1:length(names)){
    recon[[i]] <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[i,1:n_pc])
    pixm[[i]] <- pixmapGrey(recon[[i]], 64, 64, bbox = c(0, 0, 64, 64))
}

## 2PC to reconstruct centered imags
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pixm)){
    plot(pixm[[i]])
    legend("bottom", bty = "n", paste(names[i], "2 PC", sep = " "))
}

### Hmm OK, what about 5
## 5 PCs
n_pc <- 5

recon <- pixm <- list()
for (i in 1:length(names)){
    recon[[i]] <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[i,1:n_pc])
    pixm[[i]] <- pixmapGrey(recon[[i]], 64, 64, bbox = c(0, 0, 64, 64))
}

## 2PC to reconstruct centered imags
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pixm)){
    plot(pixm[[i]])
    legend("bottom", bty = "n", paste(names[i], "5 PC", sep = " "))
}

### Hmm OK, what about 10
## 10 PCs
n_pc <- 10

recon <- pixm <- list()
for (i in 1:length(names)){
    recon[[i]] <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[i,1:n_pc])
    pixm[[i]] <- pixmapGrey(recon[[i]], 64, 64, bbox = c(0, 0, 64, 64))
}

## 10PC to reconstruct centered images
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(pixm)){
    plot(pixm[[i]])
    legend("bottom", bty = "n", paste(names[i], "10 PC", sep = " "))
}
## remember this is the centered image, let's add the "mean face" to reconstruct the original
par(mfrow = c(4,4), mar = c(0,0,0,0), oma = c(0,0,0,0))
for(i in 1:length(recon)){
    plot(pixmapGrey(recon[[i]] + mean, 64, 64, bbox = c(0, 0, 64, 64)))
    legend("bottom", bty = "n", paste(names[i], "10 PC + mean", sep = " "))
}

## So arguabke we reduced 16 dim to 10... Not a huge achievement, but what about if we have 1000 images
zip <- "http://conradsanderson.id.au/lfwcrop/lfwcrop_grey.zip"
temp <- tempfile(fileext = ".zip")
download.file(zip,destfile = temp)
tst <- unzip(temp)
unlink(temp)
all_faces <- list.files("lfwcrop_grey/faces",pattern = ".pgm", full = TRUE)
set.seed(6666)
choose <- sample(1:length(all_faces), 1000, replace = FALSE)

face_set <- lapply(choose, function(x) read.pnm(all_faces[x]))

## names
col <- sapply(all_faces[choose], function(x) strsplit(strsplit(x,"faces/")[[1]][2],"_")[[1]])
names <-  sapply(col, function(y) paste(y[-length(y)],  collapse = " ")); names(names) <- NULL
names(face_set) <- names
face_data <- lapply(face_set, function(x) c(x@grey))
## each column is a face
face_data <- do.call('cbind',face_data)
colnames(face_data) <- names(face_set)
## center around mean
mean <- apply(face_data, 1, mean)
mean_face <- pixmapGrey(mean, 64, 64, bbox = c(0, 0, 64, 64))
plot(mean_face)

centered <- apply(face_data, 2, function(x) x - mean)
pca <- prcomp(centered)
pcs <- pca$x
eigenfaces <- apply(pcs,2, function(x)  pixmapGrey(x, 64, 64, bbox = c(0, 0, 64, 64)))
plot(eigenfaces[[1]])
legend("bottom", bty = "n", "PC 1")

n_pc <- 250
recon <- rowSums(pca$x[,1:n_pc]%*%pca$rotation[1,1:n_pc])
## add the "mean face" to reconstruct the original
par(mfrow = c(1,2), mar = c(0,0,0,0), oma = c(0,0,0,0))
## original
plot(face_set[[1]])


y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500

alpha=0.05
q.alpha=4.158
MSError=0.0153
LSD=q.alpha*sqrt((MSError)/6)
print(LSD)

#  the 95% confidence interval for y3bar-y1bar
left_i=(y3bar-y1bar)-LSD
right_i=(y3bar-y1bar)+LSD
print("Confidence interval is")
print(left_i)
print(right_i)


#' Compute the time-shift parameter tau.
#'
#' @param t Sampling times.
#' @param omega Angular frequency.
#'
#' @return Time-shift parameter tau.
#'
#' @examples
#' tau(1:10, 2*pi)
#'
#' @export
tau <- function(t, omega) {
    # two.omega[j] = 2 * omega[j]
    two.omega <- 2 * omega
    # two.omega.t[j,i] = 2 * omega[j] * t[i]
    two.omega.t <- two.omega %o% t

    # sin.sum[j] = Sum from i=1..N of sin(two.omega.t[j,i])
    sin.sum = rowSums(sin(two.omega.t))
    # cos.sum[j] = Sum from i=1..N of cos(two.omega.t[j,i])
    cos.sum = rowSums(cos(two.omega.t))

    # Consistent with the Fortran code
    # two.omega.tau[j] = atan(sin.sum[j] / cos.sum[j])
    two.omega.tau <- atan(sin.sum / cos.sum)
#    # Consistent with the paper.
#    # two.omega.tau[j] = atan2(sin.sum[j], cos.sum[j])
#    two.omega.tau <- atan2(sin.sum, cos.sum)

    # Consistent with the Fortran code
    # two.omega.tau[j] / (2*pi)
    two.omega.tau / (2*pi)
#    # Consistent with the paper.
#    # two.omega.tau[j] / (2*omega[j])
#    two.omega.tau / two.omega

}


# ......................................................................................
# ..........Exercise 6 - Selected distributions of a continuous random variable.........
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

#  Overview of distributions and their functions ####
#
# * Introduction: Probability Density, Distribution Function and Quantile Function ####
#
# ** Probability density ####
#
# - starts with the letter **d**: p=d...(x,...)
#
# ** Distribution function ####
#
# - starts with the letter **p**: $p = P(X < x)$:p=p...(x,...)
#
# ** Quantile function ####
#
# - starts with the letter **q**: find x for the given p: $p = F(x) \rightarrow x =
# F^{-1}(p)$: x=q...(p,...)
#

# * Uniform distribution: $X \sim U(a, b)$ ####
#
# - the random variable takes on only values greater than a and less than b
#
# - all values have the same occurrence density ->the probability density is constant
# between a and b, elsewhere zero
#

# Probability density f(x)
a = 2   # from where
b = 4   # up to
x = 3
dunif(x, a, b)

# we plot the probability density
x = seq(from = 0, to = 6, by = 0.01)
f_x = dunif(x, a, b)
plot(x, f_x, cex = 0.1) # cex is the size of the markers
grid()

# Distribution function F(x)=P(X<x)
a = 2   # from where
b = 4   # where
x = 3
punif(x, a, b)

# let's draw the Distribution function
x = seq(from = 0, to = 6, by = 0.01)
F_x = punif(x, a, b)
plot(x, F_x, type = 'l')
grid()

# quantile function F ^(- 1)(p)=x: P(X<x)=p
a = 2   # from where
b = 4   # where
p = 0.75
qunif(p, a, b)

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.01)
x = qunif(p, a, b)
plot(p, x, type = 'l')
grid()

# * Exponential distribution: $X \sim Exp(\lambda)$ ####
#
# - time to 1st event, time between events(only in the period of stable life - Poisson
# process)
#
# - the parameter $\lambda$ is the same as in the Poisson distribution
#
# - the mean value is: $E(X)=1 / \lambda$
#

# Probability density f(x)
lambda = 2
x = 1
dexp(x, lambda)

# we plot the probability density
x = seq(from = 0, to = 6, by = 0.01)
f_x = dexp(x, lambda)
plot(x, f_x, type='l')
grid()

# Distribution function F(x)=P(X<x)
lambda = 2
x = 1
pexp(x, lambda)

# let's draw the Distribution function
x = seq(from = 0, to = 6, by = 0.01)
F_x = pexp(x, lambda)
plot(x, F_x, type = 'l')
grid()

# quantile function F ^(- 1)(p)=x: P(X<x)=p
lambda = 2
p = 0.5
qexp(p, a, b)

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.001)
x = qexp(p, lambda)
plot(p, x, type = 'l')
grid()

# * Weibull distribution: $X \sim W(\theta,\beta)$ ####
#
# - time until the 1st event(faults)(suitable choice of β allows use in any period of
# fault intensity)
#
# - extension of exponential distribution Exp(λ)=W(Θ=1/λ, β=1)
#

# Probability density f(x)
theta = 1/2 # equivalent of 1/lambda in exp. distribution
beta = 1  # beta=1 ->exponential distribution
x = 5
dweibull(x,shape=beta, scale=theta)

# we plot the probability density
x = seq(from = 0, to = 6, by = 0.01)
f_x = dweibull(x,shape=beta, scale=theta)
plot(x, f_x, type='l')
grid()

# Distribution function F(x)=P(X<x)
theta = 3 # equivalent of 1/lambda in exp. distribution
beta = 2  # beta=1 ->exponential distribution
x = 5
pweibull(x,shape=beta, scale=theta)

# we draw the Distribution function
x = seq(from = 0, to = 6, by = 0.01)
F_x = pweibull(x,shape=beta, scale=theta)
plot(x, F_x, type = 'l')
grid()

# quantile function F ^(- 1)(p)=x: P(X<x)=p
theta = 3 # equivalent of 1/lambda in exp. distribution
beta = 2  # beta=1 ->exponential distribution
p = 0.5
qweibull(p,shape=beta, scale=theta)

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.01)
x = qweibull(p,shape=beta, scale=theta)
plot(p, x, type = 'l')
grid()

# * Normal distribution: $X \sim N(\mu,\sigma^2)$ ####
#
# - distribution modeling eg. measurement errors, sum/average behavior of many other
# random variables
#
# - viz. Central limit theorem
#
# - $\mu$ is the average distribution value: $E(X)=\mu$
#
# - $\sigma$ is the directly standard deviation of the distribution: $D(X)=\sigma^2$
#
# - with parameters $\mu=0,\sigma=1$ is called normalized Normal distribution
#

# Probability density f(x)
mu = 2
sigma = 3
x = 4
dnorm(x, mean=mu, sd=sigma)

# we plot the probability density
x = seq(from = -5, to = 10, by = 0.01)
f_x = dnorm(x, mean=mu, sd=sigma)
plot(x, f_x, type='l')
grid()

# Distribution function F(x)=P(X<x)
mu = 2
sigma = 3
x = 4
pnorm(x, mean=mu, sd=sigma)

# let's draw the Distribution function
x = seq(from = -5, to = 10, by = 0.01)
F_x = pnorm(x, mean=mu, sd=sigma)
plot(x, F_x, type = 'l')
grid()

# quantile function F ^(- 1)(p)=x: P(X<x)=p
mu = 2
sigma = 3
p = 0.5
qnorm(p, mean=mu, sd=sigma)

# plot - quantile function F ^(- 1)(p)=x
p = seq(from=0, to=1, by=0.01)
x = qnorm(p, mean=mu, sd=sigma)
plot(p, x, type = 'l')
grid()

#  Examples ####
#

# * Example 1. ####
#
# Height in the population of boys aged 3.5-4 years has a normal distribution with a
# mean value of 102 cm and a standard deviation of 4.5 cm. Determine what percentage of
# boys at that age are less than or equal to 93 cm in height.
#

# X... height of boys aged 3.5 to 4 years(cm)
# X~N(mu=102, sd=4.5)

mu = 102
sigma = 4.5

# P(X<=93)=F(93)
pnorm(93, mean=mu, sd=sigma)

# * Example 2. ####
#
# The average life of a machine part is 30,000 hours. Assume that the component is in a
# period of stable life. Specify:
#

# X... component life(h)
# X~Exp(lambda), where E(X)=1/lambda

lambda = 1/30000

# ** a) ####
#
# probability that the component will not last more than 2,000 hours,
#

# a) P(X<2000)=F(2000)
pexp(2000, lambda)

# ** b) ####
#
# probability that the component will last more than 35,000 hours,
#

# b) P(X>35000)=1-F(35000)
1 - pexp(35000, lambda)

# ** c) ####
#
# time until 95% of the components fail.
#

# c) P(X<t)=0.95 ->F(t)=0.95 ->t… 95% quantile
qexp(0.95, lambda)

# * Example 3. ####
#
# The production facility fails on average once every 2000 hours. The quantity Y
# representing the time before the fault has an exponential distribution. Determine the
# time T0 so that the probability that the device will run longer than T0 is 0.99.
#

# X... fault waiting time(h)
# X~Exp(lambda), where E(X)=1/lambda
lambda = 1/2000

# P(X>t)=0.99 ->1-F(t)=0.99 ->F(t)=0.01 ->t… 1% quant.
qexp(0.01, lambda)

# * Example 4. ####
#
# The measurement results are corrupted only with a normally distributed error with zero
# mean and a standard deviation of 3 mm. What is the probability that there will be an
# error in the interval(0 mm; 2.4 mm) at least once in 3 measurements?
#

# Y measurement error size(mm)
# Y~N(mu=0, sigma=3)

mu = 0
sigma = 3

# pp… true that the measurement error will be in int. 0.0-2.4mm
pp = pnorm(2.4,mean=mu,sd=sigma) - pnorm(0,mean=mu,sd=sigma)
pp

# X… number of measurement errors in int. 0 mm -2.4 mm in 3 measures.
# X~Bi(n=3, p=pp)
n = 3
p = pp

# P(X>=1)=1-P(X=0)
1 - dbinom(0, n, p)

# * Example 5. ####
#
# An average of 25 users per hour log on to a large computer network. Determine the
# probability that:
#
# ** a) ####
#
# no one logs in during 14:30 - 14:36,
#

# X… number of users logged in in 6 minutes
# X~Po(lt=2.5)

lambda = 25/60
t = 6
lt = lambda*t

# P(X=0)
dpois(0, lt)

# ** b) ####
#
# 2-3 minutes will elapse before the next login.
#

# Y… time until next login
# Y~Exp(lambda=25/60), where E(X)=1/lambda
lambda = 25/60

# P(2<Y<3)=F(3) -F(2)
pexp(3, lambda) - pexp(2, lambda)

# ** c) ####
#
# Specify the maximum length of the time interval so that the probability that no one
# will log in is at least 0.90.
#

# P(Y>t)=0.90 ->1-F(t)=0.90 ->F(t)=0.10 ->t… 10% kv.

qexp(0.10, lambda)*60

# * Example 6. ####
#
# The random variable X has a normal distribution N(µ; σ). Specify:
#
# ** a) ####
#
# P(µ - 2σ<X<µ + 2σ),
#

# P(µ - 2σ<X<µ + 2σ)=F(µ + 2σ) - F(µ - 2σ)
# X~N(µ, σ)
# it doesn't matter what values we choose
mu = -105.5447
sigma = 2.654

pnorm(mu + 2*sigma, mean=mu, sd=sigma) -
pnorm(mu - 2*sigma, mean=mu, sd=sigma)

# ** b) ####
#
# smallest k ∈ Z, so that P(µ - kσ<X<µ + kσ)>0.99.
#

# normal distribution is symmetric
# P(µ - kσ<X<µ + kσ)=
# 1 -(P(X<µ - kσ) + P(X>µ + kσ))=
# 1 - 2 * P(X>µ + kσ)=0.99 ->P(X>µ + kσ)=0.005
# ->P(X<µ + kσ)=0.995

# x=µ + kσ
x = qnorm(0.995, mean=mu, sd=sigma)
(x - mu)/sigma

for(k in 1:5){
    p = pnorm(mu + k*sigma, mean=mu, sd=sigma) -
        pnorm(mu - k*sigma, mean=mu, sd=sigma)
    print(paste0(k,":",p))
}

# * Example 7. ####
#
# An accompanying film about the life of the author of the exhibited works is screened
# on a tour of the exhibition. His screening begins every 20 minutes. Determine the
# probability that if you come to the screening room at random time (and you have no
# clue about screening shedule),
#

# Y… time until the start of the next projection
# Y~Ro(a=0, b=20)

a = 0
b = 20

# ** a) ####
#
# you won't have to wait more than 5 minutes for the movie to start,
#

# P(X<5)
punif(5, a, b)

# ** b) ####
#
# you will wait between 5 and 10 minutes,
#

# P(5<X<10)
punif(10, a, b) - punif(5, a, b)

# ** c) ####
#
# mean and standard deviation of the waiting time for the beginning of the movie.
#

E_X = (a + b)/2
E_X

D_X = (a - b)^2/12
D_X

sigma_X = sqrt(D_X)
sigma_X

# * Example 8. ####
#
# During quality control, we only accept the part if its dimension is in the range of
# 26-27 mm. The dimensions of the components have a normal distribution with a mean
# value of 26.4 mm and a standard deviation of 0.2 mm. What is the probability that the
# size of the part randomly selected for inspection will be within the required limits?
#

# X... part size(mm)
# X~N(mu=26.4, sigma=0.2)

mu = 26.4
sigma = 0.2

# P(26<X<27)=F(27) -F(26)
pnorm(27, mean=mu, sd=sigma) - pnorm(26, mean=mu, sd=sigma)

# * Example 9. ####
#
# The length of jumps of the athlete Jakub measured in cm has a normal distribution
# N(µ1; σ1), where µ1=690 and σ1=10. The length of jumps of the athlete Aleš measured in
# cm also has a normal distribution N(µ2; σ2), where µ2=705 and σ2=15. The one who jumps
# more than 700 cm from two jumps at least once qualifies for the races.
#

# SJ... length of Jakub's jump
# SJ~N(mu=690, sigma=10)
mu_J = 690
sigma_J = 10

# SA Ale Aleš's jump length
# SA~N(mu=705, sigma=15)
mu_A = 705
sigma_A = 15

# J... Jakub's jump is successful(longer than 700 cm)
# And... Aleš's jump is successful(longer than 700 cm)

# P(J)=P(SJ>700)=1-F(700)
P.J = 1-pnorm(700,mean=mu_J,sd=sigma_J)
P.J

# P(A)=P(SA>700)=1-F(700)
P.A = 1-pnorm(700,mean=mu_A, sd=sigma_A)
P.A

# KJ… Jakub qualifies for races,
# P(KJ)=1-(1-P(J))(1-P(J))
P.KJ=1-(1-P.J)*(1-P.J)
P.KJ

# KA… Aleš qualifies for races,
# P(KA)=1-(1-P(A))(1-P(A))
P.KA=1-(1-P.A)*(1-P.A)
P.KA

# ** a) ####
#
# How likely are they both to qualify for the race?
#

# ada)
P.KJ*P.KA

# ** b) ####
#
# With what probability does Aleš qualify, but Jakub does not?
#

# adb)
(1-P.KJ)*P.KA


plot(function(x){
  return(plnorm(x,meanlog=(log(0.1)-0.5^2/2),sdlog=0.5))
},xlim=c(0,0.6))
0.1 = exp(mulog+sdlog^2/2)
log(0.1) = mulog + sdlog^2/2
mulog = log(0.1) - sdlog^2/2
log(0.1)-0.5^2/2

plot(function(x){
  return(plnorm(x,meanlog=(log(0.1)-0.6^2/2),sdlog=0.6))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(pnorm(x,mean=0.1,sd=0.025))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(plnorm(x,meanlog=(log(0.1)-0.25^2/2),sdlog=0.25))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(plnorm(x,meanlog=(log(0.12)-0.5^2/2),sdlog=0.5))
},xlim=c(0,0.6),add=TRUE)

plot(function(x){
  return(plnorm(x,meanlog=(log(0.12)-0.6^2/2),sdlog=0.6))
},xlim=c(0,0.6),add=TRUE)

mu.1 = 0.12
mu.2 = exp(2*(log(0.12)-0.5^2/2)+0.5^2)*(exp(0.5^2)-1) + mu.1^2
mu.1^2/(mu.2)
nlminb(1, function(x) {return((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2)})
plot(function(x) {return(((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2))},
     xlim=c(1,4))
m = 1.957465
eta = 0.12/gamma(1+1/m)
plot(function(x){
  return(pweibull(x,shape=m,scale=eta))
},xlim=c(0,0.6),add=TRUE)

mu.1 = 0.12
mu.2 = exp(2*(log(0.12)-0.6^2/2)+0.6^2)*(exp(0.6^2)-1) + mu.1^2
mu.1^2/(mu.2)
nlminb(1, function(x) {return((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2)})
plot(function(x) {return(((mu.1^2*gamma(1+2/x)-mu.2*gamma(1+1/x)^2)^2))},
     xlim=c(1,4))
m = 1.551332
eta = 0.12/gamma(1+1/m)
plot(function(x){
  return(pweibull(x,shape=m,scale=eta))
},xlim=c(0,0.6),add=TRUE)


library(MASS)
getPriorProbabilities <- function (dset, column) {
  dsetLength <- dim(dset)[1]
  return (table(dset[, column]) / dsetLength)
}

getCovMatrix <- function(dset, expectation) {
  featureTypesCount <- dim(dset)[2]
  dsetLength <- dim(dset)[1]
  cov <- matrix(0, nrow = featureTypesCount - 1, ncol = featureTypesCount - 1)

  for (i in 1:dsetLength) {
    currentFeature <- as.matrix(dset[i, 1:featureTypesCount - 1], nrow = 1)
    tmp <- t(currentFeature - expectation) %*% (currentFeature - expectation)
    cov <- cov + tmp
  }
  cov <- cov / (dsetLength - 1)

  return(cov)
}

getLikelihood <- function(point, expectation, covMatrix) {
  pointMinusMean <- t(as.matrix(point - expectation))

  covMatrixInverse <- solve(covMatrix)
  nom <- exp(-(pointMinusMean %*% covMatrixInverse %*% t(pointMinusMean)) / 2)
  denom <- sqrt((2 * pi) ^ nrow(covMatrix) * det(covMatrix))

  return(nom / denom)
}

getPlugInProbability <- function(dset, classesColumn, className, point, lambda) {
  featuresCount <- length(point)
  croppedDset <- dset[which(dset[, classesColumn] == className), ]
  dsetLength <- dim(dset)[1]

  prior <- getPriorProbabilities(dset, classesColumn)[className]

  expectations <- array(dim = featuresCount)
  for (i in 1:featuresCount) {
    expectations[i] <- mean(croppedDset[, i])
  }

  # lambda = rep(1, featuresCount)
  covMatrix <- getCovMatrix(croppedDset, matrix(expectations, nrow=1))
  likelihood <- getLikelihood(point, expectations, covMatrix)

  probability <- lambda * prior * likelihood;

  return (probability)
}

plugInClassifier <- function(point, dset) {
  classes <- unique(dset[, 3])
  classesCount <- length(classes)
  scores <- array(dim = classesCount)
  for (i in 1:classesCount) {
    scores[i] <- getPlugInProbability(dset, 'class', classes[i], point, lambdas[i])
  }
  return(classes[which.max(scores)])
}

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

dset = data.frame(x = double(), y = double(), class = character())

dset <- rbind(dset, data.frame(x = 0, y = 2, class = 1))
dset <- rbind(dset, data.frame(x = 2, y = 0, class = 1))
dset <- rbind(dset, data.frame(x = 2.5, y = 2.5, class = 1))
dset <- rbind(dset, data.frame(x = 2.8, y = 2.8, class = 1))

dset <- rbind(dset, data.frame(x = 2, y = 4.5, class = 2))
dset <- rbind(dset, data.frame(x = 4.5, y = 2, class = 2))
dset <- rbind(dset, data.frame(x = 6, y = 6, class = 2))
dset <- rbind(dset, data.frame(x = 6, y = 5, class = 2))
dset <- rbind(dset, data.frame(x = 5, y = 6, class = 2))
dset <- rbind(dset, data.frame(x = 3, y = 5.5, class = 2))
dset <- rbind(dset, data.frame(x = 5.5, y = 3, class = 2))

plot(dset[ ,1], dset[ ,2], pch=21, bg=c("green","blue")[dset[ ,3]])

# print(plugInClassifier(c(0, 0), dset))
# # print(getPlugInProbability(dset, 3, 1, c(0, 0), 1))

## generating map
colors <- c("1" = "green", "2" = "blue")
xs <- seq(from = -5, to = 7, by = 0.2)
ys <- seq(from = -5, to = 7, by = 0.2)
## lambdas <- runif(2, min=1, max=100)
lambdas = c(1, 1)
print(lambdas)

all <- length(xs) * length(ys)
progress = 1
for (i in xs) {
  for (j in ys) {
    cat("\rProcessing point", progress, "of", all)
    progress <- progress + 1
    result <- plugInClassifier(c(i, j), dset)
    points(i, j, col = colors[result], pch = 21)
  }
}
cat("\rDone.                      \n")


#Example : 1   Chapter : 2.1  Pageno : 37
#Multiplication by rows and cols dotproduct.
multiply<-function(A,x){
  b<-c()
  for(i in 1:3){
    b<-c(b,sum(A[i,]*x[,1]))
  }
  b<-matrix(b,ncol=1)
  print(paste("Multiplying matrices by dotproduct of rows and cols"))
  print(A)
  print("*")
  print(x)
  print("=")
  print(b)
}

I<-matrix(c(1,0,0,0,1,0,0,0,1),ncol=3,byrow=T)
x<-matrix(c(4,5,6),ncol=1)
A=matrix(c(1,1,1,0,0,0,0,0,0),ncol=3)
multiply(A,x)
A<-matrix(c(1,0,0,0,1,0,0,0,1),nrow=3,ncol=3,byrow=T)
multiply(A,x)


euclidean <- function(a, b) {
  return (sqrt(sum((a - b) ^ 2)))
}

fast_cvloo_knn <- function() {
  maxK <- length(iris[,1]) - 1
  classes = unique(iris$Species)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(iris[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 1:4], iris[i, 1:4])
    }
    sortedDataset <- irisSubset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == iris$Species[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  for (i in 1:length(ans)) {

    ans[i] = ans[i] / length(iris[,1] - 1)
  }

  return (ans)
}

stats <- fast_cvloo_knn()

print(stats)
print(paste("The best K: ", which.max(stats)))

par(mfrow=c(1,1))
plot(1:(length(iris[,1]) - 1), stats, type="l", xlab="k", ylab="Accuracy")

-1 - Fast CV LOO implementation, the best K search for 1-4 iris features/-1.r


## Author: Sergio García Prado

rm(list = ls())

## a)
####

## Asymptotic distibution of (lambda1.hat, lambda2.hat) as parameters lambda1 of Pois(lambda1) and
## lambda2 of Pois(lambda2) independent of each other.
##
## (lambda1.hat, lambda2.hat) ~ N_2( (lambda1, lambda2) , [lambda1 / n, 0;
##                                                         0, lambda2 / n] )
##

## b)
####
n1 <- 50
y1 <- 75

n2 <- 50
y2 <- 100

n <- c(n1, n2)
y <- c(y1, y2)

alpha <- 0.05

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

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

opt <- optim(runif(2), NegativeLogLikelihood, y = y, n = n, hessian = TRUE)

(lambda.hat <- opt$par)
#

(lambda.hat.var <- solve(opt$hessian))
#
#

g.transform <- c(-2, 1)

(g.hat <- (g.transform %*% lambda.hat)[1])
#

(g.hat.var <- (g.transform %*% lambda.hat.var %*% g.transform)[1])
#

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

## b)
####
g.zero <- 0

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

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

## b)
####

LogLikelihoodHZero <- function(ll, ...) {
  LogLikelihood(c(2 * ll, ll), ...)
}

NegativeLogLikelihoodHZero <- function(...) {
  - LogLikelihoodHZero(...)
}

opt.hzero <- optim(runif(1), NegativeLogLikelihoodHZero, y = y, n = n,
                   lower = 10e-3, upper = 10e3, method = "Brent")

(LRT <- 2 * (LogLikelihood(lambda.hat, y, n) - LogLikelihoodHZero(opt.hzero$par, y, n)))
#

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


# Chapter 1 Conditional Flow
# Comparison of logicals
TRUE == FALSE
# FALSE

# Comparison of numerics
-6*14 != 17-101
# FALSE

# Comparison of character strings
"useR" == "user"
# FALSE

# Compare a logical with a numeric
TRUE == 1
# TRUE

# Comparison of numerics
-6*5+2 >= -10+1
# FALSE

# Comparison of character strings
"raining" <= "raining dogs"
# TRUE

# Comparison of logicals
TRUE > FALSE
# TRUE

# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)

# Popular days
linkedin > 15
# TRUE FALSE FALSE FALSE FALSE  TRUE FALSE

# Quiet days
linkedin <= 5
# FALSE FALSE FALSE  TRUE  TRUE FALSE FALSE

# LinkedIn more popular than Facebook
linkedin > facebook
# FALSE  TRUE  TRUE FALSE FALSE  TRUE FALSE

# The social data has been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)
views <- matrix(c(linkedin, facebook), nrow = 2, byrow = TRUE)

# When does views equal 13?
views == 13
#       [,1]  [,2]  [,3]  [,4]  [,5]  [,6]  [,7]
# [1,] FALSE FALSE  TRUE FALSE FALSE FALSE FALSE
# [2,] FALSE FALSE FALSE FALSE FALSE  TRUE FALSE

# When is views less than or equal to 14?
views <= 14
#       [,1] [,2] [,3]  [,4] [,5]  [,6] [,7]
# [1,] FALSE TRUE TRUE  TRUE TRUE FALSE TRUE
# [2,] FALSE TRUE TRUE FALSE TRUE  TRUE TRUE

# The linkedin and last variable are already defined for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
last <- tail(linkedin, 1)

# Is last under 5 or above 10?
last < 5 | last > 10
# TRUE

# Is last between 15 (exclusive) and 20 (inclusive)?
last > 15 & last <= 20
# FALSE

# The social data (linkedin, facebook, views) has been created for you
ls()

# linkedin exceeds 10 but facebook below 10
linkedin > 10 & facebook < 10
# FALSE FALSE  TRUE FALSE FALSE FALSE FALSE

# When were one or both visited at least 12 times?
linkedin >= 12 | facebook >= 12
# TRUE FALSE  TRUE  TRUE FALSE  TRUE  TRUE

# When is views between 11 (exclusive) and 14 (inclusive)?
views > 11 & views <= 14
#       [,1]  [,2]  [,3]  [,4]  [,5]  [,6] [,7]
# [1,] FALSE FALSE  TRUE FALSE FALSE FALSE TRUE
# [2,] FALSE FALSE FALSE FALSE FALSE  TRUE TRUE

# li_df is pre-loaded in your workspace
ls()
str(li_df)

# Select the second column, named day2, from li_df: second
second <- li_df$day2
# [1]  3 23 18 18 25 20  4  3 22 12 27 13 17 27  6 35 17  6  1 12 15 17 12  8  7
# [26] 25 15 32 29  1 22 11  5 17 12 26 13 10 37 33 19 29  8 22 10 19 27 18 15 28

# Build a logical vector, TRUE if value in second is extreme: extremes
extremes <- second > 25 | second < 5

# Count the number of TRUEs in extremes
sum(extremes)
# 16

# Variables related to your last day of recordings
medium <- "LinkedIn"
num_views <- 14

# Control structure for medium
if (medium == "LinkedIn") {
  print("Showing LinkedIn information")
} else if (medium == "Facebook") {
  # Add code to print correct string when condition is True
  print("Showing Facebook information")
} else {
  print("Unknown medium")
}

# Control structure for num_views
if (num_views > 15) {
  print("You're popular!")
} else if (num_views <= 15 & num_views > 10) {
  # Add code to print correct string when condition is TRUE
  print("Your number of views is average")
} else {
  print("Try to be more visible!")
}

# Variables related to your last day of recordings
li <- 15
fb <- 9

# Code the control-flow construct
if (li > 15 & fb > 15) {
    sms <- c(sum(li) * 2 + sum(fb) * 2)
} else if (li < 10 & fb < 10) {
    sms <- c(sum(li) / 2 + sum(fb) / 2)
} else {
    sms <- c(sum(li) + sum(fb))
}

# Print the resulting sms to the console
sms

#
#
#
#
#
# Chapter 2 Loop
# Initialize the speed variable
speed <- 64

# Code the while loop
while ( speed > 30) {
  print("Slow down!")
  speed = speed -7
}

# Extend/adapt the while loop
while (speed > 30) {
  print(paste("Your speed is",speed))
  if (speed > 48 ) {
    print("Slow down big time!")
    speed = speed - 11
  } else {
    print("Slow down!")
    speed = speed - 6
  }
}

# Initialize the speed variable
speed <- 88

while (speed > 30) {
  print(paste("Your speed is", speed))

  # Break the while loop when speed exceeds 80
  if (speed > 80) {
    break
  }

  if (speed > 48) {
    print("Slow down big time!")
    speed <- speed - 11
  } else {
    print("Slow down!")
    speed <- speed - 6
  }
}

# Initialize i as 1
i <- 1

# Code the while loop
while (i <= 10) {
  print(3 * i)
  if ((3 * i %% 8) == 0) {
    break
  }
  i <- i + 1
}

# The linkedin vector has already been defined for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)

# Loop version 1
for ( i in linkedin){
    print(i)
}

# Loop version 2
for (i in 1:length(linkedin)) {
    print(linkedin[i])
}

# The nyc list is already specified
nyc <- list(pop = 8405837,
            boroughs = c("Manhattan", "Bronx", "Brooklyn", "Queens", "Staten Island"),
            capital = FALSE)

# Loop version 1
for (i in nyc) {
    print(i)
}

# Loop version 2
for (i in 1:length(nyc)) {
    print(nyc[[i]])
}

# The tic-tac-toe matrix ttt has already been defined for you
#      [,1] [,2] [,3]
# [1,] "O"  NA   "X"
# [2,] NA   "O"  "O"
# [3,] "X"  NA   "X"

# define the double for loop
for (x in 1:nrow(ttt)){
    for (y in 1:ncol(ttt)){
        print(paste("On row ", x, " and column ", y, " the board contains ", ttt[x,y]))
    }
}

for (li in linkedin) {
  if (li > 10) {
    print("You're popular!")
  } else {
    print("Be more visible!")
  }

  # Add if statement with break
  if (li > 16){
    print("This is ridiculous, I'm outta here!")
    break
  }

  # Add if statement with next
  if (li < 5) {
    print("This is too embarrassing!")
    next
  }

  print(li)
}

# Pre-defined variables
rquote <- "r's internals are irrefutably intriguing"
chars <- strsplit(rquote, split = "")[[1]]

# Initialize rcount
rcount <- 0

# Finish the for loop
for (char in chars) {
  if (char == "r"){
    rcount <- rcount + 1
  } else if (char == "u") {
    break
  }
}

# Print out rcount
print(rcount)

#
#
#
#
#
# Chapter 3 Functions
# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, 2, 17, 14)
facebook <- c(17, 7, 5, 16, 8, 13, 14)

# Calculate the mean of the sum
avg_sum <- sum(mean(linkedin + facebook))
# 22.28571

# Calculate the trimmed mean of the sum
avg_sum_trimmed <- sum(mean(linkedin + facebook,trim = 0.2))
# 22.6

# The linkedin and facebook vectors have already been created for you
linkedin <- c(16, 9, 13, 5, NA, 17, 14)
facebook <- c(17, NA, 5, 16, 8, 13, 14)

# Basic average of linkedin
print(mean(linkedin))
# NA

# Advanced average of linkedin
print(mean(linkedin, na.rm = TRUE ))
# 12.33333

# Calculate the mean absolute deviation
print(mean(abs(linkedin - facebook),na.rm = TRUE))
# 4.8

# Create a function pow_two()
pow_two <- function(x) {
    x**2
}

# Use the function
pow_two(12)

# Create a function sum_abs()
sum_abs <- function(x, y) {
    abs(x) + abs(y)
}

# Use the function
sum_abs(-2, 3)

# Define the function hello()
hello <- function() {
    print("Hi there!")
    return(TRUE)
}

# Call the function hello()
hello()

# Define the function my_filter()
my_filter <- function(x) {
    if (x > 0) {
        return(x)
    } else {
        return(NULL)
    }
}

# Finish the pow_two() function
pow_two <- function(x, print_info = TRUE) {
  y <- x ^ 2

  # Add if construct
  if (print_info == TRUE) {
    print(paste(x, "to the power two equals", y))
  }

  return(y)
}

two_dice <- function() {
  possibilities <- 1:6
  dice1 <- sample(possibilities, size = 1)
  dice2 <- sample(possibilities, size = 1)
  dice1 + dice2
}

# The linkedin and facebook vectors have already been created for you

# Define the interpret function
interpret <- function(num_views) {
  if (num_views > 15) {
    print("You're popular!")
    return(num_views)
  } else {
    print("Try to be more visible!")
    return(0)
  }
}

# Call the interpret function twice
interpret(linkedin)
# [1] "You're popular!"
# [1] 16  9 13  5  2 17 14
interpret(facebook[2])
# [1] "Try to be more visible!"
# [1] 0

# Define the interpret_all() function
# views: vector with data to interpret
# return_sum: return total number of views on popular days?
interpret_all <- function(views, return_sum = TRUE) {
  count <- 0

  for (v in views) {
    count <- count + interpret(v)
  }

  if (return_sum) {
    return(count)
  } else {
    return(NULL)
  }
}

# Call the interpret_all() function on both linkedin and facebook
interpret_all(linkedin)
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] 33
interpret_all(facebook)
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "You're popular!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] "Try to be more visible!"
# [1] 33

# The mtcars vectors have already been prepared for you
wt <- mtcars$wt
hp <- mtcars$hp

# Request the currently attached packages
search()

# Load the ggplot2 package
library(ggplot2)

# Retry the qplot() function
qplot(wt)
qplot(hp)

# Check out the currently attached packages again
search()

#
#
#
#
#
# Chapter 4 The Apply Family
# The vector pioneers has already been created for you
pioneers <- c("GAUSS:1777", "BAYES:1702", "PASCAL:1623", "PEARSON:1857")

# Split names from birth year
split_math <- strsplit(pioneers, split = ":")
# List of 4
#  $ : chr [1:2] "GAUSS" "1777"
#  $ : chr [1:2] "BAYES" "1702"
#  $ : chr [1:2] "PASCAL" "1623"
#  $ : chr [1:2] "PEARSON" "1857"

# Convert to lowercase strings: split_low
split_low <- lapply(split_math, tolower)
# List of 4
#  $ : chr [1:2] "gauss" "1777"
#  $ : chr [1:2] "bayes" "1702"
#  $ : chr [1:2] "pascal" "1623"
#  $ : chr [1:2] "pearson" "1857"

# Write function select_first()
select_first <- function(x) {
  x[1]
}

# Apply select_first() over split_low: names
names <- lapply(split_low,select_first)
# [[1]]
# [1] "gauss"

# [[2]]
# [1] "bayes"

# [[3]]
# [1] "pascal"

# [[4]]
# [1] "pearson"

# Write function select_second()
select_second <- function(x) {
  x[2]
}

# Apply select_second() over split_low: years
years <- lapply(split_low,select_second)
# [[1]]
# [1] "1777"

# [[2]]
# [1] "1702"

# [[3]]
# [1] "1623"

# [[4]]
# [1] "1857"

# Transform: use anonymous function inside lapply
names <- lapply(split_low, function(x) {x[1]})

# Transform: use anonymous function inside lapply
years <- lapply(split_low, function(x) {x[2]})

# Generic select function
select_el <- function(x, index) {
  x[index]
}

# Use lapply() twice on split_low: names and years
names <- lapply(split_low, select_el, index = 1)
years <- lapply(split_low, select_el, index = 2)

# Use lapply() to find each day's minimum temperature
lapply(temp,min)

# Use sapply() to find each day's minimum temperature
sapply(temp,min)

# Use lapply() to find each day's maximum temperature
lapply(temp,max)

# Use sapply() to find each day's maximum temperature
sapply(temp,max)

# temp is already defined in the workspace

# Finish function definition of extremes_avg
extremes_avg <- function(x) {
  ( min(x) + max(x) ) / 2
}

# Apply extremes_avg() over temp using sapply()
sapply(temp, extremes_avg)
# 4.0 9.0 2.5 2.5 5.5 3.0 5.0

# Apply extremes_avg() over temp using lapply()
lapply(temp, extremes_avg)
# [[1]]
# [1] 4

# [[2]]
# [1] 9

# [[3]]
# [1] 2.5

# [[4]]
# [1] 2.5

# [[5]]
# [1] 5.5

# [[6]]
# [1] 3

# [[7]]
# [1] 5

# Create a function that returns min and max of a vector: extremes
extremes <- function(x) {
  c(min = min(x), max = max(x))
}

# Apply extremes() over temp with sapply()
sapply(temp, extremes)
#     [,1] [,2] [,3] [,4] [,5] [,6] [,7]
# min   -1    5   -3   -2    2   -3    1
# max    9   13    8    7    9    9    9

# Apply extremes() over temp with lapply()
lapply(temp, extremes)
# [[1]]
# min max
#  -1   9

# [[2]]
# min max
#   5  13

# [[3]]
# min max
#  -3   8

# [[4]]
# min max
#  -2   7

# [[5]]
# min max
#   2   9

# [[6]]
# min max
#  -3   9

# [[7]]
# min max
#   1   9

# Definition of below_zero()
below_zero <- function(x) {
  return(x[x < 0])
}

# Apply below_zero over temp using sapply(): freezing_s
freezing_s <- sapply(temp, below_zero)
# [[1]]
# [1] -1

# [[2]]
# numeric(0)

# [[3]]
# [1] -1 -3

# [[4]]
# [1] -2

# [[5]]
# numeric(0)

# [[6]]
# [1] -3

# [[7]]
# numeric(0)

# Apply below_zero over temp using lapply(): freezing_l
freezing_l <- lapply(temp, below_zero)
# [[1]]
# [1] -1

# [[2]]
# numeric(0)

# [[3]]
# [1] -1 -3

# [[4]]
# [1] -2

# [[5]]
# numeric(0)

# [[6]]
# [1] -3

# [[7]]
# numeric(0)

# Are freezing_s and freezing_l identical?
identical(freezing_s, freezing_l)
# TRUE

# Definition of print_info()
print_info <- function(x) {
  cat("The average temperature is", mean(x), "\n")
}

# Apply print_info() over temp using lapply()
xl <- lapply(temp, print_info)
# The average temperature is 4.8
# The average temperature is 9
# The average temperature is 2.2
# The average temperature is 2.4
# The average temperature is 5.4
# The average temperature is 4.6
# The average temperature is 4.6
# [[1]]
# NULL

# [[2]]
# NULL

# [[3]]
# NULL

# [[4]]
# NULL

# [[5]]
# NULL

# [[6]]
# NULL

# [[7]]
# NULL
# Apply print_info() over temp using sapply()
xs <- sapply(temp, print_info)
# The average temperature is 4.8
# The average temperature is 9
# The average temperature is 2.2
# The average temperature is 2.4
# The average temperature is 5.4
# The average temperature is 4.6
# The average temperature is 4.6
# [[1]]
# NULL

# [[2]]
# NULL

# [[3]]
# NULL

# [[4]]
# NULL

# [[5]]
# NULL

# [[6]]
# NULL

# [[7]]
# NULL

# Great! Notice here that, quite surprisingly,
# sapply() does not simplify the list of NULL's.
# That's because the 'vector-version' of a list of
# NULL's would simply be a NULL, which is no longer
# a vector with the same length as the input.

# Definition of basics()
basics <- function(x) {
  c(min = min(x), mean = mean(x), max = max(x))
}

# Apply basics() over temp using vapply()
vapply(temp, basics, numeric(3))
#      [,1] [,2] [,3] [,4] [,5] [,6] [,7]
# min  -1.0    5 -3.0 -2.0  2.0 -3.0  1.0
# mean  4.8    9  2.2  2.4  5.4  4.6  4.6
# max   9.0   13  8.0  7.0  9.0  9.0  9.0

# Convert to vapply() expression
sapply(temp, max)
vapply(temp, max, numeric(1))
# [1]  9 13  8  7  9  9  9

# Convert to vapply() expression
sapply(temp, function(x, y) { mean(x) > y }, y = 5)
vapply(temp, function(x, y) { mean(x) > y }, y = 5, logical(1))
# [1] FALSE  TRUE FALSE FALSE  TRUE FALSE FALSE

# work_todos and fun_todos have already been defined
work_todos <- c("Schedule call with team",
                "Fix error in Recommendation System",
                "Respond to Marc from IT")
fun_todos <- c("Sleep", "Make arrangements for summer trip")

# Create a list: todos
todos <- list(work_todos, fun_todos)

# Sort the vectors inside todos alphabetically
sapply(todos, sort)
# [[1]]
# [1] "Fix error in Recommendation System" "Respond to Marc from IT"
# [3] "Schedule call with team"

# [[2]]
# [1] "Make arrangements for summer trip" "Sleep"

#
#
#
#
#
# Chapter 5 Utilities
# abs(): calculate the absolute value.
# sum(): calculate the sum of all the values in a data structure.
# mean(): calculate the arithmetic mean.
# round(): Round the values to 0 decimal places by default.
# seq(): Generate sequences, by specifying the from, to and by arguments.
# rep(): Replicate elements of vectors and lists.
# sort(): Sort a vector in ascending order. Works on numerics, but also on character strings and logicals.
# rev(): Reverse the elements in a data structures for which reversal is defined.
# str(): Display the structure of any R object.
# append(): Merge vectors or lists.
# is.*(): Check for the class of an R object.
# as.*(): Convert an R object from one class to another.
# unlist(): Flatten (possibly embedded) lists to produce a vector.

# The errors vector has already been defined for you
errors <- c(1.9, -2.6, 4.0, -9.5, -3.4, 7.3)

# Sum of absolute rounded values of errors
round(sum(abs(errors)), digits = 0)
# 29

# The linkedin and facebook vectors have already been created for you
linkedin <- list(16, 9, 13, 5, 2, 17, 14)
facebook <- list(17, 7, 5, 16, 8, 13, 14)

# Convert linkedin and facebook to a vector: li_vec and fb_vec
li_vec <- unlist(linkedin)
fb_vec <- unlist(facebook)

# Append fb_vec to li_vec: social_vec
social_vec <- append(li_vec, fb_vec)

# Sort social_vec
sort(social_vec, decreasing = TRUE)
# [1] 17 17 16 16 14 14 13 13  9  8  7  5  5  2

# Create first sequence: seq1
seq1 <- seq(1,500,3)

# Create second sequence: seq2
seq2 <- seq(1200,900,-7)

# Calculate total sum of the sequences
sum(seq1,seq2)
# [1] 87029

# The emails vector has already been defined for you
emails <- c("john.doe@ivyleague.edu", "education@world.gov", "dalai.lama@peace.org",
            "invalid.edu", "quant@bigdatacollege.edu", "cookie.monster@sesame.tv")

# Use grepl() to match for "edu"
grepl("edu",emails)
# [1]  TRUE  TRUE FALSE  TRUE  TRUE FALSE

# Use grep() to match for "edu", save result to hits
hits <- grep("edu", emails)
# [1] 1 2 4 5

# Subset emails using hits
emails[hits]
# [1] "john.doe@ivyleague.edu"   "education@world.gov"
# [3] "invalid.edu"              "quant@bigdatacollege.edu"

# @, because a valid email must contain an at-sign.
# .*, which matches any character (.) zero or more times (*).
# Both the dot and the asterisk are metacharacters. You can use them to match any character between the at-sign and the ".edu" portion of an email address.
# \\.edu$, to match the ".edu" part of the email at the end of the string. The \\ part escapes the dot: it tells R that you want to use the . as an actual character.

# Use grepl() to match for .edu addresses more robustly
grepl("@.*\\.edu$",emails)
# [1]  TRUE FALSE FALSE FALSE  TRUE FALSE

# Use grep() to match for .edu addresses more robustly, save result to hits
hits <- grep("@.*\\.edu$",emails)

# Subset emails using hits
emails[hits]
# [1] "john.doe@ivyleague.edu"   "quant@bigdatacollege.edu"

# Use sub() to convert the email domains to datacamp.edu
sub("@.*\\.edu$","@datacamp.edu",emails)
# [1] "john.doe@datacamp.edu"    "education@world.gov"
# [3] "dalai.lama@peace.org"     "invalid.edu"
# [5] "quant@datacamp.edu"       "cookie.monster@sesame.tv"

# .*: A usual suspect! It can be read as "any character that is matched zero or more times".
# \\s: Match a space. The "s" is normally a character, escaping it (\\) makes it a metacharacter.
# [0-9]+: Match the numbers 0 to 9, at least once (+).
# ([0-9]+): The parentheses are used to make parts of the matching string available to define the replacement.
# The \\1 in the replacement argument of sub() gets set to the string that is captured by the regular expression [0-9]+.

awards <- c("Won 1 Oscar.",
  "Won 1 Oscar. Another 9 wins & 24 nominations.",
  "1 win and 2 nominations.",
  "2 wins & 3 nominations.",
  "Nominated for 2 Golden Globes. 1 more win & 2 nominations.",
  "4 wins & 1 nomination.")

sub(".*\\s([0-9]+)\\snomination.*$", "\\1", awards)

# [1] "Won 1 Oscar." "24"           "2"            "3"            "2"
# [6] "1"

# %Y: 4-digit year (1982)
# %y: 2-digit year (82)
# %m: 2-digit month (01)
# %d: 2-digit day of the month (13)
# %A: weekday (Wednesday)
# %a: abbreviated weekday (Wed)
# %B: month (January)
# %b: abbreviated month (Jan)
# Definition of character strings representing dates
str1 <- "May 23, '96"
str2 <- "2012-03-15"
str3 <- "30/January/2006"

# Convert the strings to dates: date1, date2, date3
date1 <- as.Date(str1, format = "%b %d, '%y")
date2 <- as.Date(str2, format = "%Y-%m-%d")
date3 <- as.Date(str3, format = "%d/%B/%Y")

# Convert dates to formatted strings
format(date1, "%A")
# [1] "Thursday"
format(date2, "%d")
# [1] "15"
format(date3, "%b %Y")
# [1] "Jan 2006"

# %H: hours as a decimal number (00-23)
# %M: minutes as a decimal number
# %S: seconds as a decimal number
# %T: shorthand notation for the typical format %H:%M:%S

# Definition of character strings representing times
str1 <- "May 23, '96 hours:23 minutes:01 seconds:45"
str2 <- "2012-3-12 14:23:08"

# Convert the strings to POSIXct objects: time1, time2
time1 <- as.POSIXct(str1, format = "%B %d, '%y hours:%H minutes:%M seconds:%S")
time2 <- as.POSIXct(str2, format = "%Y-%m-%d %T")

# Convert times to formatted strings
format(time1, format = "%M")
# [1] "01"
format(time2, format = "%I:%M %p" )
# [1] "02:23 PM"

# day1, day2, day3, day4 and day5 are already available in the workspace

# Difference between last and first pizza day
day5-day1
# Time difference of 11 days

# Create vector pizza
pizza <- c(day1, day2, day3, day4, day5)

# Create differences between consecutive pizza days: day_diff
day_diff <- diff(pizza)
# Time differences in days
# [1]  -5  11 -13  18

# Average period between two consecutive pizza days
mean(day_diff)
# Time difference of 2.75 days

# login and logout are already defined in the workspace
# Calculate the difference between login and logout: time_online
time_online <- logout - login

# Inspect the variable time_online
time_online
# Time differences in secs
# [1] 2305.11818   34.18472  837.18182 2397.90153 1851.30411

# Calculate the total time online
sum(time_online)
# Time difference of 7425.69 secs

# Calculate the average time online
mean(time_online)
# Time difference of 1485.138 secs

# Convert astro to vector of Date objects: astro_dates
#        spring        summer          fall        winter
# "20-Mar-2015" "25-Jun-2015" "23-Sep-2015" "22-Dec-2015"
astro_dates <- as.Date(astro, format = "%d-%b-%Y")
# [1] "2015-03-20" "2015-06-25" "2015-09-23" "2015-12-22"

# Convert meteo to vector of Date objects: meteo_dates
    #        spring            summer              fall            winter
    # "March 1, 15"      "June 1, 15" "September 1, 15"  "December 1, 15"
meteo_dates <- as.Date(meteo, format = "%B %d, %y")
# [1] "2015-03-01" "2015-06-01" "2015-09-01" "2015-12-01"

# Calculate the maximum absolute difference between astro_dates and meteo_dates
max(abs(astro_dates-meteo_dates))
# Time difference of 24 days