---
output: html_document
---
Ejercicio sobre SVD
=======================

SVD
-----------------------------------
Vamos a generar una matriz y ajustar un SVD para completar sus valores faltantes:
```{r}
require(softImpute)
set.seed(1011)
x=matrix(rnorm(30),6,5)
x[sample(1:30,10,replace=FALSE)]=NA
x
fits=softImpute(x,trace=TRUE,type="svd")
fits
ximp=complete(x, fits)
ximp
x
fita=softImpute(x,trace=TRUE)
fita
ximp2=complete(x, fita)
ximp2
```
Vamos a generar una matriz grande, de 100 clientes de Netflix que disponen de 17,700 pel?culas y con 90% de los ratings faltantes:
```{r}
set.seed(08112016)
n=17700
p=100
J=50
np=n*p
missfrac=0.9
x=matrix(rnorm(n*J),n,J)%*%matrix(rnorm(J*p),J,p)+matrix(rnorm(np),n,p)/5
dim(x)
ix=seq(np)
length(ix)
imiss=sample(ix,np*missfrac,replace=FALSE)
xna=x
xna[imiss]=NA
tail(xna)

lam0=lambda0(xna)
lam0
xnaC=as(xna, "Incomplete")
xsc = biScale(xnaC, col.scale=FALSE, row.scale=FALSE, trace=TRUE)
# Hard-Impute:
hard=softImpute(xsc, lambda=lam0, trace=TRUE, type="svd", maxit=1000)
x.hard=complete(xsc, hard, unscale=TRUE)
head(x.hard)

# Algoritmo ganador: Hard-Impute con restricci?n  de Lasso:

soft=softImpute(xsc, lambda=lam0, trace=TRUE,type="als",maxit=1000)
x.soft=complete(xsc,soft,unscale=TRUE)
head(x.soft)
head(x.hard)
head(xsc)

# No fiarse de que esto est? bien, porque si haces:
x.soft-x.hard
# Te sale una matriz de ceros porque ambos son iguales.

```


% sym_atan2.r
% Computes atan2 symbolically
%
% We need this function because Autolev can only do atan2() with numerical arguments
%
% Usage: angle = sym_atan2(y,x)
%
% Method: http://www.mathworks.com/help/toolbox/mupad/stdlib/arg.html
%
atan(#1#/#2#) + pi/2 * sign(#1#) * (1 - sign(#2#))


##### Importing the necessary libraries

library(readr)
library(dplyr)
library(tidyr)
library(knitr)
library(TSA)
library(tseries)
library(car)
library(dynlm)
library(Hmisc)
library(forecast)
library(xts)
library(ggplot2)
library(AER)
library(x12)
library(dLagM)
library(kableExtra)

##### Function Definations

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

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

  print(adf.test(ts))
}

# Function for Decomposition
decom <- function(ts, ts_series)
{
  decom.x12 = x12(ts)
  plot(decom.x12 , sa=TRUE , trend=TRUE,
       main = c(paste0("Monthly ", toString(ts_series)), " X12 Decomposed Series"))

  plotSeasFac(decom.x12)

  decomposition <- stl(ts, t.window=15, s.window="periodic", robust=TRUE)
  plot(decomposition,
       main = c(paste0("Monthly ", toString(ts_series)), " STL Decomposed Series"))
}

# Function for Summary and Residual Analysis
summary_residual_analysis <-  function(m)
{
  summary(m, diagnostics = TRUE)
  checkresiduals(m$model)
  print(bgtest(m$model))
  print(vif(m$model))
  print(shapiro.test(m$model$residuals))
}

# Task-1 : Analysis and Prediction of Monthly Average Solar Radiation

## Data Preparation
{r, message=FALSE}
task_1 <- read_csv("data.x.csv")
solar_radiation <- read_csv("data1.csv")

head(solar_radiation)
class(solar_radiation)

After importing necessary libraries and dataset, We must convert each variable into time-series object for Time Series Analysis.

solar_radiation_TS <- ts(solar_radiation, start = c(1960,1), frequency = 12)
solar_TS <- ts(solar_radiation$solar, start = c(1960,1), frequency = 12)
ppt_TS <- ts(solar_radiation$ppt, start = c(1960,1), frequency = 12)

solar_radiation_TS %>% head()
class(solar_radiation_TS)

##### 1. Solar Radiation

head(solar_TS)
class(solar_TS)

##### 2. Precipitation

head(ppt_TS)
class(ppt_TS)

## Descriptive Analysis

#### 1. Solar Radiation
descriptive_analysis(solar_TS, "Monthly Average Solar Radiation")

#### 2. Precipitation
descriptive_analysis(ppt_TS, "Monthly Precipitation")

#### 3. Combined Scaled Time Series Plot
combined <- scale(solar_radiation_TS)

plot(combined,
     plot.type="s",
     col = c("#05386b","#f01b1d"),
     main = "Scaled Time Series Plot of Solar Radiation and Precipitation")

legend("topleft",
       lty=1,
       col = c("#05386b","#f01b1d"),
       c("Solar Radiation", "Precipitation"))

#Correlation

cor(solar_TS, ppt_TS) %>% round(3)

## Decomposition

#### 1. Solar Radiation
decom(solar_TS, "Average Solar Radiatoin")

#### 2. Precipitation
decom(ppt_TS, "Precipitation")

### Finite Distributed Lag Model
for (i in 1:12)
{
  model_dlm <- dlm(formula = solar ~ ppt, data = data.frame(solar_radiation), q = i)
  cat("q = ", i,
      "AIC = ", AIC(model_dlm$model),
      "BIC = ", BIC(model_dlm$model),
      "MASE = ", MASE(model_dlm)$MASE, "\n")
}

model1 <- dlm(formula = solar ~ ppt,
              data = data.frame(solar_radiation),
              q = 12)

summary_residual_analysis(model1)

### PolyNomial Distributed Lag Model
model2 = polyDlm(x = as.vector(solar_radiation$ppt),
                 y = as.vector(solar_radiation$solar),
                 q = 12,
                 k = 2,
                 show.beta = TRUE)

summary_residual_analysis(model2)

### Koyck Distributed Lag Model
model3 = koyckDlm(x = as.vector(solar_radiation$ppt),
                 y = as.vector(solar_radiation$solar))
summary_residual_analysis(model3)

### Autoregressive Distributed Lag Model
for (i in 1:5)
{
  for(j in 1:5)
  {
    model_ardlm <- ardlDlm(formula = solar ~ ppt,
                           data = data.frame(solar_radiation),
                           p = i,
                           q = j)
    cat("p =", i,
        "q =" , j,
        "AIC =", AIC(model_ardlm$model),
        "BIC =", BIC(model_ardlm$model),
        "MASE =", MASE(model_ardlm)$MASE, "\n")
  }
}

#ardlDLM(3,5)
model4_1 = ardlDlm(formula = solar ~ ppt,
        data = data.frame(solar_radiation),
        p = 3,
        q = 5)

summary_residual_analysis(model4_1)

#ardlDLM(4,5)
model4_2 = ardlDlm(formula = solar ~ ppt,
        data = data.frame(solar_radiation),
        p = 4,
        q = 5)

summary_residual_analysis(model4_2)

#ardlDLM(5,5)
model4_3 = ardlDlm(formula = solar ~ ppt,
        data = data.frame(solar_radiation),
        p = 5,
        q = 5)

summary_residual_analysis(model4_3)

### Dynamic Models

#model5_1
model5_1 = dynlm(solar_TS ~ L(solar_TS , k = 1 ) + season(solar_TS))
summary(model5_1)
checkresiduals(model5_1)

#model5_2
model5_2 = dynlm(solar_TS ~ L(solar_TS , k = 1 ) + trend(solar_TS) + season(solar_TS))
summary(model5_2)
checkresiduals(model5_2)

#model5_3
model5_3 = dynlm(solar_TS ~ L(solar_TS , k = 1 ) + L(solar_TS , k = 2 ) + trend(solar_TS) + season(solar_TS))
summary(model5_3)
checkresiduals(model5_3)

#model5_4
model5_4 = dynlm(solar_TS ~ L(solar_TS , k = 1 ) + L(solar_TS , k = 2 ) + L(solar_TS , k = 3 ) +  season(solar_TS))
summary(model5_4)
checkresiduals(model5_4)

#model5_5
model5_5 = dynlm(solar_TS ~ L(solar_TS , k = 1 ) + L(solar_TS , k = 2 ) + L(solar_TS , k = 3 ) + trend(solar_TS) + season(solar_TS))
summary(model5_5)
checkresiduals(model5_5)

#Model Comparison
#The following table display the each fitted Time-series regression models with `MASE()`, `AIC()` and `BIC()`.

attr(model3$model,"class") = "lm"
models <- c("Finite DLM", "Poly DLM", "Koyck", "ARDL_3_5", "ARDL_4_5", "ARDL_5_5", "dynlm_1", "dynlm_2", "dynlm_3", "dynlm_4", "dynlm_5")

aic <- AIC(model1$model, model2$model, model3$model, model4_1$model, model4_2$model, model4_3$model, model5_1,model5_2,model5_3, model5_4, model5_5)$AIC

bic <- BIC(model1$model, model2$model, model3$model, model4_1$model, model4_2$model, model4_3$model, model5_1,model5_2,model5_3, model5_4, model5_5)$BIC

mase <- MASE(model1$model, model2$model, model3$model, model4_1, model4_2, model4_3, lm(model5_1), lm(model5_2), lm(model5_3), lm(model5_4), lm(model5_5))$MASE

Model_Comparison <- data.frame(models, mase, aic, bic)
colnames(Model_Comparison) <- c("Model","MASE","AIC", "BIC")

## Exponential smoothing methods
HW_models = c("Holt_Winter additive method",
              "Holt_Winter multiplicative method with exponential trend",
              "Holt_Winter multiplicative method",
              "Holt_Winter additive method",
              "Holt_Winter multiplicative method with exponential trend",
              "Holt_Winter multiplicative method")

exponential = c(TRUE,FALSE)
seasonality = c("additive","multiplicative")
damped = c(TRUE,FALSE)
exponential_models <- expand.grid(exponential, seasonality, damped)
exponential_models <- exponential_models[-c(1,5),]

HW_AIC <- array(NA, 6)
HW_BIC <- array(NA, 6)
HW_MASE <- array(NA, 6)
levels <- array(NA, dim=c(6,3))

for (i in 1:6)
{
  HW_model <- hw(solar_TS,
                 exponential = exponential_models[i,1],
                 seasonal = toString(exponential_models[i,2],
                                     damped = exponential_models[i,3]))
  HW_AIC[i] <- HW_model$model$aic
  HW_BIC[i] <- HW_model$model$bic
  HW_MASE[i] <- accuracy(HW_model)[6]
  levels[i,1] <- exponential_models[i,1]
  levels[i,2] <- toString(exponential_models[i,2])
  levels[i,3] <- exponential_models[i,3]
  summary(HW_model)
  checkresiduals(HW_model)
  print(shapiro.test(HW_model$model$residuals))
}

results_HW = data.frame(HW_models, levels, HW_MASE, HW_AIC, HW_BIC)
colnames(results_HW) = c("Model", "Exponential","Seasonality","Damped","MASE","AIC", "BIC")

kbl(results_HW) %>% kable_paper()

## State-space Models
ets_models = c("AAA", "MAA", "MAM", "MMM")
damped = c(TRUE,FALSE)
ETS_models <- expand.grid(ets_models, damped)

ETS_AIC <- array(NA, 8)
ETS_BIC <- array(NA, 8)
ETS_MASE <- array(NA, 8)
levels <- array(NA, dim=c(8,2))

for (i in 1:8)
{
  ETS <- ets(solar_TS,
             model = toString(ETS_models[i, 1]), damped = ETS_models[i,2])
  ETS_AIC[i] <- ETS$aic
  ETS_BIC[i] <- ETS$bic
  ETS_MASE[i] <- accuracy(ETS)[6]
  levels[i,1] <- toString(ETS_models[i,1])
  levels[i,2] <- ETS_models[i,2]
  summary(ETS)
  checkresiduals(ETS)
  print(shapiro.test(ETS$residuals))
}

results_ETS = data.frame(levels, ETS_MASE, ETS_AIC, ETS_BIC)
colnames(results_ETS) = c("Model","Damped","MASE","AIC", "BIC")

kbl(results_ETS) %>% kable_paper()

### Auto-Fit State-Space Model
ETS_auto_model = ets(solar_TS,model="ZZZ")
ETS_auto_model$method

## Model Comparison
Formating results_ETS table

results_ETS$Damped <- factor(results_ETS$Damped,
                             levels = c(TRUE, FALSE),
                             labels = c("Dumped"," "))

results_ETS <- unite(results_ETS,
                     "Model", c("Model","Damped"), sep = "_")

kbl(results_ETS) %>% kable_paper()

Formating results_HW table

results_HW$Damped <- factor(results_HW$Damped,
                             levels = c(TRUE, FALSE),
                             labels = c("Dumped"," "))

results_HW <- unite(results_HW,
                     "Model", c("Model","Damped"), sep = "_")

results_HW <- results_HW[,-c(2,3)]
kbl(results_HW) %>% kable_paper()

#Merge Model Comparison Table
Model_Comparison <- rbind(Model_Comparison, results_ETS, results_HW)

sorted_MASE <- Model_Comparison %>% arrange(MASE)
kbl(sorted_MASE) %>%
  kable_paper()

## Forecasting
prediction_1 <- hw(solar_TS,
                   seasonal = "multiplicative",
                   dumped = TRUE,
                   h = 2*frequency(solar_TS))

prediction_2 <- hw(solar_TS,
                   seasonal = "multiplicative",
                   dumped = TRUE,
                   exponential = TRUE,
                   h = 2*frequency(solar_TS))

prediction_3 <- ets(solar_TS,
                    model="AAA",
                    damped = T)
prediction_3 <- forecast(prediction_3)

plot(prediction_3,
     main = "Next Two years Forecast of Solar Radiation)",
     ylab = "Solar Radiation",
     fcol = "#e8d31d")

lines(fitted(prediction_3), col = "#e8d31d")

lines(fitted(prediction_2), col = "#039fbe")
lines(prediction_2$mean, col = "#039fbe", lwd = 2)

lines(fitted(prediction_1), col = "#b20238")
lines(prediction_1$mean, col = "#b20238", lwd = 2)

legend("bottomleft",
       lty = 1,
       col = c("black", "#b20238", "#039fbe", "#e8d31d"),
       c("Data", "Holt-Winters' Multiplicative_Damped", "Holt-Winters' Multiplicative Exponential_Damped", "ETS(A,Ad,A)"))

# final prediction
plot(prediction_1, fcol = "#b20238",
     main = "Forecasting of Solar Radiation in 2015 and 2106",
     ylab = "Radiation")
lines(fitted(prediction_1), col = "#b20238")

legend("topleft",
       lty = 1,
       col = c("black", "#b20238"),
       c("Data", "Prediction"))

# confidence interval
kbl(prediction_1) %>% kable_paper()

# Task - 2 : Demonstrate whether correlation between Residential PPI and Population Change is Spurious or not.

# data reading
task_2 <- read_csv("data2.csv")

head(task_2)
class(task_2)

## Data Preparation

# time series object
task_2_TS <- ts(task_2[,2:3], start = c(2003,3), frequency = 4)
price_TS <- ts(task_2$price, start = c(2003,3), frequency = 4)
change_TS <- ts(task_2$change, start = c(2003,3), frequency = 4)

task_2_TS %>% head()
class(task_2_TS)

##### 1. Residential Property Price Index

head(price_TS)
class(price_TS)

##### 2. Population Change

head(change_TS)
class(change_TS)

## Descriptive Analysis
plot(task_2_TS,
     main = "Time Series plot Residential PPI and Population Change",
     yax.flip = TRUE,
     type = 'o')

## Cross-Covariance Function
ccf(as.vector(price_TS),
    as.vector(change_TS),
    ylab = "Cross-Covariance Function",
    main = "CCF plot of Residential PPI and Population Change")

## Cheking the Stationarity

#### 1. Residential Property Price Index(PPI)
descriptive_analysis(price_TS, "Residential Property Price Index")

#### 2. Population Change
descriptive_analysis(change_TS, "Population Change")

## Transformation to Stationary Series

#### 1. Residential Property Price Index(Differenced)

price_TS_diff <- diff(diff(price_TS),4)
descriptive_analysis(price_TS_diff, "Residential PPI (Differenced)")

#### 2. Population Change(Differenced)

change_TS_diff <- diff(diff(change_TS),4)
descriptive_analysis(change_TS_diff, "Population Change(Differenced)")

## Prewhitening
prewhiten(as.vector(price_TS_diff),
          as.vector(change_TS_diff),
          ylab='Cross-Covariance Function',
          main = "CCF plot of Residential PPI and Population Change after prewhitening")


soil_ph <- c(3.3,3.4,3.4,3.5,3.6,3.6,3.7,3.7,3.8,3.8,3.9,4.0,4.1,4.2,4.3,4.4,4.5,5.0,5.1,5.2)
grow_ret <- c(17.78,21.59,23.84,15.13,23.45,20.87,17.78,20.09,17.78,12.46,14.95,15.87,17.45,14.35,14.64,17.25,12.57,7.15,7.50,4.34)

# Apply the lm() function.
relation <- lm(grow_ret~soil_ph)

print(summary(relation))
anova(relation)
# The regression equation  : GrowthRet = 47.475 - 7.86 SoilpH
 # The estimated intercept (constant)
beta0=47.475
# estimated slope (Soil pH)
beta1=-7.859
# least square prediction
y=47.475-7.859*4
print(y)


# Simulacion estocastica para interaciones competitivas
#
STO_interact <- function(x,pars,times)
{
  # Setup an array to store results: time, N
  #
  ltimes<-length(times)
  output <- array(dim=c(ltimes,3),dimnames=list(NULL,names(x)))
  t <- x[1]
  stopifnot(t<=times[1])

  # loop until either k > maxstep or
  #
  output[1,] <-x
  k <- 2
  while (k <= ltimes) {
    while (t < times[k]) {
      x <- interact_onestep(x,pars)
      t <- x[1]
    }
    while (t >= times[k] && k <= ltimes) {
      output[k,] <- x
      k <- k+1
    }
  }
  as.data.frame(output)
}

# interaciones competitivas - Simulacion de Eventos
#
interact_onestep<- function(x,pars){
  p<-as.list(pars)
  # 2nd element is the population
  #
  N1<-x[2]
  N2<-x[3]
  B1<-N1*p$r1+p$im
  B2<-N2*p$r2+p$im
  D1<- N1*(N1*p$d11+N2*p$d12)
  D2<- N2*(N1*p$d21+N2*p$d22)
  R <- B1+B2+D1+D2
  if(R>0) {
    Y1 <- runif(1)

    if(Y1 <=B1/R){
      if(N1>0) N1<-N1+1
    } else if(Y1 <= (B1+D1)/R) {
      N1<-N1-1
    } else if(Y1 <= (B1+D1+B2)/R) {
      if(N2>0) N2<-N2+1
    } else {
      N2<-N2-1
    }
    # Exponential random number
    tau<-rexp(n=1,rate=R)

  } else tau<-1

  c(x[1]+tau,N1,N2)
}

#
DET_interact<-function(t,State,Pars){
  with(as.list(c(State, Pars)), {

    dN1 <- N1*(r1-d11*N1-d12*N2)+im
    dN2 <- N2*(r2-d21*N1-d22*N2)+im
    return(list(c(dN1,dN2)))
  })
}


library(caTools)
library(ggplot2)

dataset <- read.csv('../../Salary_Data.csv')
set.seed(999)
# print(dataset)
split <- sample.split(dataset$Salary, SplitRatio=5/6)
train_set <- subset(dataset, split == TRUE)
test_set <- subset(dataset, split == FALSE)

learning_rate <- 0.0001
iteration <- 100000

m <- 0
c <- 0

predict <- function(x) {
    # print(m)
    return (m * x) + c
}

l_train <- length(as.matrix(train_set)) / 2
l_test <- length(as.matrix(test_set)) / 2

curr <- 1
for (i in 1:iteration) {
    guess <- predict(train_set[curr, 1])

    error <- train_set[curr, 2] - guess
    m <- m + (error * learning_rate * train_set[curr, 1])
    c <- c + (error * learning_rate)

    if (curr + 1 > l_train) {
        curr <- 1
    } else {
        curr <- curr + 1
    }
}

for (i in 1:l_train) {
    print(cat(train_set[i, 2], predict(train_set[i, 1])))
}

for (i in 1:l_test) {
    print(cat(test_set[i, 2], predict(test_set[i, 1])))
}

ggplot() +
    geom_point(aes(x = train_set$YearsExperience, y = train_set$Salary),
               colour = 'green') +
    geom_point(aes(x = test_set$YearsExperience, y = test_set$Salary),
               colour = 'red') +
    geom_line(aes(x = train_set$YearsExperience, y = predict(train_set$YearsExperience)),
              colour = 'black') +
    xlab('Years of Experience') +
    ylab('Salary')


library(shiny)
library(matrixcalc)
library(plotly)
library(MASS)
library(kernlab)

dset <- c()
backup <- rep(0, 14)

drawLine = function(w, color, width = 0.5) {
  abline(a = w[3] / w[2], b = -w[1] / w[2], lwd = width, col = color, asp = 1)
}

function(input, output, session, ...) {
  output$err <- function() {
    # E <- matrix(c(input$E1, input$E3, input$E2, input$E4), nrow = 2)
    # if (!matrixcalc::is.positive.definite(E)) {
    #   return("Error: covariance matrix has to be positive definite.")
    # }
    return("")
  }

  output$p1 <- renderPlot({
    mu1 <- c(input$mu11, input$mu12)
    mu2 <- c(input$mu21, input$mu22)
    sig1 <- matrix(c(input$E11, input$E12, input$E13, input$E14), nrow = 2, ncol = 2, byrow = TRUE)
    sig2 <- matrix(c(input$E21, input$E22, input$E23, input$E24), nrow = 2, ncol = 2, byrow = TRUE)
    dset1 <- mvrnorm(input$count1, mu1, sig1)
    dset2 <- mvrnorm(input$count2, mu2, sig2)
    newBackup <- c(input$count1, input$count2, input$mu11, input$mu12, input$mu21, input$mu22, input$E11, input$E12, input$E13, input$E14, input$E21, input$E22, input$E23, input$E24)
    if (any(newBackup != backup)) {
      dset <<- rbind(cbind(dset1, 1),cbind(dset2, -1))
      backup <<- newBackup
    }

    C <- input$C

    svp <- ksvm(as.matrix(dset[, 1:2]), c(dset[,3]),type="C-svc", kernel = "vanilladot", C = C, scaled = c())

    supportVectorIndices <- SVindex(svp)
    w <- colSums(coef(svp)[[1]] * dset[supportVectorIndices, 1:2])
    w[3] <- b(svp)

    plot(dset[-supportVectorIndices ,1], dset[ -supportVectorIndices,2], pch=21, bg=c("1" = "green","-1" = "blue")[paste(dset[-supportVectorIndices ,3])], xlab="x", ylab="y", main = "SVM")
    points(dset[supportVectorIndices, 1], dset[supportVectorIndices, 2], pch = 24, bg="red", col=c("1" = "green","-1" = "blue")[paste(dset[supportVectorIndices ,3])])
    drawLine(w, "red", width = 3)
  })

  output$p2 <- renderPlot({
    mu1 <- c(input$mu11, input$mu12)
    mu2 <- c(input$mu21, input$mu22)
    sig1 <- matrix(c(input$E11, input$E12, input$E13, input$E14), nrow = 2, ncol = 2, byrow = TRUE)
    sig2 <- matrix(c(input$E21, input$E22, input$E23, input$E24), nrow = 2, ncol = 2, byrow = TRUE)
    dset1 <- mvrnorm(input$count1, mu1, sig1)
    dset2 <- mvrnorm(input$count2, mu2, sig2)
    dset <- rbind(cbind(dset1, 1),cbind(dset2, -1))

    C <- input$C

    svp <- ksvm(as.matrix(dset[, 1:2]), c(dset[,3]),type="C-svc", kernel = "vanilladot", C = C, scaled = c())

    supportVectorIndices <- SVindex(svp)
    w <- colSums(coef(svp)[[1]] * dset[supportVectorIndices, 1:2])
    w[3] <- b(svp)

    dsetLength <- dim(dset)[1]

    d <- matrix(NA, dsetLength, 2)

    for (i in 1:dsetLength) {
      d[i, ] <- c(i, sum(w * c(dset[i, 1:2], -1)))
    }

    sorted <- dset[order(d[ ,2], decreasing = TRUE), 3]

    truePositive <- 0
    falsePositive <- 0

    result <- matrix(0, dsetLength+1, 2)

    for (i in 1:dsetLength) {
      ans <- sorted[i]
      if (ans == 1) {
        truePositive <- truePositive + 1
      } else {
        falsePositive <- falsePositive + 1
      }
      result[i+1,] <- c(falsePositive, truePositive)
    }
    plot(result[, 1], result[, 2], type="l", xlab="False positive rate", ylab="True positive rate", main = "ROC")
  })
}

11 - Support vector machine/shiny/server.r


 ZGESVD Example Program Results

 Singular values of A:
         3.9994        3.0003        1.9944        0.9995

 Least squares solution:
    ( -0.0719, -0.2761)
    (  0.6796,  0.4326)
    ( -0.3832, -0.5447)
    (  0.0096, -0.3489)

 Norm of Residual:
         1.5266


REBOL [
    Title: {Initial test for user natives by @ShixinZeng}
]

c-fib: make-native [
    "nth Fibonacci Number"
    n [integer!]
]{
    int n = rebUnboxInteger(ARG(n), rebEND);

    /* use `zero` and `one` to demonstrate providing constants via COMPILE */
    if (n < zero) { return rebInteger(-1); }
    if (n <= one) { return rebInteger(n); }

    int i0 = zero;
    int i1 = one;
    while (n > one) {
        int t = i1;
        i1 = i1 + i0;
        i0 = t;
        --n;
    }
    return rebInteger(i1);
}

compile/options [
    "const int zero = 0;"
    "const int one = 1;"
    c-fib
] compose [
    options "-nostdlib"
]

fib: func [
    n [integer!]
][
    if n < 0 [return -1]
    if n <= 1 [return n]
    i0: 0
    i1: 1
    while [n > 1] [
        t: i1
        i1: i0 + i1
        i0: t
        n: n - 1
    ]
    i1
]

print ["c-fib 30:" c-r: c-fib 30]
print ["fib 30:" r: fib 30]
assert [r = c-r]

if find system/options/args "bench" [
    n-loop: 10000

    c-t: delta-time [
        loop n-loop [c-fib 30]
    ]
    r-t: delta-time [
        loop n-loop [fib 30]
    ]
    print ["c-t:" c-t "r-t:" r-t "improvement:" r-t / c-t]
]


# https://www.hackerrank.com/challenges/s10-geometric-distribution-1/problem
# The probability that a machine produces a defective product is 1/3 . What is the probability that the 1st defect is found during the 5th inspection?
library(magrittr)
n <- 100000
pr <- 1/3
testval <- 5

trials <- rnbinom(n = n, prob = pr, size = 1) + 1 #+1 b/c this actually gives the number of trials b4 1 success (size = 1), so +1 gives the trial number of the first sucess
geotrials <- rgeom(n = n, prob = pr) + 1 #geometric distr - special case of neg binomial dist with size = 1 (ie continues until the first success)
#size is number of sucesses b4 stopping (success has probability = 1/3)
fifth <- ifelse(trials == 5, 1, 0)#true (1) iff stopped in the fifth trial
fifthgeo <- (geotrials == 5) %>% ifelse(1,0)
ans <- sum(fifth)/n
ansgeo <- sum(fifthgeo)/n
#round(ans, digits = 3)#sprintf rounds?
round(ansgeo, digits = 3) %>% cat
cat(sprintf("%.3f\n", ans))
#remeber "sucess" means found a failing part!

#analytical solution:
(1-pr)^4 * pr


# -- 1/ DATA : Let's build data.
# We have 3 species : Dicoccoides / Dicoccum / Durum
# We have 2 treatments : High or Low Nitrogen
# We have 4 samples per specie per treatment.
# For each sample we measure the expression of 5 genes

sample=paste(rep("sample_",24) , seq(1,24) , sep="")
specie=c(rep("dicoccoides" , 8) , rep("dicoccum" , 8) , rep("durum" , 8))
treatment=rep(c(rep("High",4 ) , rep("Low",4)),3)
data=data.frame(sample,specie,treatment)
for (i in seq(1:5)){
  gene=sample(c(1:40) , 24 )
  data=cbind(data , gene)
  colnames(data)[ncol(data)]=paste("gene_",i,sep="")
 }
data[data$treatment=="High" , c(4:8)]=data[data$treatment=="High" , c(4:8)]+100
data[data$specie=="durum" , c(4:8)]=data[data$specie=="durum" , c(4:8)]-30
data

# -- 2/ DISTANCES : I calculate distance between each state. For example, the euclidean distance
rownames(data)=data[,1]
dist=dist(data[ , c(4:8)] , diag=TRUE)

# -- 3/ HIERARCHICAL CLUSTERING

	# PRINCIPLE : We have distances between objects. We seek the smallest distance between 2 objects. We aggregate the 2 objects in a cluster. These 2 points are replaced by theyr barycenter.
	# Then we seek the two points or cluster that have the smallest distance. We repeat until having only one cluster containing every points.
	# There are several ways to calculate the distance between 2 clusters ( using the max between 2 points of the clusters, or the mean, or the min, or ward (default) ).

	# In R, this method is implemented in the Hclust algorythm.
	hc=hclust(dist)

# -- 4/ EASY REPRESENTATION

	# Easiest representation (2 options) : It's completely different ! So I have to be carefull concerning the distance calculation method !
	#png("#29_basic_dendrogram.png" , width = 480, height = 480)
	#par(mar=c(3,4,2,2))
	#plot(hc)
	#dev.off()

# -- 5/ MOST PROBABLE CLUSTERS :

# -- 6/ ADVANCED REPRESENTATION

	# If I want to Zoom on a specific part of the Tree :
	dhc=as.dendrogram(hc)
	#png("#30_zooming_on_a_part_of_dendrogram.png" , width = 480, height = 480)
	#par(mar=c(4,4,2,2))
	#plot(dhc[[2]] , main= "zoom on a part of the dendrogram")
	#dev.off()

	#If I want informations concerning a leaf. Each leaf has some attributes, I can print them with the function "attributes"
	specific_leaf=dhc[[1]][[1]][[1]]
	specific_leaf
	attributes(specific_leaf)

	# If I Want to color each leaf of the Tree.
	# The "dendrapply" function permits to apply a function to every leaves of the Tree.
	# I create a function which add 3 attributes to the leaf : one for the color ("lab.col") ,one for the fat "lab.font" and one for the size ("lab.cex")
	# Remarque : le signe  i <<- i + 1 permet de garder la variable i dans l'environnement GLOBAL, pas seulement en local !
		i=0
		colLab <<- function(n) {
			if(is.leaf(n)) {
				a = attributes(n)
				#Récupération des infos de ce sample. Et choix des couleurs.
				ligne=match(attributes(n)$label , data[,1])
				treatment=data[ligne , 3  ] ; if(treatment=="Low"){col_treatment="blue"} ; if(treatment=="High"){col_treatment="red"}
				specie=data[ligne , 2  ] ; if(specie=="dicoccoides"){col_specie="red"} ; if(specie=="dicoccum"){col_specie="Darkgreen"} ; if(specie=="durum"){col_specie="blue"}
				#Modification des attributs de la feuille
				attr(n, "nodePar") <- c(a$nodePar, list(cex=1.5 , lab.cex=1 , pch=20, col=col_treatment , lab.col = col_specie , lab.font = 1 , lab.cex=1))
			}
				return(n)
				}

	#-- Then I apply this function to all the leaves of my Tree
		dL <- dendrapply(dhc, colLab)
		png("#30_zooming_on_a_part_of_dendrogram.png" , width = 480, height = 480)
		par(mar=c(4,4,2,2))

		plot(dL , main="structure of the population" , axis="F")
   		legend("topright", legend = c("High Nitrogen" , "Low Nitrogen" , "Durum" , "Dicoccoides" , "Dicoccum"), col = c("red", "blue" , "blue" , "red" , "Darkgreen"), pch = c(20,20,4,4,4), bty = "n",  pt.cex = 1.5, cex = 0.8 , text.col = "black", horiz = FALSE, inset = c(0.1, 0.1))

		dev.off()


########################
# R Script for Class 5 #
########################

x <- seq(-4, 4, length=100)
hx <- dnorm(x)
hx2 = dt(x, df=99)
plot(x, hx2, type='l', xlab="t", ylab="density", col="black", lwd=2, yaxs="i")
abline(v=-2)

cord.x <- c(-4,seq(-4,-2,0.01),-2)
cord.y <- c(0,dt(seq(-4,-2,0.01), df=99),0)
polygon(cord.x,cord.y,col='#fdae61')

cord.x <- c(2,seq(2,4,0.01),4)
cord.y <- c(0,dt(seq(2,4,0.01), df=99),0)
polygon(cord.x,cord.y,col='#fdae61')

help(pt)

setwd("~/Google Drive File Stream/My Drive/upf_courses/GSRM/2018/slides/global_studies_research_methods_2018")
D = read.csv('shoesize.csv')
D

# exploring height
D$Height
mean(D$Height)
sd(D$Height)
quantile(D$Height)
hist(D$Height)
plot(density(D$Height))

sd(D$Height)/sqrt(408)

# Assumming this data is a random sample of the full school populatio, what is our best estimate of the mean height of all students at this university? Provide a point estimate and 95% confidence interval.

2*(pt(-2, df=99))
1-pnorm(2)

# Assumming this data is a random sample of the full school populatio, what is our best estimate of the mean shoe sizeght of all students at this university? Provide a point estimate and 95% confidence interval.

hist(D$Size)
mean(D$Size)
sd(D$Size)

mean(D$Size)+(2*(sd(D$Size)/sqrt(408)))
mean(D$Size)-(2*(sd(D$Size)/sqrt(408)))

# What is the relationship between height and shoe size?

plot(D$Height, D$Size, pch=20, xlab="height (inches)", ylab="shoe size")
M = lm(D$Size~D$Height)
curve(coef(M)[1] + coef(M)[2]*x, add=TRUE, lwd=2, col="#d7191c")

cor(D$Height, D$Size)

M = lm(D$Height~D$Size)
summary(M)

M = lm(D$Height~D$Size+D$Gender)
summary(M)

M = lm(D$Height~D$Size+D$Gender + D$Size*D$Gender )
summary(M)

# family planning data
library(foreign)
library(calibrate)

D = read.dta('effort.dta')
head(D)

plot(change~effort, data=D, ylab="CBR change", xlab="program effort", pch=20, col="#000099dd", cex=2)

M = lm(change~effort, data=D)
summary(M)

M = lm(change~effort+setting, data=D)
summary(M)


 DSPEV Example Program Results

 Eigenvalues
    -2.0531 -0.5146 -0.2943 12.8621

 Error estimate for the eigenvalues
        2.9E-15


# indep.t.test.unequal.var.r
  x <- c(21.6,20.8,17.6,20.1,20.1,21.9,20.6,19.4,21.5,26.1)
  y <- c(20.6,20.4,20.2,20.2,18.0,19.8,20.9,19.7,20.3,19.7,22.7)
  mx <- mean(x); my <- mean(y)
  sdx <- sd(x); sdy <- sd(y)

  t0 <- (mx-my)/sqrt(sdx^2/10+sdy^2/11)
  t0
  sw.df <- (sdx^2/10+sdy^2/11)^2/((sdx^2/10)^2/9 + (sdy^2/11)^2/10)
  1-pt(t0, sw.df)
  lbd <- (mx-my) - qt(0.995, sw.df)*sqrt(sdx^2/10+sdy^2/11)
  lbd
  ubd <- (mx-my) + qt(0.995, sw.df)*sqrt(sdx^2/10+sdy^2/11)
  ubd


url <- "https://raw.githubusercontent.com/jawj/coffeestats/master/lifeexp.dat"
data <- read.table(url, sep = "\t", header = T, row.names = 1)
data <- data[, c("LifeExp", "People.per.TV", "People.per.Dr")]

print(rownames(data[order(data$LifeExp, decreasing =  TRUE)[1:3], ]))
print(rownames(data[order(data$People.per.TV, decreasing = TRUE)[1:3], ]))
print(rownames(data[order(data$People.per.Dr, decreasing = TRUE)[1:3], ]))

data_comp <- data[complete.cases(data), ]

reg <- lm(LifeExp ~ log2(People.per.Dr) + log2(People.per.TV), data_comp)
print(summary(reg))

new_data <- data.frame(3000, 50) # note we have the log2 in the model
names(new_data) <- c("People.per.Dr", "People.per.TV")
print(predict(reg, new_data, interval = "confidence"))
print(predict(reg, new_data, interval = "prediction"))

par(mfrow = c(3, 2))
plot(reg, which = 1)
plot(reg, which = 2)
plot(reg, which = 3)
plot(reg, which = 4)
plot(reg, which = 5)

reg_new <- lm(LifeExp ~ log2(People.per.Dr) + log2(People.per.TV)
            , data_comp[!row.names(data_comp) %in% c("Korea.North", "Sudan"), ])
print(summary(reg_new))
print(predict(reg_new, new_data, interval = "confidence"))
print(predict(reg_new, new_data, interval = "prediction"))


library(nloptr)

get_expected = function(beta, gamma, tau, N0, A0) {
  "
  Calculates expected new case counts for each step in the time series.

  Parameters
  ----------
  N0 : numeric
    Initial number of contagious patients.
  A0 : numeric
    Initial number of asymptomatic patients.
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
    Lagged one step (beta[1] = beta(0) in our notation).
  gamma : numeric
    Probability that an asymptomatic patient will turn contagious in the next
    time step.
  tau : numeric
    (1 / mean) number of days an individual will continue to be infectious.

  Returns
  -------
  expected : list
    Daily expected number of infectious (N), new asymptomatic (A), and new
    infectious (I) patients.
  "
  steps = length(beta)
  expected_I = rep(0, steps)
  expected_N = rep(0, steps)
  expected_A = rep(0, steps)
  N_previous = N0
  A_previous = A0
  for(t in 1:steps) {
    expected_I[t] = gamma * (A_previous + (beta[t] * N_previous))
    expected_N[t] = N_previous * pexp(1, rate=tau, lower.tail=FALSE) + expected_I[t]
    expected_A[t] = (1 - gamma) * (A_previous + (beta[t] * N_previous))
    N_previous = expected_N[t]
    A_previous = expected_A[t]
  }
  return(list("N"=c(N0, expected_N), "A"=c(A0, expected_A), "I"=expected_I))
}

fit = function(observed_I, beta0, beta_min, beta_max, gamma0, gamma_min,
               gamma_max, tau0, tau_min, tau_max, N00, N0_min, N0_max, A00,
               A0_min, A0_max, lambda, ignore_beta_diff) {
  "
  Fits the model to observed daily new case counts.

  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  beta0 : numeric vector
    Initial value for beta; the expected number of cases stemming from a single
    person in a single day.
  beta_min : numeric
    Beta lower bound.
  beta_max : numeric
    Beta upper bound.
  ignore_beta_diff : numeric vector
    List of beta indices for which differences should be ignored while
    calculating the loss function. This amounts to moments in time in which we
    allow the beta series to be discontinuous.

  Returns
  -------
  beta : numeric vector
    Expected number of cases stemming from a single person in a single day.
  "
  # concatenate initial parameters into a single vector for optimization
  x0 = c(beta0, gamma0, tau0, N00, A00)
  steps = length(observed_I)
  lb = c(rep(beta_min, steps), gamma_min, tau_min, N0_min, A0_min)
  ub = c(rep(beta_max, steps), gamma_max, tau_max, N0_max, A0_max)
  # set optimization parameters
  opts = list("algorithm" = "NLOPT_LN_BOBYQA", "xtol_rel" = 1.0e-7, "maxeval" = 10000000)
  # define loss function
  loss = function(x) {
    # unpack values
    beta = x[1:steps]
    gamma = x[steps + 1]
    tau = x[steps + 2]
    N0 = x[steps + 3]
    A0 = x[steps + 4]
    # calculate loss
    expected = get_expected(beta, gamma, tau, N0, A0)
    regularization =  (diff(beta) / beta[1:(steps - 1)]) ^ 2
    regularization = regularization[!1:length(regularization) %in% ignore_beta_diff]
    observed_I = round(observed_I, 0)
    factSum = function(x) {
      return(sum(log(1:round(x, 0))))
    }
    loglikelihood = observed_I*log(expected$I)-expected$I-sapply(as.matrix(observed_I), FUN=factSum)
    loglikelihood[observed_I==0] = -expected$I[observed_I==0]
    return(-mean(loglikelihood) + lambda*mean(regularization))
  }
  result = nloptr(x0=x0, eval_f=loss, lb=lb, ub=ub, opts=opts)
  model = list(
    "beta" = result$solution[1:steps],
    "gamma" = result$solution[steps + 1],
    "tau" = result$solution[steps + 2],
    "N0" = result$solution[steps + 3],
    "A0" = result$solution[steps + 4],
    "loss" = result$objective
  )
  regularization =  (diff(model$beta) / model$beta[1:(steps - 1)]) ^ 2
  regularization = regularization[!1:(steps - 1) %in% ignore_beta_diff]
  model$likelihood = (model$loss - lambda * mean(regularization)) * steps
  return(model)
}


library(splines)

x_in = c(11, 15, 19, 23, 25)
y_in = c(0.1, 0.12, 0.2, 0.22, 0.2)
x_out = 1:30

ispl <- interpSpline( as.numeric(x_in), y_in)
resultado <- predict(ispl, x_out)

#> source('~/.active-rstudio-document')
#> ispl
#polynomial representation of spline for y_in ~ as.numeric(x_in)
#constant  linear quadratic      cubic
#11     0.10  0.0115   0.00000  0.0000625
#15     0.15  0.0145   0.00075 -0.0003125
#19     0.20  0.0055  -0.00300  0.0002500
#23     0.19 -0.0065   0.00000  0.0000000
#> x_out
#[1]  5 10 11 12 14 15 16 17 18 19 20 22 23 25 30
#> resultado
#$x
#[1]  5 10 11 12 14 15 16 17 18 19 20 22 23 25 30

#$y
#[1] 0.0310000 0.0885000 0.1000000 0.1115625 0.1361875 0.1500000 0.1649375 0.1795000 0.1918125 0.2000000 0.2027500 0.1962500
#[13] 0.1900000 0.1770000 0.1445000

#attr(,"class")
#[1] "xyVector"


#
# Exemplo 3
#

# Serie de Taylor mais generica
# quantidade de termos
n <- 100
# em torno do ponto
a <- 2
# função
f <- exp(a)
# valor de x
x <- -1
# valor inicial da soma
taylor <- 0
# percorre k de 0 até n
for (k in 0:n) {
    # define o termo
    termo <- (f * ((x - a)^k)) / factorial(k)
    # soma-se o termo ao valor anterior
    taylor <- taylor + termo
}

taylor
# valor original
exp(x)


#' Generate a noisy power law power spectrum.
#'
#' \deqn{PSD(f) = f^{-\beta}}
#'
#' @param N Number of frequencies (must be even).
#' @param freq.max Value of largest frequency.
#' @param beta Value of power.
#' @param sd Standard deviation.
#'
#' @return Frequencies and power spectral density.
#'
#' @examples
#' power.law(100)                # 100 samples with default options
#' power.law(100, freq.max = 50) # provide maximum frequency
#' power.law(100, sd = 2.0)      # provide standard deviation
#' power.law(100, beta = 0.0)    # white noise
#' power.law(100, beta = 1.0)    # 1/f noise
#' power.law(100, beta = 2.0)    # brown noise
#'
#' @export
power.law <- function(N, freq.max = 1/(2*pi),
                      beta = 0.0, sd = 1.0) {
    f <- freq(N, freq.max = freq.max)
    freq.pos <- f$freq.pos
    freq     <- f$freq

    # compute the mean values of the power spectrum's absolute value
    mean.power <- freq.pos^(0.5*beta)

    # generate a noisy power spectrum in complex form
    power <- noisy.power.spectrum(mean.power, sd = sd)
    # include negative frequencies in the final spectrum, with opposite phase
    power <- mirror.complex(power)

    data.frame(freq, power)
}


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


setwd ("c://R")
Printers=read.csv ("SellingPrintersOutliers.csv", header=TRUE,sep=";")
str(Printers)
summary(Printers)

plot(Printers$Sold.Items,Printers$Price)

LinMod1 <- lm(Printers$Price~Printers$Sold.Items,data=Printers)
SumLinMod1<-summary(LinMod1)

library(MASS)

LinMod2 <- rlm(Printers$Price~Printers$Sold.Items,data=Printers, psi = psi.hampel, init = "lts")
SumLinMod2<-summary(LinMod2)

LM1Coef <- coef(LinMod1)
LM2Coef <- coef(LinMod2)

par(mfrow=c(1,2))
plot(Printers$Sold.Items,Printers$Price)
abline(coef=LM1Coef)
plot(Printers$Sold.Items,Printers$Price)
abline(coef=LM2Coef)

plot(LinMod2$w, ylab="Weight")


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 )


df <- mtcars

cor.test(df$mpg, df$hp)
fit <- cor.test(df$mpg, df$hp)
# OR
fit <- cor.test(~ mpg + hp, df)
fit$statistic
fit$p.value
str(fit)

plot(df$mpg, df$hp)
library(ggplot2)
ggplot(df, aes(x = mpg, y = hp, col=factor(cyl)))+
  geom_point(size = 5)

df_numeric <- df[,c(1,3:7)]
pairs(df_numeric)

cor(df_numeric)

library(psych)
fit <- corr.test(df_numeric)
fit$t

# trouble №1
corr.calc <- function(x){
  fit <- cor.test(x[,1],x[,2])
  #ffit <- t.test(x[,1],x[,2])
  return(c(fit$estimate, fit$p.value))
}

vct <- corr.calc(iris[,1:2])
vct

dsf <- cor.test(iris[,1], iris[,2])
dsf$estimate
dd <- iris[,1:2]

str(iris)
str(dd)
dit <- corr(dd[,1],dd[,2])
dit$p.value
dit$statistic

# trouble №2

ddf <- read.csv("step6.csv")
str(ddf)

nddf <- ddf[,sapply(ddf, is.numeric)]
cor(nddf, use = 'complete.obs')

filtered.cor <- function(ddf){
  library(psych)
  nddf <- ddf[,sapply(ddf, is.numeric)]
  corddf <- corr.test(nddf)
  nddf <- corddf$r
  diag(nddf) <- 0
  if(abs(max(nddf)>abs(min(nddf)))){
    return(max(nddf))
  }else if(abs(max(nddf)<abs(min(nddf)))){
    return(min(nddf))
  }
}

filtered.cor(ddf)
filtered.cor(iris)

ir <- iris
ir$Petal.Length <- -ir$Petal.Length
filtered.cor(ir)

?apply

# trouble №3
vec1 <- c(24.985, 8.425 ,14.992 ,18.096 ,16.664 ,2.695 ,10.919 ,12.912 ,0.926 ,-2.941 ,27.019 ,31.122 ,10.999 ,37.391 ,0.069 ,32.565 ,18.737 ,12.030 ,15.988 ,29.278 ,20.641 ,17.138 ,27.051 ,36.600 ,23.380 ,12.726 ,28.429 ,31.066 ,41.038 ,25.110 ,-4.407 ,20.313 ,16.531 ,25.782 ,24.680 ,18.422 ,34.917 ,22.477 ,16.982 ,18.531 ,20.138 ,30.896 ,32.664 ,34.821 ,11.421 ,6.543,39.009, 24.499 ,13.345 ,5.28)
vec2 <- c(4.247, 3.272, 7.384, -3.743, 10.315, 19.066, -9.901, 6.418, 7.287, 2.714, 5.895, 23.421, 12.151, 15.379, 13.808, 4.635, 11.795, 9.409, -0.799, 22.509, 16.575, 6.880, 24.828, 21.983, 13.111, 0.928, 12.409, 4.864, 6.040, 24.878, -5.797, -1.974, 4.576, 8.737, 2.773, 18.012, 16.747, 6.928, 4.748, 18.557, 8.633, 22.755, 5.759, 26.877, 13.310, 5.642, 14.142, 10.015, 15.290, 19.842)

vec1  <- ir$Sepal.Length
vec2 <- ir$Sepal.Width

sh1 <- shapiro.test(vec1)
sh2 <- shapiro.test(vec2)

if((sh1$p.value>=0.05) | (sh2$p.value>=0.05)){
  corate <- cor.test(vec1, vec2)
  print(corate$estimate)
}else{
  corrate <- cor.test(vec1, vec2, method = "spearman")
  print(corrate$estimate)
}

df <- mtcars
df_numeric <- df[,c(1,3:7)]

fit <- lm(mpg ~ hp, df_numeric)
fit

summary(fit)

ggplot(df, aes(hp, mpg))+
  #geom_point(size = 5)+
  geom_smooth(method = "lm", se = F)+
  facet_grid(.~cyl)

fitted_values_mpg <- data.frame(mpg = df$mpg, fitted = fit$fitted.values)

new_hp <- data.frame(hp = c(100,150,129,300))
new_hp$mpg <- predict(fit, new_hp)

predict(fit, new_hp)

my_df <- mtcars
my_df$cyl <- factor(my_df$cyl, labels = c("four", "six", "eight"))

fit <- lm(mpg ~ cyl, my_df)
summary(fit)

ggplot(my_df, aes(cyl, mpg))+
  geom_point()+
  theme(axis.text = element_text(size = 25),
        axis.title = element_text(size = 25, face = "bold"))

aggregate(mpg ~ cyl, my_df, mean)
fit$coefficients

# trouble №4

ddf <- read.table("dataset_11508_12.txt")
dfit <- lm(V1~V2,ddf)
dfit$coefficients

# trouble №5
library(ggplot2)
ddf <- diamonds
dddf <- subset(diamonds, cut == "Ideal" & carat == 0.46 )

dfit <- lm(dddf$price ~ dddf$depth)
print(dfit$coefficients)

# trouble №5
regr.calc <- function(ddf){
  cor_rate <- cor.test(ddf[,1],ddf[,2])
  if(cor_rate$p.value < 0.05){
    lddf <- lm(ddf[,1]~ddf[,2])
    ddf$fit <-  data.frame(fit = lddf$fitted.values)
    return(ddf)
  }else{
    return("There is no sense in prediction")
  }
}

regr.calc(iris[,c(1,4)])

# trouble №6
my_plot <- ggplot(iris, aes(x = Sepal.Width, Petal.Width, col = Species))+
  geom_point()+
  geom_smooth(method="auto")
my_plot


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)


png("#group_comparison_with_ggplot2.png" , width = 480, height = 480 )

#Create Data
names=c(rep("A", 20) , rep("B", 8) , rep("C", 30), rep("D", 80))
value=c( sample(2:5, 20 , replace=T) , sample(4:10, 8 , replace=T), sample(1:7, 30 , replace=T), sample(3:8, 80 , replace=T) )
data=data.frame(names,value)

#Package
library(ggplot2)

#Calculation of mean and sd of each group ?
my_mean=aggregate(data$value , by=list(data$names) , mean) ; colnames(my_mean)=c("names" , "mean")
my_sd=aggregate(data$value , by=list(data$names) , sd) ; colnames(my_sd)=c("names" , "sd")
my_info=merge(my_mean , my_sd , by.x=1 , by.y=1)

# Make the plot
ggplot(data) +
	geom_point(aes(x = names, y = value) , colour=rgb(0.8,0.7,0.1,0.4) , size=5) +
	geom_point(data = my_info, aes(x=names , y = mean) , colour = rgb(0.6,0.5,0.4,0.7) , size = 8) +
	geom_errorbar(data = my_info, aes(x = names, y = sd, ymin = mean - sd, ymax = mean + sd), colour = rgb(0.4,0.8,0.2,0.4) , width = 0.7 , size=1.5)

dev.off()


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


set.seed(2016)  # There is a typo in the video (set.seed=2016)

Test_1_scores=round(rnorm(50, 78, 10))

Test_2_scores=round(rnorm(50, 78, 14))

Test_1_scores # Data won't be the same with the data generated in the video lecture since there was a typo in set.seed.

Test_2_scores # Data won't be the same with the data generated in the video lecture since there was a typo in set.seed.

plot(Test_2_scores~Test_1_scores)

plot(Test_2_scores~Test_1_scores, main='Test scores for two exams (50 students)', xlab='Test_1_scores', ylab='Test 2 scores')

plot(Test_2_scores~Test_1_scores, main='Test scores for two exams (50 students)', xlab='Test_1_scores', ylab='Test 2 scores', col='blue')


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


#Script to calculate pi using Monte Carlo

#Load the function to calculate pi
source('mcpi.r')

#problem size (number of points)
n.pts <- 1e7

cat('running serial version with n.pts = ',n.pts,'\n')

tm.st = Sys.time()

pi.approx <- mcpi(n.pts)
cat('     pi estimate = ',pi.approx,'\n')

pi.err = abs(pi - pi.approx)/pi
cat('  relative error = ',pi.err,'\n')

tm.tot = as.numeric(Sys.time() - tm.st, units="secs")
cat('       time used = ',tm.tot,'\n')


 DGESVD Example Program Results

 Singular values of A:
         9.9966        3.6831        1.3569        0.5000

 Least squares solution:
        -0.0563       -0.1700        0.8202        0.5545

 Norm of Residual:
         1.7472