#' Fisher's Linear Discriminant
#'
#' Compute the 2-class Fisher's linear discriminant either in
#' serial or parallel.
#'
#' @param x
#' The data in the form of a matrix or ddmatrix.
#' @param g
#' The group variable in the form of a matrix/vector or a ddmatrix.
#' The values should be 0 and 1 exclusively.
#'
#' @return
#' A list of class 'fld' containing the prior probabilities, group means,
#' w vector, and c scalar.  In the distributed case, the priors and c scalar
#' are both global, while the other values are distributed.
#'
#' @references
#' Duda, R. O., Hart, P. E., & Stork, D. G. (2012). Pattern classification,
#' chapter 5. John Wiley & Sons.
#'
#' @author
#' Drew Schmidt
#'
#' @examples
#' \dontrun{
#' x <- matrix(rnorm(30), 10)
#' g <- sample(0:1, size=10, replace=TRUE)
#'
#' fld(x, g)
#' }
#'
#' @name fld
#' @rdname fld
#' @export
fld <- function(x, g)
{
  if (!is.ddmatrix(x))
    x <- as.matrix(x)

  # if (!all.sametype(x, g))
  #   comm.stop("arguments 'x' and 'g' must either both be of type 'matrix', or both of type 'ddmatrix'")

  n <- NROW(x)
  if (n != NROW(g))
    comm.stop("argument 'g' must be the same length as 'x'")

  if (!comm.all(check_groupvar(g)))
    comm.stop("argument 'g' must be a vector of only 0's and 1's")

  ### Get group indices/priors
  if (is.ddmatrix(g))
    g <- as.vector(g) ### FIXME

  ind0 <- which(submatrix(g) == 0)
  ind1 <- setdiff(1:n, ind0)

  prior0 <- length(ind0)/n
  prior1 <- length(ind1)/n

  ### Get group covariances and means
  x0 <- x[ind0, , drop=FALSE]
  x1 <- x[ind1, , drop=FALSE]

  cov0 <- cov(x0)
  cov1 <- cov(x1)

  mu0 <- colMeans(x0)
  mu1 <- colMeans(x1)

  ### fld
  mu_sum <- mu0 + mu1
  if (is.ddmatrix(mu_sum))
    mu_sum <- t(mu_sum)

  w <- solve(cov0 + cov1, mu_sum)
  c <- as.vector(0.5 * crossprod(w, mu_sum))

  ### wrangle return
  means <- list(mu0=mu0, mu1=mu1)
  prior <- c("0"=prior0, "1"=prior1)

  ret <- list(prior=prior, means=means, w=w, c=c)
  class(ret) <- "fld"

  return(ret)
}

#' @method print fld
#' @export
print.fld <- function(x, ...)
{
  comm.cat("Prior probabilities of groups:\n", quiet=TRUE)
  comm.print(x$prior, quiet=TRUE)

  comm.cat("\nc =", x$c, "\n", quiet=TRUE)
}


## https://israeldi.github.io/bookdown/_book/monte-carlo-simulation-of-stock-portfolio-in-r-matlab-and-python.html

source('/home/dlhjel/GitHub_repos/R-setup/setup.r')

data <- '
    Date AAPL_Adj_Close GOOG_Adj_Close FB_Adj_Close
11/15/17       166.5791        1020.91       177.95
11/16/17       168.5693        1032.50       179.59
11/17/17       167.6333        1019.09       179.00
11/20/17       167.4658        1018.38       178.74
11/21/17       170.5791        1034.49       181.86
11/22/17       172.3721        1035.96       180.87
11/24/17       172.3820        1040.61       182.78
11/27/17       171.5150        1054.21       183.03
11/28/17       170.5101        1047.41       182.42
11/29/17       166.9732        1021.66       175.13
'
stock_Data = readall(data)
stock_Price = as.matrix( stock_Data[ , 2:4] )

mc_rep = 10 # Number of Monte Carlo Simulations
training_days = 5

# This function returns the first differences of a t x q matrix of data
returns = function(Y){
  len = nrow(Y)
  yDif = Y[2:len, ] / Y[1:len-1, ] - 1
}

# Get the Stock Returns
stock_Returns = returns(stock_Price)

# Suppose we invest our money evenly among all three assets
# We use today's Price 11/14/2018 to find the number of shares each stock
# that we buy
portfolio_Weights = t(as.matrix(rep(1/ncol(stock_Returns), ncol(stock_Returns))))
print(portfolio_Weights)

# Get the Variance Covariance Matrix of Stock Returns
pairs(stock_Returns)
coVarMat = cov(stock_Returns)

# calculate meaan return for each stock
miu = colMeans(stock_Returns)
# Extend the vector to a matrix
Miu = matrix(rep(miu, training_days), nrow = 3)

# Initializing simulated 30 day portfolio returns
portfolio_Returns_30_m = matrix(0, training_days, mc_rep)

set.seed(200)
for (i in 1:mc_rep) {
  Z = matrix ( rnorm( dim(stock_Returns)[2] * training_days ), ncol = training_days )
  # Lower Triangular Matrix from our Choleski Factorization
  L = t( chol(coVarMat) )
  # Calculate stock returns for each day
  daily_Returns = Miu + L %*% Z
  # Calculate portfolio returns for 30 days
  portfolio_Returns_30 = cumprod( portfolio_Weights %*% daily_Returns + 1 )
  # Add it to the monte-carlo matrix
  portfolio_Returns_30_m[,i] = portfolio_Returns_30;
}

# Visualising result
x_axis = rep(1:training_days, mc_rep)
y_axis = as.vector(portfolio_Returns_30_m-1)
plot_data = data.frame(x_axis, y_axis)
ggplot(data = plot_data, aes(x = x_axis, y = y_axis)) + geom_path(col = 'red', size = 0.1) +
  xlab('Days') + ylab('Portfolio Returns') +
  ggtitle('Simulated Portfolio Returns in 30 days')+
  theme_bw() +
    theme(plot.title = element_text(hjust = 0.5))

# Porfolio Returns statistics on the 30th day.
Avg_Portfolio_Returns = mean(portfolio_Returns_30_m[30,]-1)
SD_Portfolio_Returns = sd(portfolio_Returns_30_m[30,]-1)
Median_Portfolio_Returns = median(portfolio_Returns_30_m[30,]-1)
print(c(Avg_Portfolio_Returns,SD_Portfolio_Returns,Median_Portfolio_Returns))

# Construct a 95% Confidential Interval for average returns
Avg_CI = quantile(portfolio_Returns_30_m[30,]-1, c(0.025, 0.975))
print(Avg_CI)


library(pomp)

set.seed(1111)

# Function to simulate one time step
step_fun_R <- function(x, t, params, delta.t, ...){
    S <- x[1]
    I <- x[2]
    R <- x[3]
    N <- S + I + R
    logbeta <- x[4]
    beta <- exp(logbeta)

    gamma = params[1]
    sigma = params[2]
    alpha = params[3]

    newinf <- beta * S * I * delta.t/N
    newdeath <- gamma * I *delta.t
    S <- max(0, S - newinf )
    I <- max(0, I + newinf - newdeath )
    R <- max(0, R + newdeath )
    logbeta <- logbeta + rnorm(1, -alpha * I * delta.t, sd = sigma * sqrt(delta.t) )
    c( S = unname(S) , I  = unname(I), R  = unname(R), logbeta = unname( logbeta ))
}

# Defines pomp object that could be used for simulation or inference
spsir_pomp_R <- pomp ( rprocess = euler.sim( step.fun = step_fun_R, delta.t = .001)
 , t0 = 0
 , statenames = c( 'S', 'I', 'R', 'logbeta')
 , paramnames = c('gamma', 'sigma', 'alpha')
 , data = data.frame( time = seq(0, 10, by=.01), S = NA, I = NA, R = NA, logbeta = NA)
 , time = 'time'
 , initializer = function(params, t0, ... ) c( S = 50, I = 1, R = 0, logbeta = log(3) )
 , rmeasure = function( x, t, params, ... ) x
)

spsir_pomp_R_sol <- simulate(spsir_pomp_R, params = c( gamma = 1, sigma = 1, alpha =  0.1) )

plot( spsir_pomp_R_sol )


cities<-c("c1","c2","c3","c4","c5","c6","c7","c8","c9","c10")
# All possible samples are
t(combn(cities, 2))
total_pairs<-nrow(t(combn(cities, 2)))
# the probability associated with each sample in a random sample of 2 cities selected from the population
probability_selecting2cities<-1/total_pairs
print(probability_selecting2cities)


library(modreg)

postscript("Plots/plot-06-01.ps")
n <- 100
x <- rnorm(n);y <- rnorm(n)
lambda <- seq(0.05,1,len=50)
df <- sapply(lambda,function(l) if(l==0) return(n) else return(sum(loess(y~x,span=l)$trace.hat)))
par(mfrow=c(1,2))
plot(lambda,df,main="Loess",type="l")
lambda <- seq(0.01,2,len=100)
df <- sapply(lambda,function(l) smooth.spline(x,y,spar=l,all.k=T)$df)
plot(lambda,df,main="Smoothing spline",type="l")
dev.off()

###different definitions of degrees of freedom
postscript("Plots/plot-06-02.ps")
n <- 100
x <- sort(runif(n,0,1))
Y <- diag(n)
lambda <- seq(.02,1,len=10)
df <- matrix(0,length(lambda),3)
for(i in 1:length(lambda)){
  l <- lambda[i]
  S <- apply(Y,1,function(yy) loess(yy~x,span=l)$fitted)
  aux1 <- sum(diag(S));aux2 <- sum(diag(S%*%t(S)))
  df[i,] <- c(aux1,aux2,2*aux1-aux2)
}
par(mfrow=c(1,1))
plot(lambda,df[,1],ylim=range(df),type="l",ylab="df",log="y")
lines(lambda,df[,2],lty=2)
lines(lambda,df[,3],lty=3)
legend(.7,range(df)[2]*.95,c("tr(S)","tr(SS')","2tr(S)-tr(SS')"),lty=c(1,2,3))
dev.off()

###might as well draw the columns of the smoothing spline
postscript("Plots/plot-06-03.ps")
n <- 101
x <- sort(runif(n,0,1))
Y <- diag(n)
S <- apply(Y,1,function(yy) smooth.spline(x,yy,spar=.8,all.knots=T)$y)
par(mfrow=c(3,2))
for(i in seq(1,101,len=6))
  plot(x,S[i,],ylab=paste(i,"th row of S",sep=""),type="b")
dev.off()

n <- 30
x <- sort(runif(n,0,1))
##first linear to show example
X <- cbind(1,x)
S <- X%*%solve(t(X)%*%X)%*%t(X)
aux <- eigen(S,symmetric=T)
U <- aux$vector; D <- diag(aux$values) ###S should be UDU'

postscript("Plots/plot-06-04.ps")
par(mfrow=c(1,2),oma=c(0,0,2,0))
plot(diag(D),xlab="",ylab="Eigenvalues")
par(mfrow=c(2,2))
par(mfg=c(1,2))
plot(x,U[,1],xlab="x",ylab="First Eigenvector")
par(mfg=c(2,2))
plot(x,U[,2],xlab="x",ylab="Second Eigenvector")
mtext("Simple linear regression",outer=T,side=3,line=0,cex=1.5)
dev.off()

###NOW for smoothing splines
n <- 30
x <- sort(runif(n,0,1))
postscript("Plots/plot-06-05.ps")
Y <- diag(n)
S <- apply(Y,1,function(yy) smooth.spline(x,yy,spar=.6,all.knots=T)$y)
aux <- eigen(S,symmetric=T)
U <- aux$vector; D <- diag(aux$values) ###S should be UDU'
par(mfrow=c(1,1))
plot(diag(D),xlab="",ylab="Eigenvalues")
dev.off()

postscript("Plots/plot-06-06.ps")
par(mfcol=c(5,2),mai=c(.3,.5,.1,.3),oma=c(0,0,2,0))
for(i in 1:10)
  plot(x,U[,i],xlab="x",ylab=paste(i,"th Eigenvector",sep=""),type="l")
mtext("Smoothing spline",outer=T,side=3,line=0,cex=1.5)
dev.off()

postscript("Plots/plot-06-07.ps")
par(mfcol=c(5,2),mai=c(.3,.5,.1,.3),oma=c(0,0,2,0))
for(i in 11:20)
  plot(x,U[,i],xlab="x",ylab=paste(i,"th Eigenvector",sep=""),type="l")
mtext("Smoothing spline",outer=T,side=3,line=0,cex=1.5)
dev.off()

postscript("Plots/plot-06-08.ps")
par(mfcol=c(5,2),mai=c(.3,.5,.1,.3),oma=c(0,0,2,0))
for(i in 21:30)
  plot(x,U[,i],xlab="x",ylab=paste(i,"th Eigenvector",sep=""),type="l")
mtext("Smoothing spline",outer=T,side=3,line=0,cex=1.5)
dev.off()

###REACT STUFF
n <- 48
x <- (1:n)/n
y <- scan("Data/mouse-bt.dat")
U <- cbind(rep(1/sqrt(n),n),
           sapply(1:(n/2-1),function(k) sqrt(2/n)*cos(2*pi*k*x)),
           sapply(1:(n/2-1),function(k) sqrt(2/n)*sin(2*pi*k*x)),
           1/sqrt(n)*cos(pi*n*x))

postscript("Plots/plot-06-09.ps")
par(mfrow=c(5,2),mai=c(.3,.5,.1,.3),oma=c(0,0,2,0))
for(i in 1:5){
  plot(x,U[,i+1],xlab="x",ylab=paste(i,"th FFT row",sep=""),type="l")
  plot(x,U[,n/2+i],xlab="x",ylab=paste(i,"th FFT row",sep=""),type="l")
}
dev.off()

##fft of data
aux <- fft(y)/sqrt(n)
z <- c(Re(aux[1]),
       as.vector(t(matrix(c(Re(aux[2:(n/2)]),Im(aux[2:(n/2)])),ncol=2))),
       Re(aux[n/2+1]))
##this functions recieves a fft and returns an estimate of f
ifft <- function(z){
  n <- length(z)
  aux <- complex(real=z[seq(2,n-1,2)],im=z[seq(3,n-1,2)])
  yhat <-Re(fft(c(z[1],aux,z[n],rev(Conj(aux))),inv=T)/sqrt(n))
}

postscript("Plots/plot-06-10.ps")
par(mfrow=c(2,2))
for(m in c(1,4,8,23)){
  plot(x,y,main=paste(m,"non zero"))
  zhat <- z*c(rep(1,1+2*m),rep(0,n-2*m-1))
  lines(x,ifft(zhat))
}
dev.off()

###We need to define the average and PAV functions
average_function(y, wt = rep(1, length(y)))
{
# compute a weighted average of a vector, y
        if(any(is.na(wt))) stop("NA's not allowed for wt")
        if(any(wt < 0))
                stop("wt must be a vector of NON-NEGATIVE weights")
        if(length(wt) != length(y)) stop(
                "y and wt must be vectors of the same length")
# if any observations have Infinite weight, return the simple
# (unweighted) average of only those observations (giving no
# weight to observations with finite weight)
        if(any(wt == Inf)) {
                wt[wt < Inf] <- 0
                wt[wt == Inf] <- 1
        }
# if all weights are zero, return the simple (unweighted)
# average of y
        if(sum(wt) == 0)
                wt <- rep(1, length(wt))
        return(sum((y * wt)/sum(wt)))
}

PAV_function(y, wt = rep(1,p))
{
### This is a modification of Derick's PAV program
### (Weighted) Pool-Adjacent-Violators (PAV) algorithm
### for non-parametric monotonic (decreasing) regression of y on x
  n <- length(y)
  if(n != length(wt))
    stop("y, and wt must be vectors of equal length")
  yhat <- y       # initialize while loop
  j <- count <- 1
  k <- 2
  support <- vector("numeric", n)
  support[count] <- j
  while(k <= n) {
    while(yhat[j] < yhat[k]) {
      yhat[j:k] <- average(y[j:k], wt[j:k])
      if(yhat[support[count]] < yhat[k]) {
        j <- support[count]
        if(count > 1)
          count <- count - 1
      }
      else {
        k <- ifelse(k == n, k, k + 1)
      }
    }
    count <- count + 1
    support[count] <- j
    j <- k
    k <- k + 1
  }
  return(y = yhat, wt)
}
postscript("Plots/plot-06-11.ps")
par(mfrow=c(2,2))
plot(x,y,xlab="Time",ylab="Temperature",type="n",main="Harmonic Model")
points(x,y,col=4)
m <- 4
yhat <- z*c(rep(1,1+2*m),rep(0,n-2*m-1))
lines(x,ifft(yhat),col=9)
plot(2:48,abs(z[-1]),xlab="coefficient of z",ylab="Absolute value",type="h")
points(2:(1+2*m),abs(z[2:(1+2*m)]),col=3)
points((2+2*m):n,abs(z[(2+2*m):n]),col=4,pch=4)
abline(h=0)
plot(x,y,xlab="Time",ylab="Temperature",type="n",main="REACT")
points(x,y,col=4)
sigma2 <- .1520197 ##we got this from somewhere else
g <- 1 - sigma2/z^2
fhat <- PAV(g, z^2)$y
fhat <- sapply(fhat, function(x) max(x, 0))
fit1 <- ifft(z*fhat)
lines(x,fit1,col=9)
plot(2:48,abs(z[-1]),xlab="coefficient of z",ylab="Absolute value",type="h")
points(2:n,abs(z[2:n]),col=3)
points(2:n,abs(z*fhat)[-1],col=4,pch=4)
abline(h=0)
dev.off()

postscript("Plots/plot-06-12.ps")
Y <- matrix(scan("Data/all-mouse-bt.dat"),48,12,byrow=T)
Y <- sweep(Y,2,apply(Y,2,mean))
par(mfrow=c(1,1))
plot(rep(x,12),as.vector(Y),xlab="Time",ylab="Temperature")

lines(x,apply(Y,1,mean),lwd=3)
lines(x,fit1-mean(fit1),col=3,lty=2,lwd=3)
lines(x,ifft(yhat)-mean(ifft(yhat)),col=4,lty=3,lwd=3)
legend(0.05,1.5,c("Average","REACT","Harmonic"),lty=c(1,2,3),col=c(1,3,4))
dev.off()

##the rest is code-06.s... becuase of the wavelet module


# Group members (Name, Student ID, E-Mail):
# 1. Baldomero Valdez,  Valenzuela, 2905175, baldmer.w@gmail.com
# 2. Omar Trinidad Gutierrez Mendez, 2850441, omar.vpa@gmail.com
# 3. Shinho Kang, 2890169, wis.shinho.kang@gmail.com

# import package nnet to implement multinomial logistic regression
library(nnet)

# 1. Fit a logistic regression model on iris dataset
# Multinomial logistic regression with nnet package
data(iris)

# shuffle the dataset and get training and test dataset
shuffled.iris <- iris[sample(1:nrow(iris)), ]
test.ds <- shuffled.iris[1:30,]
training.ds <- shuffled.iris[31:150,]

formula <- Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
multinomial.model <- multinom(formula, training.ds)
print(multinomial.model)

#Call:
#multinom(formula = formula, data = training.ds)
#
#Coefficients:
#           (Intercept) Sepal.Length Sepal.Width Petal.Length Petal.Width
#versicolor    15.78584    -5.753264   -6.333713     12.78611   -2.309163
#virginica    -22.61359    -8.586707  -12.026601     22.15053   13.246169
#
#Residual Deviance: 11.38084
#AIC: 31.38084

e = predict(multinomial.model)

# Binomial logistic regression using `glm` function

# for setosa
setosa.ds = shuffled.iris
training.setosa <- setosa.ds[31:150,]
newcol <- data.frame(isSetosa=(training.setosa$Species == 'setosa'))
training.setosa <- cbind(training.setosa, newcol)

formula <- isSetosa ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
model.setosa <- glm(formula, data=training.setosa, family='binomial')
print(model.setosa)
#Call:  glm(formula = formula, family = "binomial", data = training.setosa)
#
#Coefficients:
# (Intercept)  Sepal.Length   Sepal.Width  Petal.Length   Petal.Width
#       8.083         4.034        11.240       -22.097        -4.758
#
#Degrees of Freedom: 119 Total (i.e. Null);  115 Residual
#Null Deviance:      152.8
#Residual Deviance: 2.285e-09    AIC: 10
e = predict(model.setosa, newdata=test.ds, type='response')

# for versicolor
versicolor.ds = shuffled.iris
training.versicolor <- versicolor.ds[31:150,]
newcol <- data.frame(isVersicolor=(training.versicolor$Species == 'versicolor'))
training.versicolor <- cbind(training.versicolor, newcol)

formula <- isVersicolor ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
model.versicolor <- glm(formula, data=training.versicolor, family='binomial')
print(model.versicolor)
#Call:  glm(formula = formula, family = "binomial", data = training.versicolor)
#
#Coefficients:
# (Intercept)  Sepal.Length   Sepal.Width  Petal.Length   Petal.Width
#      7.7785       -0.3307       -2.7866        1.2605       -2.5890
#
#Degrees of Freedom: 119 Total (i.e. Null);  115 Residual
#Null Deviance:      152.8
#Residual Deviance: 115.4        AIC: 125.4
e = predict(model.versicolor, newdata=test.ds, type='response')

# for virginica
virginica.ds = shuffled.iris
training.virginica <- virginica.ds[31:150,]
newcol <- data.frame(isVirginica=(training.virginica$Species == 'virginica'))
training.virginica <- cbind(training.virginica, newcol)

formula <- isVirginica ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
model.virginica <- glm(formula, data=training.virginica, family='binomial')
print(model.virginica)

#Call:  glm(formula = formula, family = "binomial", data = training.virginica)
#
#Coefficients:
# (Intercept)  Sepal.Length   Sepal.Width  Petal.Length   Petal.Width
#     -38.802        -2.830        -5.672         9.420        15.584
#
#Degrees of Freedom: 119 Total (i.e. Null);  115 Residual
#Null Deviance:      152.8
#Residual Deviance: 11.38        AIC: 21.38
e = predict(model.virginica, newdata=test.ds, type='response')


###  power and sample size function for TSLS estimator

TSLS.power=function(n, beta, rho_ZD, sigmau, sigmaDsq, alpha=0.05){
  return(c(1+pnorm(-qnorm(1-alpha/2)-beta*rho_ZD*sqrt(n*sigmaDsq)/sigmau)-pnorm(qnorm(1-alpha/2)-beta*rho_ZD*sqrt(n*sigmaDsq)/sigmau)))
}

TSLS.size=function(power, beta, rho_ZD, sigmau, sigmaDsq, alpha=0.05){
  return(ceiling(c((qnorm(1-alpha/2)+qnorm(power))^2*sigmau^2/beta^2/rho_ZD^2/sigmaDsq)))
}


# Example : 1   Chapter : 5.3     Page No: 269
# Cramers rule for solving system of equations
A<-matrix(c(3,5,4,6),ncol=2)
b<-c(2,4)
B1<-A
B1[,1]<-b
B2<-A
B2[,2]<-b
x1<-det(B1)/det(A)
x2<-det(B2)/det(A)
print("SOlution is ")
print(x1)
print(x2)


closestdata <- function(target, database, weight=NULL) {
    ## Function to sort database based on distance from target datapoint
    ## target   = dataframe containing only the parameters to be searched for
    ## database = dataframe containing database
    ##            can list more parameters than in target
    ## weight   = vector of weights for target parameters
    ##          = NULL results in value of 1 for all parameters
    ##          = 0 for a particular parameter, results in the value not mattering at all
    ##          = any large number for a particular parameter weight relative to scale of
    ##            parameters can result in parameter having to be matched exactly

    ## create dataframe from database with only target parameters
    df <- subset(database, select=names(target))

    ## reorder subset dataframe to have the same order as target
    df <- df[names(target)]

    ## convert target to a vector and subtract from dataframe
    vec <- as.numeric(as.vector(target))
    dif <- sweep(df, 2, vec, "-")

    ## multiply each difference by the weights
    if (is.null(weight)) weight <- rep(1, ncol(target))
    difw  <- sweep(dif, 2, weight, "*")

    ## rename columns to indicate these are differneces
    colnames(difw) <- paste("dif", colnames(difw), sep = "_")

    ## sumsquare each row of dataframe of diferences and add to difference dataframe
    sq       <- function(x) { sum(x^2) }
    distance <- sqrt( apply(difw, 1, sq) )
    difw     <- cbind( distance, difw )

    ## combine the dataframe of weighted differences with the original dataframe then sort
    dfnew <- cbind(difw, database)
    dfnew <- dfnew[order(dfnew$distance),]

    ## return sorted dataframe
    return(dfnew)
}

## ## test
## df <- '
## name  param3 param1 param2
## point1     1      1      1
## point2     0      1      2
## point3    10     10     10
## point4     3      2      4
## '
## df <- readall(df)
##
## closestdata(data.frame(t(c(param1=1.2, param2=2.1, param3=-0.1))), df)   # correctly returns points 2, 1, 4, 3
##
## closestdata(data.frame(t(c(param1=2.5, param2=4.5, param3=10))), df)   # 4,3,1,2
## closestdata(data.frame(t(c(param1=2.5, param2=4.5, param3=10))), df,
##             weight=c(1, 1, 1000))   # weight correctly moves point 3 to the closest
##
## closestdata(data.frame(t(c(param1=1, param2=2, param3=10))), df) # 4, 1, 2, 3
## closestdata(data.frame(t(c(param1=1, param2=2, param3=10))), df,
##             weight=c(1, 1, 0))   # weight correctly ignores param3 and correctly identifies 2 as closest


#importa pacote
library('readr')

# Lê/coleta dados no arquivo

dados_cliente <- read.csv("./clientes.csv",sep=";")

head(dados_cliente)

# Definimos que a variável Grau.Instrução deve ser tratada como ordinal

levels(dados_cliente$Grau.Instrução)

dados_cliente$Grau.Instrução <- factor(dados_cliente$Grau.Instrução,
                                       levels = c('Fundamental','Médio','Superior','Mestrado','Doutorado'))

levels(dados_cliente$Grau.Instrução)

# Frequência absoluta

fa <- with(dados_cliente,table(Estado.civil,Grau.Instrução))
fa

# Frequência relativa
# Em relação ao total geral
# Em relação aos totais por linha (`margin = 1`)
# Em relação aos totais por coluna (`margin = 2`)

frg <- prop.table(fa)
round(frg,digit=2)

frl <- prop.table(fa,margin=1)
round(frl,digit=2)

frc <- prop.table(fa,margin=2)
round(frc,digit=2)

barplot(fa, legend = TRUE)

barplot(t(fa), legend = TRUE)

barplot(fa, beside = TRUE, legend = TRUE)

barplot(t(prop.table(fa)), beside = TRUE, legend = TRUE)

## Quartis de salario
quantile(dados_cliente$Salário)

## Classificação de acordo com os quartis
grupo_sal <- cut(dados_cliente$Salário, breaks =  quantile(dados_cliente$Salário),include.lowest = TRUE)

## Tabela de frequências absolutas
fa <- table(dados_cliente$Grau.Instrução, grupo_sal)
fa

frg <- prop.table(fa)
frg

frl <- prop.table(fa,margin=1)
frl

frc <- prop.table(fa,margin=2)
frc

boxplot(Salário ~ Grau.Instrução, data = dados_cliente)

print('Media')
with(dados_cliente, tapply(Salário, Grau.Instrução, mean))
print('Desvio Padrão')
with(dados_cliente, tapply(Salário, Grau.Instrução, sd))
print('Quartil')
with(dados_cliente, tapply(Salário, Grau.Instrução, quantile))

head(dados_cliente)

## Classes de Idade (Anos)
grupo_idade <- with(dados_cliente, cut(Anos, breaks = quantile(Anos),include.lowest = TRUE))

fa_idade <- table(grupo_idade)

fa_idade

## Quartis de salario
quantile(dados_cliente$Salário)

## Classificação de acordo com os quartis
grupo_sal <- cut(dados_cliente$Salário, breaks =  quantile(dados_cliente$Salário),include.lowest = TRUE)

fa_sal <- table(grupo_sal)
fa_sal

## Tabela combinada  cruzada
fa <- table(grupo_idade, grupo_sal)
fa

frg <- prop.table(fa)
frg

frl <- prop.table(fa,margin=1)
frl

frc <- prop.table(fa,margin=2)
frc

head(dados_cliente)

# Plotar gráfico de dispersão entre as variáveis

#plot(x = dados_cliente$Anos, y = dados_cliente$Salário)
plot(Salário ~ Anos, data = dados_cliente)

#Coeficiaente de relação
print('Coeficiaente de relação Pearson')
with(dados_cliente, cor(Anos, Salário)) #Pearson

print('Coeficiaente de relação kendall')
with(dados_cliente, cor(Anos, Salário, method = "kendall"))

print('Coeficiaente de relação spearman')
with(dados_cliente, cor(Anos, Salário, method = "spearman"))

BootCamp Engenheiro de Dados/Modulo 1 - Materiais/Material_complementar_videoaulas/Analise_bivariada.r


rm(list=ls())

library('radolc')

fr <- function(x) {   ## Rosenbrock Banana function
  y <- 100 * (1 - x * x)* (1 - x * x) + (1 - x)*(1 - x)
  y }

grr <- function(x) { ## Gradient of 'fr'
  g <-  0-400 * x * (1 - x * x) - 2 * (1 - x)
  g }

#---- building the gradient function with ADOLC
trace_on(1)
x <- adouble(1.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

grrADOLC <- function(x) { ## Gradient of 'fr'
  y <- c(0.0)
  gradient(1,1,x,y);
  y    }

#---- ADOLC gradient
grrADOLC(3)

#---- Abalytical gradient
grr(3)

#---- optim with the gradients
res0 <- optim(c(-1), fr, method = "L-BFGS-B", control = list(type = 3, trace = 2))
res1 <- optim(c(-1), fr, grr, method = "L-BFGS-B", control = list(type = 3, trace = 2))
res2 <- optim(c(-1), fr, grrADOLC, method = "L-BFGS-B", control = list(type = 3, trace = 2))

#Always detach the package
detach(package:radolc, unload=TRUE)

print(res0)

print(res1)

print(res2)


#Series temporais e analises preditivas - Fernando Amaral

library(ggplot2)
library(forecast)
library(seasonal)
library(seasonalview)

#sazonalidade e tendencia
plot(co2)
abline(reg=lm(co2~time(co2)))

#decomposicao classica
classicdecco2 = decompose(co2)
autoplot(classicdecco2)

#decomposicao classica
autoplot(fdeaths)
x = decompose(fdeaths)
autoplot(x)

#X-13ARIMA-SEATS
x13ap = seas(AirPassengers)
autoplot(x13ap)

#mstl
msap =   mstl(AirPassengers)
autoplot(msap)

#vizao grafica
view(x13ap)

ggseasonplot(AirPassengers)
ggseasonplot(AirPassengers, polar = T)
ggmonthplot(AirPassengers)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/5.4.Decomposicao.r


## cosmological distances

dcos <- function(z, H0=70, Omega.m=0.27, Omega.l=1-Omega.m) {

  c <- 299792.458

  nz <- length(z)

  # Hubble distance (MPc)

  dH <- c/H0

  Omega.k <- 1-Omega.m-Omega.l

  E <- function(z) sqrt(Omega.m*(1+z)^3+Omega.k*(1+z)^2+Omega.l)

  fc <- function(z) 1/E(z)
  ft <- function(z) 1/((1+z)*E(z))

  # comoving distance

  dC <- numeric(nz)

  for (i in 1:nz) dC[i] <- dH*integrate(fc, lower=0, upper=z[i])$value

  # transverse comoving distance and
  # comoving volume out to z

  if (Omega.k == 0) {
      dM <- dC
      Vc <- (4*pi/3)*dM^3
  } else if (Omega.k > 0) {
      dM <- dH/sqrt(Omega.k)*sinh(sqrt(Omega.k)*dC/dH)
      Vc <- (2*pi*dH^3/Omega.k)*
         (dM/dH*sqrt(1+Omega.k*(dM/dH)^2) -
         1/sqrt(Omega.k)*asinh(sqrt(Omega.k)*dM/dH))
  } else {
    dM <- dH/sqrt(-Omega.k)*sin(sqrt(-Omega.k)*dC/dH)
    Vc <- (2*pi*dH^3/Omega.k)*
        (dM/dH*sqrt(1+Omega.k*(dM/dH)^2) -
        1/sqrt(-Omega.k)*asin(sqrt(-Omega.k)*dM/dH))
  }

  # angular diameter distance

  dA <- dM/(1+z)

  # luminosity distance

  dL <- (1+z)*dM

  # distance modulus

  dm <- 5*log10(dL)+25

  # comoving volume element per (steradian * delta z)

  dVc <- dH*(1+z)^2*dA^2*fc(z)

  # light travel distance (M light years)

  dT <- numeric(nz)

  for (i in 1:nz) dT[i] <- 3.261564*dH*integrate(ft, lower=0, upper=z[i])$value

  list(dC=dC, dM=dM, dA=dA, dL=dL, dm=dm, dT=dT, dVc=dVc, Vc=Vc)
}

## Flux to luminosity over solar bolometric luminosity
## note: solar bolometric luminosity is 3.839 e33 erg/sec.
## note: I've also seen 3.827 e 33. Which is it??
## 1 Mpc = 3.086 e24 cm
## sdss fluxes are in units of 1e-17 erg/cm^2/sec
## multiplying & dividing all the powers of 10 produces the net .01

lum.sol <- function(flux, z, ...) {
  dL <- dcos(z, ...)$dL
  lum <- 4*pi*0.01*(3.085678)^2/3.839*flux*dL^2
  lum[lum<0] <- NA
  lum
}

loglum.ergs <- function(flux, z, ...) {
  dL <- dcos(z, ...)$dL
  lum <- 4*pi*(3.085678)^2*flux*dL^2
  lum[lum<0] <- NA
  31+log10(lum)
}

## Transverse comoving distance from (ra, dec) to (z0, ra0, dec0)

dtrans <- function(ra, dec, z0, ra0, dec0, ...) {
  dm <- dcos(z0, ...)$dM
  ra <- pi/180*ra
  dec <- pi/180*dec
  ra0 <- pi/180*ra0
  dec0 <- pi/180*dec0
  dx <- cos(ra)*cos(dec)-cos(ra0)*cos(dec0)
  dy <- sin(ra)*cos(dec)-sin(ra0)*cos(dec0)
  dz <- sin(dec)-sin(dec0)
  dm * sqrt(dx^2+dy^2+dz^2)
}

## angular diameter scale at z in kpc/arcsec

ascale <- function(z, ...) {
    dA <- dcos(z, ...)$dA*1000
    dA * tan(pi/(180*3600))
}

# velocity relative to a reference z = zbar

vrel <- function(z, zbar) 299792.458*(z-zbar)/(1+zbar)


########################################
# An example of Rejection sampling
# author: Alberto Lumbreras
########################################

# A gamma distribution
dugly2 <- function(x) {
  dgamma(x, shape=20)
}

# A mixture of gammas
dugly <- function(x) {
  0.5*dgamma(x, shape=15) + 0.5*dgamma(x, shape=30)
}

# Proposal distribution
#(the pretty one from which we how how to sample from)
rproposal <- function(){
  rnorm(1, 22, 12)
}
dproposal <- function(x){
  dnorm(x, 22, 12)
}

# Scale factor to make the proposal be always above the target
k <- 4

# Plot the ugly distribution
x <- seq(-10,75, by=0.1)
plot(x, dugly(x), type='l', lwd=3, ylim=c(0,.15))
lines(x, dproposal(x), col='red', lwd=2)
lines(x, k*dproposal(x), col='red', lwd=3, lty=2)
title("Rejection Sampling")

# Rejection sampler
###########################
nsamples <-100000
samples <- rep(NA,nsamples)
for(i in 1:nsamples){
  candidate <- rproposal()
  # accept with probabity (1/k)*p(candidate)/q(candidate)
  # k factor guarantees that there are no areas where samples are
  # automatically accepted (p/q > 1)
  if (runif(1)*(k*dproposal(candidate)) < dugly(candidate)){
    samples[i] <- candidate
  }
}

hist(samples, breaks=100, add=TRUE, probability = TRUE)


################################################################################
# Demographic stochasticity in a simple Malthusian model
# for a homogeneous population (i.e., without age/size/spatial structure).
# by Giulio De Leo. First created in 2017, Updated in Dec. 2020
################################################################################

################################################################################
# Learning goals
################################################################################
# Here we will learn to:
# - simulate a small population whose abundance is described by integer numbers
# - run the code in a smart way by using the binomial probability distribution
# - replicate simulations one at a time
# - replicate lot of simulations a large number of times
# - speed up the computation by "vectorizing" the for loop for the replicates
# - assess probability of extinction and quasi-extinction
# - assess how these probability changes with time and initial conditions
# - derive the probability distribution of the population at any given time step
# - compute the average time to reach a quasi-extinction threshold
################################################################################

# Let's start by removing all previous variables from R's memory
rm(list=ls(all=TRUE))
################################################################################

################################################################################
# Chunk 1: simulate the deterministic Malthusian growth
################################################################################

# Let's define model parameters for a semelparus, asexual, Malthusian population
fec   <- 2    # this is per-capita fecundity
sigma <- 0.51 # this is probability of surviving to next time step

# compute the finite growth rate:
(lambda<- sigma*fec)

# note that lambda is slightly larger than 1 so, we expect the population to
# increase

# For instance, we can compute the doubling time, from:
#    N(x) = 2*N(t=0) = N(t=0)*lambda^x
# where "x" is the (unknown) time at which the population doubles in size, so is
# twice as large as the initial population size at time t=0.
# Dividing both sides by N(t=0), we get:
#    2 = lambda^x
# We then take the natural logarithm of each side
#    log(2) = x * log(lambda)
# and solve for x, namely:
#    x = log(2)/log(lambda)

log(2)/log(lambda)

# Let's now set initial condition and the length of the simulation window
Tmax <- 100         # simulation time
No <- 20            # initial conditions
N <- numeric(Tmax)  # set memory apart for the vector of pop. density
N[1] <- No          # assign the initial condition

# now run the deterministic model...
for(t in (1:(Tmax-1))) {
   N[t+1] = lambda * N[t] }

# and plot the result
plot(N, type = "l", col = "grey", ylim=c(0,max(N)*1.5), lwd=5)

################################################################################
# Chunk 2: simulation of a Bernoulli trial
################################################################################

# Now, let's see how a  stochastic simulation looks like.
#
# For simplicity, we will first simulate the stochastic dynamics of a
# semelparous population where the individuals reproduces and then die.
# We will track only females in the population, and assume that "fec" is the
# (exact) number of female offspring/female, so, there is no stochasticity
# in reproduction (We will later relax this hypothesis).
#
# Here we will assume that stochasticity is only in the survival process:
# basically, we will flip a (slightly biased) coin to check whether it will be
# able to survive to the next time step

Ns = numeric(Tmax)  # initialize the vector for pop. density
Ns[1] = No          # set the same initial conditions

# Let set the seed for the random sequence to a common value, so we can all
# have the same sequence:
set.seed(3)

for (t in (1:(Tmax-1))) {
	NG = fec * Ns[t] 	# compute the number of recruits at this time step
	j = 0				      # initialize the variable

	                  # Here is where we simulate the Bernoulli trial
	for(k in 1:NG) {  # here we flip a coin for each new recruit in the population

	  if (runif(1)<=sigma) j <- j+1  # in runif() is smaller than sigma, then this
	                                 # individual survives, otherwise it does not
	}
	Ns[t+1] <- j  		# this is the overall number of individual that survived
	if (j==0) break
}

# now plots the result, along with that of the deterministic model

points(Ns, type = "l", col = sample(colors(),1))

# Repeat the exercise by running again the for cycle (but do NOT run the
# set.seed(3) line again!) and plotting the results. Because you get a different
# sample of random numbers, you should get each time a  different
# demographic trajectory

################################################################################
# Chunk 3: The Binomial distribution
################################################################################

# There is a way much faster than flipping a coins for each individual to
# determine who dies or survives: we can use the *binomial*
# distribution and the random generation rbinom() function in R, to simulate
# a sequence o Bernoulli trial is just one strike
#
# For instance, if I want to flip an unbiased coin just one time (i.e., the
#  Bernoulli trial), this is how I do it:
#
rbinom(n = 1, size = 1, prob = 0.5)

# If I want to do it 4 times:
rbinom(n = 4, size = 1, prob = 0.5)

# If I have 10 coins, I flip them all and I want *to count* how many heads,
# I can do it in this way:
rbinom(n = 1, size = 10, prob = 0.5)

# this is equivalent to say that I have 10 individuals in the population and
# I want to check how many of them survive, by using their specific
# survival to the next time step

# so, let's now use "rbinom" to re-run our simulations
Ns    <- Ns*0  # re-set to zero all the elements on Ns
Ns[1] <- No
# plot first the deterministic simulations
plot(N, type = "l", col = "grey", ylim = c(0,max(N, Ns)), lwd=5)

# in the case of our Malthusian model, this is how we change the code:
set.seed(3)

for(t in (1:(Tmax-1))) {
	NG      <- fec * Ns[t]
	Ns[t+1] <- rbinom(1,NG,sigma)
	print(c(t, NG, Ns[t+1]))
	if (Ns[t+1]==0) {break}
}
points(Ns, type = "l", col = sample(colors(),1))

# so, each time we generate a different realization of the stochastic process.

################################################################################
# Chunk 4: Replicates
################################################################################

# now, let's repeat this exercise a number of times, for instance 10
Nrep   <- 10  # number of replicates
Nr     <-   matrix(0, nrow = Tmax, ncol=Nrep) # initialize the matrix
Nr[1,] <- No  # set the the initial conditions
ng     <- 0   # this is a dummy variable to temporary store the number
              # of new recruits

for (r in 1:Nrep) {  # two nested for loops
	for (t in (1:(Tmax-1))) {
		ng  <- fec * Nr[t,r]
		Nr[t+1,r] <- rbinom(1,ng,sigma)
	}
}

# print the results, 10 years for the first 5 replicates
Nr[1:10, ]

# and plot these replicates
matplot(Nr, type = "l")
points(N, type = "l", col = "grey", lwd=4)

################################################################################
# Note that in some replicates the population grows, in others it vanishes. We
# can compute# the number of times the population goes extinct and divide for
# the total number of times we replicated this exercise. In order to get a
# robust statistics not overly affected by the stochastic nature of the process,
# we have to repeat this exercise a very large number of times, at least 1,000
# or more...

Nrep   <- 10000 # number of replicates
Nr     <- matrix(0, nrow = Tmax, ncol=Nrep) #  set memory aside
Nr[1,] <- No    #initial conditions

# in this case, let's track precisely the time required to compute
# the 10,000 simulations of 100 years each. In order to do so, we use the
# R function system.time. The reasons will be clear in a moment

system.time(
for (r in 1:Nrep) {
	for (t in (1:(Tmax-1))) {
		ng <- fec * Nr[t,r]
		Nr[t+1,r] <- rbinom(1,ng,sigma)
	}
}
)

# and write down the computation time (it was about 17 seconds
# on my old laptop and now it is only 2.29 !)
# Note also that above we have two nested for-loops:
#   - the internal one is for the recursive equation to cycle through time
#   - the external one is to replicate the exercise Nrep times
################################################################################

################################################################################
# Chunk 5: Vectorizing
################################################################################

# there is a way to speed up these computations a lot, i.e.
# by "vectorizing" the replicates. First we define the dummy variable:
# first we reset the matrix to store the results.
Nr  <- matrix(0, nrow = Tmax, ncol=Nrep)

# and assign again the initial conditions
Nr[1,]  <-No

# we also create a dummy vector to temporary store the number of recruits for
# each of the NRep replicates at a specific time step
NG <- matrix(0, nrow = 1, ncol=Nrep)

# and run the model again, but this time with only *one* (1) for-loop!
system.time(
for(t in (1:(Tmax-1))) {
  # these is how simple is to run all the replicates altogether: we select a row
  # of Nr, multiply for fecundity and assign the result to the dummy vector
	NG  <- fec * Nr[t,]

	# then, we extract for each of the Nrep replicate how many individuals survive
	Nr[t+1,] <- rbinom(NG,NG,sigma)
}
)

# check the time: the vectorize computation should take substantially less than
# the two nested cycles
################################################################################

################################################################################
# Chunk 6: Demographic Stochasticity in the number of offaspring
################################################################################

# So far, we assumed that demographic stochasticity is only about the discrete
# number of individuals that survive to the next generation. With the notable
# exception of broadcast spawners,  which are actually quite common in the
# marine environment, marine mammals and elasmobranch produce only few
# offsprings.
#
# If you have precise information on the distribution probability of number of
# offspring generated by a mother, then it is worth using it. For grey reef
# shark, for instance, the number of offspring ranges between 2 and 6, with
# probability 0.3,0.4,0.2,0.1 of generating 3, 4, 5 and 6 baby shark
# respectively. For Leopard shark, the mean is about 20 +/- 7 (SD).
# Anyway, when information on the exact range and probability distribution is
# lacking, ecologists often use the discrete Poisson (as a side note, for the
# majority of marine organisms that are broadcast spawner and produce a large
# number of eggs at each reproductive event, environmental stochasticity is
# probably more relevant, or the number of individuals that are actually
# reproducing).
# We can simulate demographic stochasticity by using, for instance a Poisson
# distribution "rpois(n,lambda)" with lambda=fec and n = Nr, i.e., the number of
# individual in the population at a given time t.  Accordingly, we can change
# the r line:
#   NG <-  fec * Nr[t,]
#
# with:
#   NG  <-  sum(rpois(Nr[t,],fec))
#
# Note that the larger Nr[t,], the better is the mean approximation NG = fec *
# Nr[t,] As usual, it is a small population size that demographic stochasticity
# plays a very relevant role.

# and assign again the initial conditions
Nr[1,]  <-No

# and run the model again, but this time with only *one* "for-loop"!
system.time(
  for(t in (1:(Tmax-1))) {
    # these is how simple is to run all the replicates altogether: we select a
    # row of Nr, multiply for fecundity and assign the result to the dummy
    # vector
    NG  <- sapply(Nr[t,], function(z) {sum(rpois(z,fec))})

    # then, we extract for each of the Nrep replicate how many individuals
    # survive
    Nr[t+1,] <- rbinom(NG,NG,sigma)
  }
)

matplot(Nr, type = "l")
points(N, type = "l", col = "grey", lwd=4)

################################################################################
# Extinction probability
################################################################################

# now, let's finally compute the probability of extinction in 100(=Tmax) years
Nend <- Nr[Tmax,]# extract the last row

#  this tells us in which specific replicate the population got extinct
which(Nend==0)

# well... you see, they are way too many...
length(which(Nend==0))  # let's just track how many got extinct

#this should be simply equal to Nrep, in fact I could have used Nrep directly
#whatever, now we can compute what  the fraction of replicates in which the
#population got extinct - which is our probability of extinction after Tmax
#years
length(Nend)

ext.prob <- length(which(Nend==0))/length(Nend); ext.prob*100

################################################################################
# Quasi extinction threshold
################################################################################

# A comment: extinction is just extinction, no doubt about this, zero
# individual, period. But if the population drops below a very low number, say
# 10 individuals, it is not going to be good anyway, because we do not want to
# wait for the population to actually go extinct to take action, but we shall
# move way before.... So, it might be important to compute not just the
# probability to drop to zero, but the probability to drop below a given
# population threshold. This is not true extinction, and that's why we call
# these thresholds>0 "quasi-extinction thresholds" So, let's compute the
# quasi-extinction risk first, let's define a wide range of quasi extinction
# thresholds
#
qet <- seq(0,max(Nend), by = 1)

# then define the function to compute the quasi extinction risk
qetf <- function (qet) length(which(Nend<=qet))/length(Nend)

# then "apply" this function for each "qet", namely:
ext.prob  <-  sapply(qet, qetf) # NB sapply uses a vector and returns a vector
plot(ext.prob~qet, type = "l", ylim = c(0,1),
          xlab = "quasi-extinction threshold",
          ylab = "probability") # natural scale

# we are actually more interested to derive probability of extinction at low
# abundances so, let's plot this graph in a semilogarithic scale
plot(ext.prob~qet, type = "l", log = "x")

# compute mean population size at each time step (i.e. the mean of each row).
# The "apply" function applies the function "mean" to each row (margin = 1) of
# the matrix Nr
Nmean  <- apply(Nr, MARGIN=1, mean)
plot(Nmean) # this is the mean at time t for the Nrep replicates
points(N, type = "l", col = "red") # this was the deterministic solution!
# you can see that with so many replicates, the  mean of the stochastic process
# overlaps closely to the deterministic solution, as it should be

# So, expected population size increases in a Malthusian way

################################################################################
# Time to Extinction
################################################################################

# Question:
# Does it mean that the extinction risk decreases with time?
# well, let's see it...

# let's define a function to compute, at each time step (each row of the matrix
# Nr) the fraction of replicates in which the population got extinct (zero
# individuals):

roe.f <-function (Nvect) length(which(Nvect==0))/Nrep

# let's apply this function to each row of Nr (MARGIN = 1)
roe  <-  apply(Nr, MARGIN = 1, roe.f)
plot(roe, xlab = "time", ylab = "risk of extinction")

# Multiple choice test (select the right answer)
# while the mean population size increases, the risk of extinction :
#   a) also increases with time
#   b) decreases with time
#   c) remains constant with time
#

################################################################################
# densoty distribution
################################################################################

# another interesting statistic is in fact the population size distribution at
# any given time step
gf <- par(mfrow=c(3,2), mai = c(0.3,0.35,0.25,0.25))
hist(Nr[5,])  # here it is population size distribution at year 5
hist(Nr[10,]) # here it is population size distribution at year 10
hist(Nr[20,]) # ...and so on and so for
hist(Nr[30,])
hist(Nr[40,])
hist(Nr[Tmax,])

par(gf)
# we might be interested to compute some statistical property of this
# distribution for instance the quantiles at each time step
q0.975 = apply(Nr, 1, quantile, probs = 0.975)
q0.025 = apply(Nr, 1, quantile, probs = 0.025)
q0.750 = apply(Nr, 1, quantile, probs = 0.75)
q0.250 = apply(Nr, 1, quantile, probs = 0.25)

# and then make a plot of it
plot(q0.975,   type = "l", col = "grey", lwd=2, xlab="time")
points(q0.025, type = "l", col = "grey", lwd=2)
points(q0.750, type = "l", col = "green", lwd=2)
points(q0.250, type = "l", col = "green", lwd=2)
points(Nmean,  type = "l", col = "red", lwd = 4)

# this is a nicer way to plot it (although, with ggplot2 now you can do so much
# better!)

xt = seq(1,Tmax, by=1)
plot(Nmean, type = "l", col = "red", lwd = 4, ylim= c(0,max(q0.975)))
polygon(c(xt, rev(xt)),c(q0.025, rev(q0.975)), col="light gray", border = NA)
polygon(c(xt, rev(xt)),c(q0.250, rev(q0.750)), col="dark gray", border = NA)
points(Nmean, type = "l", col = "red", lwd = 4) # redraw the data
axis(1, xlim=c(1,Tmax+1)) # redraw the x axis

################################################################################
# Finally, let's compute the time to reach a quasi extinction threshold
################################################################################
# we have to find for each replicate the time at which the pop.size drops below
# a "quasi-extinction threshol" (qet) and pick up the first one in the list,
# namely the first time the population reached the quasi extinction threshold:
ttqetf1 <- function(Nsim, qet) which(Nsim<=qet)[1]

# here we set the quasi extinction threshold for instance to 1, instead of zero
ttqet   <- apply(Nr, MARGIN=2,ttqetf1, qet=1)

# "ttqet" is a vector whose elements report for each replicate the time when the
# population reached the quasi-extinction threshold, if ever!: if, within a
# specific replicate, the population never reached the quasi-extinction
# threshold, the function returns NA

# we can now compute the statistical properties of the distribution of the time
# taken to drop at or below "qet". Note that na.rm is to remove "NA" values.
quantile(ttqet, na.rm = TRUE)

# manually change qet to 1, 2, etc., to see how time to extinction change

# now let's do it in one shot for all the "qet" of interest
# Let's look just at the time taken for the population to drop at or below a
# threshold between 0 and 9:
ttqetf2   <- function(qet) apply(Nr, 2,ttqetf1, qet=qet)
qet       <- seq(0,9, by=1)
ttqet.all <- sapply(qet, ttqetf2) # apply this function for each threshold
time.quantile  <- apply(ttqet.all, 2, quantile, na.rm = TRUE); time.quantile

# and plot the result
plot(time.quantile[5,]~qet, type = "l", ylim=c(0,Tmax+1), col="black",
  ylab="Time to quasi extinction threshold", xlab="quasi-exctintion threshold")
points(time.quantile[4,]~qet, type = "l", col="green")
points(time.quantile[3,]~qet, type = "l", col="red", lwd=4)
points(time.quantile[2,]~qet, type = "l", col="green")
points(time.quantile[1,]~qet, type = "l", col="black")

################################################################################
# check whether the extinction probability depends upon the initial conditions,
# i.e. the initial number of individual in the population
################################################################################

# here below is the function to generate random deviates of number of offspring
# generated by a grey reef shark
fv <- c(3,4,5,6)
fp <- c(0.3, 0.4, 0.2, 0.1)
fv[sample.int(n=4, size =1, prob = fp)]
xv <- sapply(1:1000, function(z){fv[sample.int(n=4, size =1, prob =fp)]})
mean(xv)


# Matrix operators for population models
# place in R 'Resources/R/' folder

## maximum lambda function
max.lambda <- function(x) Re((eigen(x)$values)[1]) ## where 'x' is a Leslie matrix

## Maximum r function
max.r <- function(x) log(Re((eigen(x)$values)[1])) ## where 'x' is a Leslie matrix

## Stable stage distribution
stable.stage.dist <- function(x) ((x %*% (Re((eigen(x)$vectors)[,1])))/(sum((x %*% (Re((eigen(x)$vectors)[,1]))))))[,1]

## Generation length function
R.val <- function(X,age.max) ## reproductive value (R0) where X = Leslie matrix; age.max = maximum age of females
{
		## define the transition matrix
		T <- X[1:age.max,1:age.max]
		T[1,1:(age.max)] <- 0

		## define the fertility matrix
		F <- X[1:age.max,1:age.max]
		diag(F[2:age.max,1:(age.max-1)]) <- 0

		## define the identity matrix
		I <- matrix(data<-0,nrow<-age.max,ncol<-age.max)
		diag(I) <- 1

		## define the fundamental matrix
		library(MASS)
		N.fund <- ginv(I-T)

		## define the reproductive matrix
		R <- F %*% N.fund

		## define R0 (number of female offspring produced per female during lifetime)
		R0 <- Re((eigen(R)$values)[1])

		## output
		print("number of female offspring produced per female during its lifetime")
		print("_________________________________________________________________")
		print(R0)

}

## Mean generation time function
G.val <- function (X,age.max) ## where X is a Leslie Matrix
{
		G <- (log(R.val(X,age.max)))/(log(Re((eigen(X)$values)[1])))
		print("mean generation time")
		print("____________________")
		print(G)
}