#' @export
homoskedastic_covariance_estimator <- function(X, y){
    s.2 <- unbiased_error_variance_estimation(X, y)

    solve(t(X) %*% X) * s.2
}

#' @export
white_heteroskedastic_covariance_estimator <- function(X, y){
    e.hat <- c(residual(X, y))
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.hat^2) %*% X

    `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

#' @export
hinkley_heteroskedastic_covariance_estimator <- function(X, y){
    e.hat <- c(residual(X, y))
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.hat^2) %*% X
    n <- dim(X)[1]
    k <- dim(X)[2]

    n/(n-k) * `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

#' @export
horn_heteroskedastic_covariance_estimator <- function(X, y){
    e.bar <- c(standardized_residual(X, y))
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.bar^2) %*% X

    `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

#' @export
mackinnon_heteroskedastic_covariance_estimator <- function(X, y){
    e.tilde <- prediction_error(X, y)
    `inv(X'X)` <- solve(t(X) %*% X)
    `X'DX` <- t(X) %*% diag(e.tilde^2) %*% X

    `inv(X'X)` %*% `X'DX` %*% `inv(X'X)`
}

# Notations and Abbreviations

#' @export
V.hat_beta.hat <- homoskedastic_covariance_estimator
#' @export
vce <- homoskedastic_covariance_estimator

#' @export
V.hat.hc0_beta.hat <- white_heteroskedastic_covariance_estimator
#' @export
robust_vce0 <- white_heteroskedastic_covariance_estimator

#' @export
V.hat.hc1_beta.hat <- hinkley_heteroskedastic_covariance_estimator
#' @export
robust_vce1 <- hinkley_heteroskedastic_covariance_estimator

#' @export
V.hat.hc2_beta.hat <- horn_heteroskedastic_covariance_estimator
#' @export
robust_vce2 <- horn_heteroskedastic_covariance_estimator

#' @export
V.hat.hc3_beta.hat <- mackinnon_heteroskedastic_covariance_estimator
#' @export
robust_vce3 <- mackinnon_heteroskedastic_covariance_estimator


library(ggplot2)

# change these parameters if you wnt
samplesPerExperiment <- 32
nExperiments <- 1000

# generate the experimental data
controls = rnorm(n = samplesPerExperiment*nExperiments, mean = 50, sd = 20)
tests = rnorm(n = samplesPerExperiment*nExperiments, mean = 60, sd = 20)
dim(controls) <- c(samplesPerExperiment, nExperiments)
dim(tests) <- c(samplesPerExperiment, nExperiments)

# this function calculate a p values
pValue <- function(nSamples1, mean1, var1,
                   nSamples2, mean2, var2) {
    delta <- mean1 - mean2
    sp2 <- ((nSamples1 - 1) * var1 + (nSamples2 - 1) * var2) / (nSamples1 + nSamples2 - 2)
    stderr <- sqrt(sp2 * (1 / nSamples1 + 1 / nSamples2))
    t <- delta / stderr
    pt(-abs(t), df = 2 * samplesPerExperiment - 2) +
        1 - pt(abs(t), df = 2 * samplesPerExperiment - 2)
}

# apply the pValue function to the experimental data
pVector <- mapply(pValue,
       apply(controls, 2, length),
       apply(controls, 2, mean),
       apply(controls, 2, var),
       apply(tests, 2, length),
       apply(tests, 2, mean),
       apply(tests, 2, var))

# plot a histogram
myPlot <- ggplot() +
    geom_histogram(aes(x = pVector,
                   fill = ifelse(pVector <= 0.05, "#56B4E9", "#E69F00")),
                   binwidth = 0.05,
                   color = "white") +
    scale_fill_discrete(name = "Significance",
                        labels = c("p <= 0.05", "p > 0.05")) +
    theme(axis.title.x = element_blank()) +
    theme(axis.title.y = element_blank())

# ...profit!
plot(myPlot)

# print out stuff
print(sum(pVector <= 0.05))
print(sum(pVector > 0.05))
print(summary(pVector))


y=1200
n=2500
pie=y/n
sigma=sqrt((pie*(1-pie))/n)
pie0=0.44
#test statistic
z=(pie-pie0)/sigma
print(z)
# critical value
alpha=0.05
z.alpha=qnorm(1-alpha)
#Because the observed value of z exceeds the critical value 1.645, we conclude that the
#percentage of students that participate in binge drinking exceeds the national percentage of 44%
nbar = n + (z.alpha^2)
pie_bar=(y+z.alpha)/nbar

sigma_bar=sqrt((pie_bar*(1-pie_bar))/nbar)
error_bar=z.alpha*sigma_bar
left=pie_bar-error_bar
right=pie_bar+error_bar
print(left)
print(right)
# the percentage of binge drinkers at the university is, with 95% confidence,between 46% and 50%


=begin
  # sample-jordan-form01.rb

  require "algebra"

  M4 = SquareMatrix(Rational, 4)
  m = M4[
      [-1, 1, 2, -1],
      [-5, 3, 4, -2],
      [3, -1, 0, 1],
      [5, -2, -2, 3]
  ]
  m.jordan_form.display; #=>
  #  2,   0,   0,   0
  #  0,   1,   1,   0
  #  0,   0,   1,   1
  #  0,   0,   0,   1
  puts

  #-----------------------------------
  m = M4[
    [3, 1, -1, 1],
    [-3, -1, 3, -1],
    [-2, -2, 0, 0],
    [0, 0, -4, 2]
  ]
  jf, pt, qt, field, modulus  = m.jordan_form_info
  p modulus #=> [a^2 + 4]
  jf.display; puts #=>
  #  2,   1,   0,   0
  #  0,   2,   0,   0
  #  0,   0,   a,   0
  #  0,   0,   0,  -a

  m = m.convert_to(jf.class)
  p jf == pt * m * qt #=> true

  #-----------------------------------
  m = M4[
      [-1, 1, 2, -1],
      [-5, 3, 4, -2],
      [3, -1, 0, 1],
      [5, -2, -2, 0]
  ]
  jf, pt, qt, field, modulus  = m.jordan_form_info
  p modulus #=> [a^3 + 3a - 1, b^2 + ab + a^2 + 3]
  jf.display; puts #=>
  #  2,   0,   0,   0
  #  0,   a,   0,   0
  #  0,   0,   b,   0
  #  0,   0,   0, -b - a

  m = m.convert_to(jf.class)
  p jf == pt * m * qt #=> true
((<_|CONTENTS>))
=end


# @' export
t_ratio <- function(coef, std_err){
    coef/std_err
}

# @' export
f_stat <- function(coef, std_err){
    t_ratio(coef, std_err)^2
}

critical_values <- function(distribution, ...){
    quantile_func <- get(paste0("q", distribution))

    quantile90 <- quantile_func(p=0.9, ...)
    quantile95 <- quantile_func(p=0.95, ...)
    quantile99 <- quantile_func(p=0.99, ...)

    ci_lower_bound90 <- quantile_func(p=0.5*0.1, ...)
    ci_lower_bound95 <- quantile_func(p=0.5*0.05, ...)
    ci_lower_bound99 <- quantile_func(p=0.5*0.01, ...)

    ci_upper_bound90 <- quantile_func(p=1-0.5*0.1, ...)
    ci_upper_bound95 <- quantile_func(p=1-0.5*0.05, ...)
    ci_upper_bound99 <- quantile_func(p=1-0.5*0.01, ...)

    output <- data.frame(
        critical_values = c(quantile90, quantile95, quantile99),
        ci_lower_bound = c(ci_lower_bound90, ci_lower_bound95, ci_lower_bound99),
        ci_upper_bound = c(ci_upper_bound90, ci_upper_bound95, ci_upper_bound99),
        row.names = c("0.9", "0.95", "0.99")
    )

    return(output)
}

significant_level <- function(f_stat, df){
    crit_values <- critical_values(distribution="f", df1=1, df2=df)

    result <- sapply(f_stat, function(f){
        if      (f > crit_values["0.99", "critical_values"])   '***'
        else if (f > crit_values["0.95", "critical_values"])   '**'
        else if (f > crit_values["0.9", "critical_values"])    '*'
        else                                  ' '
    })
}


mean.square.error <- function(theta.hat,theta) {
#Purpose:
#  Calculates mean squared errors for a matrix of estimates
#   where the rows are the replicates and the columns are different
#   estimators
#Inputs:
# theta.hat - vector of estimates.  Rows = replicates; Cols = estimators.
# theta - true value
#Outputs:
# vector of MSEs - one for each estimator

#count number of replicates for each estimator
  n <- dim(theta.hat)[1]
#count number of estimators
  num.ests <- dim(theta.hat)[2]
#create vector for results
  MSE.vec <- numeric(num.ests)

#Work out the sum of squared errors for each estimator:
#Go through each replicate
  for(i in 1:n) {
#go through each estimator
    for(j in 1:num.ests)
#Add the squared error for this replicate to the running total in MSE.vec
      MSE.vec[j] <- MSE.vec[j]+(theta.hat[i,j]-theta)^2
  }
#Turn from a sum of squared errors into mean square error by dividing by n
  MSE.vec <- MSE.vec/n

  return(MSE.vec)
}


### ANOVA

library(ggplot2)

# formulae

DV ~ IV # One-way

DV ~ IV1 + IV2 # Two-way

DV ~ IV1:IV2  # Two-way interaction

DV ~ IV1 + IV2 + IV1:IV2 # Main effects + interaction

DV ~ IV1 * IV2  # The same: Main effects + interaction

DV ~ IV1 + IV2 + IV3 + IV1:IV2

DV ~ (IV1 + IV2 + IV3)^2 # main effects and all possible interactions up to level 2

DV ~ IV1 + Error(subject/IV1) # repeated measures

# reading data

mydata <- read.csv('shops.csv')

# One-way ANOVA

boxplot(price ~ origin, data=mydata)

ggplot(mydata, aes(x = origin, y = price)) +
  geom_boxplot()

fit <- aov(price ~ origin, data=mydata)
summary(fit)

# Two-way ANOVA

fit1 <- aov(price ~ origin + store, data=mydata)
summary(fit1)

model.tables(fit1,"means")

# Interaction

pd = position_dodge(0.1)
ggplot(mydata, aes(x = store, y = price, color = origin, group = origin)) +
  stat_summary(fun.data = mean_cl_boot, geom = 'errorbar', width = 0.2, lwd = 0.8, position = pd)+
  stat_summary(fun.data = mean_cl_boot, geom = 'line', size = 1.5, position = pd) +
  stat_summary(fun.data = mean_cl_boot, geom = 'point', size = 5, position = pd, pch=15) +
  theme_bw()

fit3 <- aov(price ~ origin + store + origin:store, data=mydata)
summary(fit3)

fit4 <- aov(price ~ origin * store, data=mydata)
summary(fit4)

# Pairwise comparisons

ggplot(mydata, aes(x = food, y = price)) +
  geom_boxplot()

fit5 <- aov(price ~ food, data=mydata)
summary(fit5)

TukeyHSD(fit5)

# Repeated measures

mydata2 <- read.csv('therapy_data.csv')
str(mydata2)

mydata2$subject <- as.factor(mydata2$subject)

fit1 <- aov(well_being ~ therapy, data = mydata2)
summary(fit1)
fit1b <- aov(well_being ~ therapy + Error(subject/therapy), data = mydata2)
summary(fit1b)

fit2 <- aov(well_being ~ therapy*price, data = mydata2)
summary(fit2)

ggplot(mydata2, aes(x = price, y = well_being)) +
  geom_boxplot()

fit2b <- aov(well_being ~ therapy*price + Error(subject/(therapy*price)), data = mydata2)
summary(fit2b)

ggplot(mydata2, aes(x = price, y = well_being)) +
  geom_boxplot() +
  facet_grid(~subject)

fit3 <- aov(well_being ~ therapy*price*sex, data = mydata2)
summary(fit3)
fit3b <- aov(well_being ~ therapy*price*sex + Error(subject/(therapy*price)), data = mydata2)
summary(fit3b)


#Example simultion code
#Author: Len Thomas
#Last updated: 25th October 2013

#Functions to run a simulation to look at the MSE arising from
# using trimmed means to estimate the mean of a mixture distribution
# See ExampleSimulation.pdf for details
#Some code to drive the simulation is provided in ExampleSimulationDriver.r

#Note that there are two versions of the functions mix.dist and RMSE
#Have a look at them, and try to decide which is better!...

do.sim <- function(mix.par=0.2,mu1=5,sigma1=4,mu2=5,df=4,n=30,
                   alpha.vec=c(0,0.1,0.2), M=1000) {
#Purpose:
# Runs a simulation to compute the RMSEs for trimmed means from
#  samples taken from a 2 point normal and t mixture model
#Inputs:
# mix.par - mixture parameter of the distribution (range 0-1)
# mu1 - mean of the normal component of the mixture
# sigma1 - sd of the normal component of the mixture
# mu2 - mean of the t component of the mixture
# df - degrees of freedom for the t component
# n - size of samples to generate in simulation
# alpha.vec - vector of trimming levels to try (0=no trim i.e. mean,
#   0.5=trim 50th quantile above and below - i.e., median)
# M - number of simultions to run
#Output: List containing elements:
# MSE - vector of the MSEs at each trim level
# ests - matrix with M rows and length(alpha.vec) columns containing the raw estimates
# mu - the true mean of the input distribution

  #initialize matrix of outputs
  est.matrix <- matrix(NA,M,length(alpha.vec))
  #run simulation
  for(simulation in 1:M) {
    temp <- mix.dist(n,mix.par,mu1,sigma1,mu2,df)
    est.matrix[simulation,] <- estimate(temp,alpha.vec)
  }

  #work out the expected value of the input distribution
  E.Z<-get.E.Z(mix.par,mu1,mu2)

  #Calculate MSEs
  mean.square.error <- MSE(est.matrix,E.Z)

  return(list(MSE=mean.square.error, ests=est.matrix, mu=E.Z))

}

get.E.Z <- function(mix.par, mu1, mu2){
#Purpose: Returns the expected value of a mixture with mix proportion
# mix.par, and means mu1 and mu2
  return(mix.par*mu1+(1-mix.par)*mu2)
}

mix.dist <- function(n,mix.par,mu1,sigma1,mu2,df) {
#Purpose: Returns n samples from the mixture distribution
#Inputs:
# n - number of samples to return
# mix.par - pi in the practical notes -- proportion of samples from norm dist
# mu1 - mean of norm dist
# sigma1 - sd of norm dist
# mu2 - mean of t dist
# df - df for t dist
#Outputs:
# vector of n values from the mixture distribution
#Implementation note:
# This version uses vectorization - but wastefully samples from
# both the normal and t for each observation.  See below for another
# way to do this. Which is quicker, I wonder?

  #sample n values from a Bernoulli dist, to see which distribution
  # each data point comes from
  nu <- rbinom(n,1,mix.par)

  #sample values from the normal
  X <- rnorm(n,mu1,sigma1)
  #sample values from the t
  Y <- mu2 + rt(n,df)

  #put them together
  Z <- nu*X + (1-nu)*Y
  return(Z)
}

mix.dist.alt <- function(n,mix.par,mu1,sigma1,mu2,df) {
#Purpose: Alternative implementation of routine to sample n values
#  from the mixture distribution
#Inputs:
# n - number of samples to return
# mix.par - pi in the practical notes -- proportion of samples from norm dist
# mu1 - mean of norm dist
# sigma1 - sd of norm dist
# mu2 - mean of t dist
# df - df for t dist
#Outputs:
# vector of n values from the mixture distribution

  #create results vector
  Z<-numeric(n)

  #go through each observation...
  for(i in 1:n){
    #...determine if it comes from the normal or t distribution
    if(rbinom(1,1,mix.par)==1) {
      #normal distribution
      Z[i]<-rnorm(1,mu1,sigma1)
    } else {
      #t distribution
      Z[i]<-mu2+rt(1,df)
    }
  }

  return(Z)
}

estimate <- function(x,trim) {
#Purpose: Estimates trimmed means on data x, using a vector of trimming
# levels trim
#Inputs:
# x - data
# trim - vector of trimming levels
#Outputs:
# vector of trimmed means

  #create vector for results
  n.trimmed.means<-length(trim)
  trimmed.means<-numeric(n.trimmed.means)

  #loop through, calculating trimmed means
  for(i in 1:n.trimmed.means)
    trimmed.means[i] <- mean(x,trim[i])

  return(trimmed.means)
}

MSE <- function(theta.hat,theta) {
#Purpose: Calculates mean squared errors for a matrix of estimates
# where the rows are the replicates and the columns are different
# estimators
#Inputs:
# theta.hat - vector of estimates.  Rows = replicates; Cols = estimators.
# theta - true value
#Outputs:
# vector of MSEs - one for each estimator
#Implementation note:
# This version uses a double loop.  See below for a more vectorized
#  version of this function.  Which is quicker?

  #count numeber of replicates for each estimator
  n <- dim(theta.hat)[1]
  #count number of estimators
  num.ests <- dim(theta.hat)[2]
  #create vector for results
  MSE.vec <- numeric(num.ests)

  #Work out the sum of squared errors for each estimator:
  #Go through each replicate
  for(i in 1:n) {
    #go through each estimator
    for(j in 1:num.ests)
      #Add the sqared error for this replicate of the estimator to
      # the running total in MSE.vec
      MSE.vec[j] <- MSE.vec[j]+(theta.hat[i,j]-theta)^2
  }
  #Turn from a sum of squared errors into mean square error by dividing
  # by n
  MSE.vec <- MSE.vec/n

  return(MSE.vec)
}

MSE.alt <- function(theta.hat,theta) {
#Purpose: Alternative vectorized implementation of function to
# calculate mean squared errors for a matrix of estimates
# where the rows are the replicates and the columns are different
# estimators
#Inputs:
# theta.hat - vector of estimates.  Rows = replicates; Cols = estimators.
# theta - true value
#Outputs:
# vector of MSEs - one for each estimator

  #Declare function to calculate MSE of a vector
  MSE.vec <- function(theta.hat.vec, theta) {
  #Purpose: calculates MSE of a vector
  #Inputs:
  # theta.hat.vec - vector of estimates
  # theta - true value
  #Output: MSE
     square.error<-(theta.hat.vec-theta)^2
     MSE<-mean(square.error)
     return(MSE)
  }

  #Apply this function to each column of theta.hat
  MSE<-apply(theta.hat,2,MSE.vec,theta)

  return(MSE)
}


#Q2. The sum of the squares of the first ten natural numbers is,
#12+22+...+102=385
#The square of the sum of the first ten natural numbers is,
#(1+2+...+10)2=552=3025
#Hence the difference between the sum of the squares of the first ten natural numbers and the square of the sum is
#3025−385=2640
#.Find the difference between the sum of the squares of the first one hundred natural numbers and the square of the sum.

sum=0;
sq=0;
res = 0;
n = 10;

sum = n*(n+1)/2;
sq=(n*(n+1)*(2*n+1))/6;
res=sum*sum-sq;
print(res)


setwd("C:/Users/Nina/Desktop/machinelearning_estatistica_R/dataset")
library(readxl)

# Problema: Quero prever quanto será o salário com base  no passar dos anos

# Sep é um separador de coluna e o dec = separador de casas decimais.
dados <- read.table("salary.csv", header = TRUE,
                   sep = ",", dec = ".") #Função que lê o arquivo csv e salva em uma base de dados R

# Verifica os nomes das variaveis
names(dados)

# Verifica a correlação linear entre duas variáveis quantitativas
cor(dados$years, dados$salary)

# O output é +0.97. Portanto é uma correlação linear forte e positiva, ou seja, com o passar dos anos aumenta o meu salário

# Realizando o modelo de Regressão Linear

# Obtenha o modelo de regressão linear simples. Com 90% de confiança, há relação linear entre as variáveis?
regressao <- lm(data=dados,
                salary ~ years)
options(scipen=999)
summary(regressao)

# De acordo co o output temos BO = 25792.2, significa que quando você tem 0 anos , ou seja, nem nasceu, você já tem um salário assim.
# Podemos notar que a base de dados não é verossímel a realidade.

regressao$coefficients[1] + regressao$coefficients[2] * 1

# Calcula os valores preditos da varíavel resposta para cada elemento da amostra
regressao$fitted.values #: calcula os valores preditos da variável resposta(Y) para cada elemento da amostra (faz uma previsão);

# calcula o erro ou os resíduos (valor observado - valor predito) para cada ponto da amostra
regressao$residuals

# obtém uma estimativa dos coeficientes da regressão.
regressao$coefficients

#  Gerar o gráfico de dispersão - variáveis quantitativas

plot (salary ~ years,pch = 4, data = dados)

# Esta função ajusta a reta do modelo aos dados
abline(regressao,col="red")

# Aqui a gente consegue ver um raio quadrado bem grande, ou seja, a interpretação disso 95% da variabilidade explicada da variável y pela x.
summary(regressao)

setwd("C:/Users/Nina/Desktop/machinelearning_estatistica_R/dataset")
library(readxl)

# Problema: Quero prever quanto será o salário com base  no passar dos anos

# Sep é um separador de coluna e o dec = separador de casas decimais.
dados <- read.table("salary.csv", header = TRUE,
                   sep = ",", dec = ".") #Função que lê o arquivo csv e salva em uma base de dados R

# Verifica os nomes das variaveis
names(dados)

# Verifica a correlação linear entre duas variáveis quantitativas
cor(dados$years, dados$salary)

# O output é +0.97. Portanto é uma correlação linear forte e positiva, ou seja, com o passar dos anos aumenta o meu salário

# Realizando o modelo de Regressão Linear

# Obtenha o modelo de regressão linear simples. Com 90% de confiança, há relação linear entre as variáveis?
regressao <- lm(data=dados,
                salary ~ years)
options(scipen=999)
summary(regressao)

# De acordo co o output temos BO = 25792.2, significa que quando você tem 0 anos , ou seja, nem nasceu, você já tem um salário assim.
# Podemos notar que a base de dados não é verossímel a realidade.

regressao$coefficients[1] + regressao$coefficients[2] * 1

# Calcula os valores preditos da varíavel resposta para cada elemento da amostra
regressao$fitted.values #: calcula os valores preditos da variável resposta(Y) para cada elemento da amostra (faz uma previsão);

# calcula o erro ou os resíduos (valor observado - valor predito) para cada ponto da amostra
regressao$residuals

# obtém uma estimativa dos coeficientes da regressão.
regressao$coefficients

#  Gerar o gráfico de dispersão - variáveis quantitativas

plot (salary ~ years,pch = 4, data = dados)

# Esta função ajusta a reta do modelo aos dados
abline(regressao,col="red")

# Aqui a gente consegue ver um raio quadrado bem grande, ou seja, a interpretação disso 95% da variabilidade explicada da variável y pela x.
summary(regressao)


###############
## Section 2 ##
###############

library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

ITN.data <- read.csv("ITN_data.csv", header=TRUE)

###############
## Table 2.1 ##
###############

## Logit model

ITN.logit <- glm(useditn ~  malariamessage+education+richest+poorest+pregnant+altitude, family=binomial(link="logit"), data=ITN.data, x=TRUE)
ITN.logit.results <- cbind(ITN.logit$coefficients, sqrt(diag(vcov(ITN.logit))), confint.default(ITN.logit, level=0.95))
N <- length(ITN.logit$fitted.values)
colnames(ITN.logit.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(ITN.logit.results, digits=3)))
print(N)

###############
## Table 2.2 ##
###############

## Simulated Coefficients

beta <- ITN.logit$coefficients
covmat.beta <- vcov(ITN.logit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

mean.x <- colMeans(ITN.logit$x)
simprobs <- plogis(betadraw%*%mean.x)

simcoef.results <- append(quantile(simprobs, probs=c(0.5, 0.025, 0.975)), sd(simprobs))

## Bootstrapping

nsamples <- 1000
betas.boot <- matrix(NA,nsamples,length(beta))

for (i in 1:1000) {

	ITN.data.boot <- ITN.data[sample(seq(1,nrow(ITN.data),1), replace=TRUE),]
	logit.boot <- glm(useditn ~  malariamessage+education+richest+poorest+pregnant+altitude, family=binomial(link="logit"), data=ITN.data.boot)
	betas.boot[i,] <- logit.boot$coefficients
}

probs.boot <- plogis(betas.boot%*%mean.x)

boot.results <- append(quantile(probs.boot, probs=c(0.5, 0.025, 0.975)), sd(probs.boot))

## Delta Method

xb <- mean.x %*% beta
predicted.prob <- plogis(xb)

deltamethod.var <- (dlogis(xb)^2) * (t(mean.x) %*% covmat.beta %*% mean.x)
deltamethod.se <- sqrt(deltamethod.var)

delta.95ci.u <- predicted.prob + 1.96*deltamethod.se
delta.95ci.l <- predicted.prob - 1.96*deltamethod.se

delta.results <- cbind(predicted.prob, delta.95ci.l, delta.95ci.u, deltamethod.se)

## Summarize Results

statistical.uncertainty <- rbind(simcoef.results, boot.results, delta.results)
colnames(statistical.uncertainty) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(statistical.uncertainty) <- c("Simulated Coefficients", "Bootstrap", "Delta Method")

print(round(statistical.uncertainty, digits=3))


## Author: Sergio García Prado
## Title: Statistical Inference - Non parametric Tests - Exercise 08

rm(list = ls())

x1 <- c(1, 3, 3)  # c('A', 'C', 'C')
x2 <- c(2, 2, 3)  # c('B', 'B', 'C')

(s <- (x2 - x1)[x2 != x1])
# 1 -1

(n <- length(s))
# 2

(V <- sum((s > 0) * rank(abs(s))))
# 1.5

(V.mean <- n * (n + 1) / 4)
# 1.5

(V.var <- n * (n + 1) * (2 * n + 1) / 24)
# 1.25

## Asymptotic pvalue (with continuity correction, without tie correction)
1 - pnorm(V - 0.5, mean = V.mean, sd = sqrt(V.var))
# 0.672639576990711

## Asymptotic pvalue (with continuity correction, with tie correction)
(ties <- table(abs(s)))
# 1
# 2

(V.var.corrected <- V.var - sum(ties ^ 3 - ties) / 48)
# 1.125

1 - pnorm(V - 0.5, mean = V.mean, sd = sqrt(V.var.corrected))
#0.681324055883031

## Exact pvalue (not valid with ties)
1 - psignrank(V - 1, n)
# 0.5

wilcox.test(x1,  x2, paired = TRUE, alternative = "greater", exact = FALSE)
# Wilcoxon signed rank test with continuity correction
#
# data:  x1 - x2
# V = 1.5, p-value = 0.6813
# alternative hypothesis: true location is greater than 0


#' Compute Efficient Frontier of Mean Variance Optimization
#' @param returns
#' @param cset
#' @param list.arg
#' @param npoints
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{efrontPlot}}
#' @keywords efficient frontier
#' @examples
#' @export

efrontMV = function(returns,cset = NULL, list.arg= NULL, npoints = 10)
{

	require(quadprog)
	require(Rglpk)
	require(xts)

    if(is.null(cset))
    {
    mu = apply(returns,2,mean)
    mu.min = minmu(returns)
    mu.max = 1.2*max(mu)}     else
    {
      if (any(c("turnover.hobbs","turnover","propcost") %in% cset$clist.names)){ # find max mu without turnover/propcost constraint, since Rglpk doesn't work with turnover/propcost
        if(length(cset$clist.names)>1){

      index.mu <- which (cset$clist.names %in% c("turnover.hobbs","turnover","propcost"))
      clist.mu <- c(cset$clist.names[-index.mu],"sum")
      cset.mu <- combine.cset(clist=clist.mu,returns=returns,list.arg,verbose=F)
      mu.min = minmu(returns,cset.mu)

mu.max = .999*maxmu(returns,cset.mu)
      } else{mu = apply(returns,2,mean)
             mu.min = minmu(returns)
             mu.max = 1.2*max(mu)}
        }
      else {
      mu.min = minmu(returns)
      mu.max = .999*maxmu(returns,cset)
      }
    }
    p = ncol(returns)
    efront = matrix(rep(0,npoints*(p+2)),ncol = p+2)
    muvals = seq(mu.min,mu.max,length.out = npoints)
    for(i in 1:npoints){
    if(is.null(cset))
    {efront[i,] = mvo(returns,muvals[i],wts.only = F)}     else
    {
      efront[i,] = tryCatch(mvo(returns,muvals[i],cset,wts.only = F),error=function(e)return(NA))
      efront[i,] = as.numeric( efront[i,] )
    }}
    dimnames(efront)[[2]] = c("MU","VOL",dimnames(returns)[[2]])
    if(any(is.na(efront))){
    print("turnover/propcost constraints reduced the max mean return in efficient frontier plot")
    # violate
    efront<-efront[-which(apply(efront,1,function(x)any(is.na(x)))),]}
    efront
}

#' Plot Efficient Frontier of Mean Variance Optimization
#' @param returns
#' @param cset
#' @param mu.min
#' @param mu.max
#' @param rf
#' @param npoints
#' @param wts.xlab
#' @param printout
#' @param bar.ylim
#' @param list.arg
#' @param is.fancy
#' @author Kirk Li  \email{kirkli@@stat.washington.edu}
#' @seealso \code{\link{efrontPlot}}
#' @keywords efficient frontier
#' @examples
#' @export
efrontPlot = function(returns,cset = NULL,mu.min = NULL, mu.max = NULL, rf = NULL,
                         npoints = 10,wts.plot = T, wts.xlab="VOL",printout = F,bar.ylim = c(0,2),
                      list.arg=NULL, is.fancy=TRUE)
{
    if(is.null(cset))
    {efront = efrontMV(returns,cset = NULL, list.arg=list.arg, npoints)}     else
    {efront = efrontMV(returns,cset,list.arg=list.arg, npoints)}
	if(nrow(efront)<=1) stop("no solution, consider relaxing constraints")
    if(printout) print(efront)
    # Set smart x and y plotting region limits
    sigma = apply(returns,2,sd);mu = apply(returns,2,mean)
    xlim = c(0,max(sigma));ylim = range(mu);ylim[1] = ylim[1]-.05*diff(ylim)
    ylim[1] = min(min(efront[,1]),ylim[1])
    ylim[2] = max(max(efront[,1]),ylim[2])
    if(wts.plot) {par(mfrow = c(1,2), mgp= c(4, 2, 0), mar=c(8,6,4,2)+0.1)}
    plot(efront[,2],efront[,1],type = "l",col = 4,lwd = 2, xlab = "VOL",ylab = "MU", xlim = xlim,
            ylim = ylim, main = "MV Efficient Frontier")
    points(sigma,mu,pch = 20)
    text(sigma,mu, labels = dimnames(returns)[[2]],pos = 1, cex = .7)
    # If risk-free rate is supplied, get Sharpe ratio and plot tangent line
    if(!is.null(rf))
    {sr = (efront[,1]-rf)/efront[,2]
    i.srmax = which.max(sr);srmax = sr[i.srmax]
    abline(rf,srmax,lty = 2)
    # Plot points risk-free rate and tangency portfolio
    points(0,rf,pch = 16)
    points(efront[i.srmax,2],efront[i.srmax,1],pch = 16)
    # Plot point at minimum variance portfolio
    i.minvol = which.min(efront[,2])
    points(efront[i.minvol,2],efront[i.minvol,1],pch = 16)

    if(is.fancy){ #display parameter values in ef plot
     para.to.dis <- unique(unlist(sapply(cset$clist.names,function(x){
              clist.names.i <- paste("cset.",x,sep="")
              names(formals(clist.names.i))})))
     para.to.dis <- para.to.dis[para.to.dis %in% c("toc","ptc")] # only display these two parameters
     to.dis <- list.arg[para.to.dis]
     temp1 <- gsub("\\)","",gsub("\\(","",gsub(" c"," ",paste(names(to.dis),to.dis))))
     temp1 <- sub("[[:space:]]"," = ",temp1)
     temp1 <- c(temp1, paste("SRmax =",round(srmax,3),sep = ""),
                  paste("rf =",round(rf,3),sep = ""))
     temp1 <- temp1[unlist(lapply(temp1, function(x){nchar(x)<=50}))]
     legend("topleft",legend=paste(temp1),bty = "n",y.intersp=0.8, xjust=0, x.intersp=-0.5)
     } else{
    legend("topleft",inset = c(0,.05),paste("SRmax =",round(srmax,3),sep = ""),bty = "n")
    legend("topleft",inset = c(0,.1),paste("rf =",round(rf,3),sep = ""),bty = "n")}
    }
    wts.efront = t(efront); p = nrow(wts.efront)-2
#     MU <- efront[,"MU"]
#     SD <- efront[,"SD"]
    if(wts.plot)
    {
      barplotWts(wts.efront,legend.text = T,col = topo.colors(p),ylab = "WEIGHTS",xlab = wts.xlab, bar.ylim = bar.ylim)
      }
    par(mfrow = c(1,1))
}


#Task 1:
distance = function(x)
{
  x = as.matrix(x)
  u = apply(x*x,1,sum) %*% matrix(1.0,1,nrow(x))
  sqrt(abs(u + t(u) - 2 * x %*% t(x)))
}

ordering = function(mim)
{
  Non = nrow(mim) + 1
  ordering = rep(0,Non)
  ordering[1] = m[Non-1,1]
  ordering[2] = m[Non-1,2]
  location = 2
  for(i in seq(Non-2,1))
  {
    for(j in seq(1,location))
    {
      if(ordering[j] == i)
      {
        ordering[j] = mim[i,1]
        if(j==location)
        {
          location = location + 1
          ordering[location] = mim[i,2]
        } else
        {
          location = location + 1
          for(k in seq(loc, j+2)) ordering[k] = ordering[k-1]
          ordering[j+1] = mim[i,2]
        }
      }
    }
  }
  -ordering
}

hi_clust = function(d, method=c("single","complete","average","centroid"))
{
  if(!is.matrix(d)) d = as.matrix(d)

  method_function = switch(match.arg(method),
                     single   = min,
                     complete = max,
                     average  = mean,
                     centroid  = median)
  N = nrow(d)
  diag(d)=Inf
  n = -(1:N)
  m = matrix(0,nrow=N-1, ncol=2)
  h = rep(0,N-1)
  for(j in seq(1,N-1))
  {

    h[j] = min(d)
    i = which(d - h[j] == 0, arr.ind=TRUE)
    i = i[1,,drop=FALSE]
    p = n[i]
    p = p[order(p)]
    m[j,] = p
    grp = c(i, which(n %in% n[i[1,n[i]>0]]))
    n[grp] = j
    r = apply(d[i,],2,method_function)
    d[min(i),] = d[,min(i)] = r
    d[min(i),min(i)]        = Inf
    d[max(i),] = d[,max(i)] = Inf
  }

  structure(list(merge = m, height = h, order = iorder(m),
                 labels = rownames(d), method = method,
                 call = match.call(), dist.method = "euclidean"),
            class = "hclust")
}

i=seq(1,by=3,length.out=50)
x=as.matrix(iris[i,1:4])
h=hclust(dist(x),method="single")
h1=hi_clust(dist(x),method="single")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h1)

h=hclust(dist(x),method="complete")
h2=hi_clust(dist(x),method="complete")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h2)

h=hclust(dist(x),method="average")
h3=hi_clust(dist(x),method="average")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h3)

h=hclust(dist(x),method="centroid")
h4 = hi_clust(dist(x),method="centroid")
#print(cbind(h$merge[1:22,],h1$merge[1:22,]))
plot(h4)

#Task 2:
#loading the dataset
file_data <- read.delim("nci.data.txt", header=FALSE, sep=" ")
t(file_data)
file_trans <- t(file_data)
file_usable <- file_trans[complete.cases(file_trans), ]

#Task 3:
#K-means clustering
#The kmeans() function performs K-means clustering in R.

#K = 1
set.seed(1)
km.out <- kmeans(file_trans, 1,nstart = 20)
km.out$cluster

#K = 2
set.seed(1)
km.out = kmeans(file_trans, 2, nstart=20)
km.out$cluster

#K = 3
set.seed(2)
km.out = kmeans(file_trans, 2, nstart=20)
km.out$cluster

#K = 4
set.seed(2)
km.out = kmeans(file_trans, 2, nstart=20)
km.out$cluster


# Euler/Milstein

r <- 2; K <- 1; beta <- 0.25; Xzero <- 0.5;   # problem parameters
T <- 1; N <- 2^(11); dt <- T/N;               #
M <- 500;                                     # number of paths sampled
R <- [1; 16; 32; 64; 128];                    # Milstein stepsizes are R*dt

dW <- sqrt(dt)* runif(1, M, N);
Xmil <- double(M, 5);
for p = 1:5
    Dt = R[p]*dt;
    L = N/R[p];
    Xtemp = Xzero*rep(M,1);
    for j = 1:L
        Winc = sum(dW(:, R[p]*(j-1)+1:R[p]*j),2);
        Xtemp = Xzero + Dt*r*Xtemp.*(K-Xtemp) + beta*Xtemp.*Winc + .5*beta^2*Xtemp.*(Winc.^2 - Dt);
    end
    Xmil(:,p) <- Xtemp; #store MIlstein solution at t=1
end

Xref = Xmil(:,1);                            # Reference solution
Xerr = abs(Xmil(:,2:5) - repmat (Xref,1,4)); # Error in each path
mean(Xerr);                                  # Mean pathwise errors
Dtvals = dt*R(2:5);                          # Milstein timesteps used

subplot(224)
plot(Dtvals, mean(Xerr), log = "xy", type = "l");
lines(Dtvals, Dtvals, log = "xy");
axis([1e-3 1e-1 1e-4 1])
xlabel('\Delta t')
ylabel('Sample average of | X(T) - X_L|')
main('milstein', 'FontSize', 10)


#' Area under the curve (AUC)
#'
#' @description Calculates AUC
#'
#' @param x numeric vector
#' @param y numeric vector
#' @param limits numeric range for integration (default = x range)
#'
#' @return auc
#' @export
#'
#' @examples
#'
#' x <- seq(-3,3,l = 100)
#'
#' y <- dnorm(x)
#'
#' plot(x,y)
#'
#' auc(x,y)
#'

auc  <- function(x,y, limits = NULL) {

  if(is.numeric(x) == F){
    stop("x must be numeric")
  }

  if(is.numeric(y) == F){
    stop("y must be numeric")
  }

  if((is.numeric(limits) == F) & (is.null(limits) == F)){
    stop("limits must be numeric or NULL")
  }

  if((length(limits) != 0) & (length(limits) != 2)){
    stop("limits must be of length 2 or NULL")
  }

  tryCatch(
    {
      if(is.null(limits) == T){
        r <- range(x)
      }else{
        r <- limits
      }
      integrate(approxfun(x,y), r[1], r[2])$value
    },
    error = function(e) return(NA_real_)
  )

}


#Suppose a coin toss turns up 12 heads out of 20 trials.
#At .05 significance level, can one reject the null hypothesis
#that the coin toss is fair?

pbar = 12/20
p0 = 0.5

n = 20

z = (pbar-p0) / sqrt(p0*(1-p0)/n)

z # 0.89

alpha = .05

z.half.alpha = qnorm(1-alpha/2)

#aceptamos
c(-z.half.alpha,z.half.alpha)

pval = 2* pnorm(z,lower.tail = FALSE)
pval

prop.test(12,20,p=0.5,correct = FALSE)

Parcial/1. Prueba de hipotesis/TwoTailedProportion.r


# linear regression to get estimate forage fill value in ration depending on energy::fillvalue
# UFL:FV (FV either in UEL or ULB) ration.
# Based on feed tables in
# Agabriel, J. (2010). Alimentation des bovins, ovins et caprins. Besoins des animaux - Valeurs
# des aliments. Tables INRA 2010. Editions Quae, France.

M <- as.matrix(read.csv("FV_f.csv", header = TRUE, sep = ";", dec = "."))
UEL <- as.numeric(M[,"UEL"])
UEB <- as.numeric(M[,"UEB"])
UFL_UEL <- as.numeric(M[,"UFL_UEL"])
UFL_UEB <- as.numeric(M[,"UFL_UEB"])

cor(UFL_UEL, UEL)
fit <- lm(UEL ~ UFL_UEL)
#pdf("UEL_f.pdf")
png("UEL_f.png", width = 500, height = 500, units = "px")
plot(UFL_UEL, UEL)
abline(fit)
s <- summary(fit)
lm_coef <- round(coef(fit), 3)
mtext(bquote(UEL == .(lm_coef[2])*UFL/UEL + .(lm_coef[1])), adj=1, padj=0)
mtext(bquote(r^2 == .(round(s$r.squared, 3))), adj=0, padj=0)
mtext(bquote(n == .(nrow(M))), adj=0.15, padj=0)
print(s)
dev.off()

cor(UFL_UEB, UEB)
fit <- lm(UEB ~ UFL_UEB)
#pdf("UEB_f.pdf")
png("UEB_f.png", width = 500, height = 500, units = "px")
plot(UFL_UEB, UEB)
abline(fit)
s <- summary(fit)
lm_coef <- round(coef(fit), 3)
mtext(bquote(UEB == .(lm_coef[2])*UFL/UEB + .(lm_coef[1])), adj=1, padj=0)
mtext(bquote(r^2 == .(round(s$r.squared, 3))), adj=0, padj=0)
mtext(bquote(n == .(nrow(M))), adj=0.15, padj=0)
print(s)
dev.off()


#!/usr/bin/Rscript

require(deSolve)

## ==============================================================================
## Example: Numerical solution of the susceptible (X), infected (Y) resistant (Z)
## epidemiological model
## ==============================================================================

parameters <- c(beta  = 0.01,
                gamma = 0.01,
                m = 0.1)

state <- c(X = 100, Y = 1, Z = 0)

## the ODE system

lorenz <- function(t, state, parameters) {
    with(as.list(c(state, parameters)),{

# rate of change

        dX <- -beta*X*Y + gamma*Z
        dY <- beta * X * Y - m*Y
        dZ <- m*Y - gamma * Z

# return the rate of change

        list(c(dX, dY, dZ))

    })

}

times <- seq(0, 100, by = 0.01)

out <- ode(y = state, times = times, func = lorenz, parms = parameters)

head(out)

par(oma = c(0, 0, 3, 0))
plot(out, xlab = "time", ylab = "-")
plot(out[, "X"], out[, "Z"], pch = ".")
mtext(outer = TRUE, side = 3, "SIR Model", cex = 1.5)


##PROJET: Manipulation de polynomes

#1) Quelle serait la représentation creuse sous forme de liste du polynome 2+x^4−3x^5 ? list(c(2, 0), c(1, 4), c(-3, 5))
#2) Et sa représentation dense ? c(2, 0, 0, 0, 1, -3)
#3) Quand choisit-on de travailler plutot en représentation creuse ? Quand on souhaite travailler avec les degrés
#4) Quelle est la représentation la plus économique en terme d’espace mémoire ? Representation dense

# SOURCES :
# http://www.i3s.unice.fr/~malapert/R/pdf/A4-Polynomes.pdf
# https://www.youtube.com/watch?v=Z393AcN_Gz0 (Horner methode comprehension)

# Pour executer le programme faire Rscript ./polynomes.r
# Ou l'executer dans Rstudio.
# Va executer toutes les demonstrations de l'activite.

# Vous devez avoir installer le package 'polynom' sinon il y aura une erreur.

# Pour utiliser les fonctions une a une
# (cf. Activite_manipulation_des_polynomes.pdf)
# qui est une documentation du code.
p <- list(c(2,5), c(-1,4),c(-2,1))
q <- list(c(1,4), c(7,2),c(-1,0))

# indique si le polynome est nul
is_poly0 <- function(p) length(p) == 0

# renvoyant le degre d’un monome ou d’un polynome.
degre <- function(mp) {
    if(is_poly0(mp)) return(-Inf)
    if (is.list(mp)) mp <- mp[[1]]
    if (is.vector(mp) && length(mp) == 2) return(mp[2])
    else return(NULL)
}

# renvoyant le coefficient d’un monome ou d’un polynome.
coeff <- function(mp) {
    if(is_poly0(mp)) return(-Inf)
    if (is.list(mp)) mp <- mp[[1]]
    if (is.vector(mp) && length(mp) == 2) return(mp[1])
    else return(NULL)
}

# renvoyant une chaîne de caractères représentant le polynome creux sous la forme ∑aiX^i
poly2str <- function(p){
    if(length(p) == 0){
        return ("")
    }
    acc = ""
    for(e in p){
        acc = paste(acc, e[1], "*X^", e[2], " + ", sep="")
    }
    return(substr(acc, 0, nchar(acc) - 3))
}

# multiplication par un scalaire k d’un polynome
mult_ext <- function(p, k) {
    return(lapply(p, function(x) c(k*x[1], x[2])))
}

# transforme un polynome plein en un polynome creux
make_poly <- function(x) {
    poly_creux <- list()
    power <- length(x) - 1
    j <- 1
    for (i in length(x):1) {
        if (x[i] != 0) {
            poly_creux[[j]] <- c(x[i], power)
            j <- j + 1
        }
        power <- power - 1
    }
    return(poly_creux)
}

# générant un polynome aléatoire de degré inférieur à n
# et dont les coefficients sont tirés dans le vecteur coeffs
rand_poly <- function(n, coeffs) {
    poly <- list()
    len_poly <- sample(1:n-1, 1)
    j <- 1
    for (i in len_poly:1) {
        rand_coeff <- sample(coeffs, 1)
        if (rand_coeff != 0) {
            poly[[j]] <- c(rand_coeff, i)
            j <- j + 1
        }
    }
    if (length(poly) == 0) return(rand_poly(n, coeffs))
    return(poly)
}

# trie une liste de monomes par degré décroissant
sort_monoms <- function(p) {
    for (i in 1:length(p)) {
        for (j in i:length(p)) {
            if (p[[i]][2] < p[[j]][2]) {
                x <- p[[i]]
                p[[i]] <- p[[j]]
                p[[j]] <- x
            }
        }
    }
    return(p)
}

# somme les termes de même degré, et supprime les termes dont le coefficient est nulle
merge_monoms <- function(p) {
    monoms <- list(p[[1]])
    l_p <- length(p)
    i <- 2
    j <- 1
    # Additionne les monoms entre eux
    while (i <= l_p) {
        if (monoms[[j]][2] == p[[i]][2] && i != j) {
            monoms[[j]] <- c(monoms[[j]][1] + p[[i]][1], p[[i]][2])
        } else {
            j <- j + 1
            monoms[[j]] <- p[[i]]
        }
        i <- i + 1
    }
    k <- 1
    # Enlève les monoms de coeff nulle
    while (k <= length(monoms)) {
        if (monoms[[k]][1] == 0) {
            monoms[[k]] <- NULL
            next
        }
        k <- k + 1
    }
    return(monoms)
}

# Addition de deux polynomes
add <- function(p, q) {
    combine <- c(p, q) # combine 2 listes
    return(merge_monoms(sort_monoms(combine)))
}

# Soustraction de 2 polynomes
sub <- function(p,q) add(p,mult_ext(q,-1))

# polynome dérivé du polynome p
deriv <- function(p) {
    drv <- list()
    for (i in p) {
        if (i[[2]] == 1) {
            drv <- c(drv, list(c(i[[1]], 0)))
        }
        else if (i[[2]] == 0) {
            i <- NULL
        }
        else {
            drv <- c(drv, list(c(i[[2]] * i[[1]], i[[2]] - 1)))
        }
    }
    return(drv)
}

# primitive du polynome p
integ <- function(p) {
    integ <- list()
    for (c in p) {
        integ <- c(integ, list(c(c[[1]] / (c[[2]] + 1), c[[2]] + 1)))
    }
    return(integ)
}

# Multiplication de 2 monomes
mult_monoms <- function(m1, m2) {
    return(list(c(m1[1] * m2[1], m1[2] + m2[2])))
}

# Multiplication d'un polynome par un monome
mult_poly_mono <- function(p, m) {
    return(lapply(p, function(x) c(m[1]*x[1], m[2] + x[2])))
}

# Multiplication interne de deux polynomes
mult <- function(p, q) {
    res <- list()
    # S'appuyant sur la methode vu dans le cours de l'activite
    for (monom in q) {
        res <- add(res, mult_poly_mono(p, monom))
    }
    return(res)
}

# Valeur d'un polynome en un point x version naive
polyval <- function(p, x) {
    res <- c()
    for (monom in p) {
        res <- c(res, c(monom[1] * x ** monom[2]))
    }
    return(sum(res))
}

# Fonction personnel pour faire polyhorn
# qui convertir un polynome creux a dense
creux_to_dense <- function(p) {
    degre <- degre(p)
    res <- c()
    old <- p[[1]][2]
    i <- 1
    j <- 1
    while (i <= length(p)) {
        if (old - p[[j]][2] >= 2) {
            res <- c(res, 0)
            old <- old - 1
            next
        }
        else {
            res <- c(res, p[[j]][1])
            j <- j + 1
        }
        old <- p[[i]][2]
        i <- i + 1
    }
    adjust <- degre - length(res) + 1
    if (adjust > 0) res <- c(res, numeric(adjust))
    return(rev(res))
}

# Valeur d'un polynome en un point x version Horner
polyhorn <- function(p, x) {
    # Verification que le polynome p est un polynome creux, si oui conversion en dense
    if (is.list(p)) p <- creux_to_dense(p)
    len_p <- length(p)
    res <- p[[len_p]][1]
    for (i in (len_p-1):1) {
        res <- (res * x) + p[[i]][1]
    }
    return(res)
}

# construit la fonction polynome associee a p
fpoly <- function(p) {
    return( function(x) {polyval(p, x)}) # on peut faire pareil avec polyhorn
}

# dessine les courbes de la primitive, derivee et du polynome
dessiner <- function(p, x) {
    cols <- c("green", "red", "blue")
    finteg <- fpoly(integ(p))
    fderiv <- fpoly(deriv(p))
    fpoly_p <- fpoly(p)

    integ <- sapply(x, finteg)
    derivate <- sapply(x, fderiv)
    poly_p <- sapply(x, fpoly_p)
    matplot(x, cbind(integ, derivate, poly_p), t="l", lwd=1.5, lty=1, xlab="x", ylab="y", col=cols)
    legend("topleft", inset=.05, legend=c("Primitive", "Derivee", "Polynome"), horiz=FALSE, lwd=2, lty=1, col=cols)
}

# tout les cas de test de l'activite polynome
# sont effectue dans cette fonction
demonstration <- function() {
    stopifnot("2*X^5 + -1*X^4 + -2*X^1" == poly2str(p))
    stopifnot(poly2str(mult_ext(p,-2)) == "-4*X^5 + 2*X^4 + 4*X^1")
    stopifnot(poly2str(make_poly(c(0, -2, 0, 0, -1, 2))) == "2*X^5 + -1*X^4 + -2*X^1")
    stopifnot(poly2str(make_poly(c(-1, 0, -7, 0, 1))) == "1*X^4 + -7*X^2 + -1*X^0")
    stopifnot(poly2str(add(p, list())) == "2*X^5 + -1*X^4 + -2*X^1")
    stopifnot(poly2str(add(list(), q)) == "1*X^4 + 7*X^2 + -1*X^0")
    stopifnot(poly2str(add(p,q)) == "2*X^5 + 7*X^2 + -2*X^1 + -1*X^0")
    stopifnot(poly2str(sub(p,p)) == "")
    stopifnot(poly2str(sub(p,q)) == "2*X^5 + -2*X^4 + -7*X^2 + -2*X^1 + 1*X^0")
    stopifnot(poly2str(sub(q,p)) == "-2*X^5 + 2*X^4 + 7*X^2 + 2*X^1 + -1*X^0")
    stopifnot(poly2str(integ(p)) == "0.333333333333333*X^6 + -0.2*X^5 + -1*X^2")
    stopifnot(poly2str(integ(q)) == "0.2*X^5 + 2.33333333333333*X^3 + -1*X^1")
    stopifnot(poly2str(deriv(p)) == "10*X^4 + -4*X^3 + -2*X^0")
    stopifnot(poly2str(deriv(q)) == "4*X^3 + 14*X^1")
    p1 <- make_poly(c(1,1))
    p2 <- make_poly(c(-1,1))
    p3 <- make_poly(c(1,-1,1))
    stopifnot(poly2str(mult(p1,p2)) == "1*X^2 + -1*X^0")
    stopifnot(poly2str(mult(p3,p3)) == "1*X^4 + -2*X^3 + 3*X^2 + -2*X^1 + 1*X^0")
    cat('---TEST CASES DE L\'ACTIVITE POLYNOME---\n')
    cat('TEST CASE : poly2str(p) == "2*X^5 + -1*X^4 + -2*X^1" TRUE\n')
    cat('TEST CASE : poly2str(mult_ext(p,-2)) == "-4*X^5 + 2*X^4 + 4*X^1" TRUE\n')
    cat('TEST CASE : poly2str(make_poly(c(0, -2, 0, 0, -1, 2))) == "2*X^5 + -1*X^4 + -2*X^1" TRUE\n')
    cat('TEST CASE : poly2str(make_poly(c(-1, 0, -7, 0, 1))) == "1*X^4 + -7*X^2 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(rand_poly(5,0:3)) = ', poly2str(rand_poly(5,0:3)), '\n')
    cat('TEST CASE : poly2str(rand_poly(10,0:1)) = ', poly2str(rand_poly(10,0:1)), '\n')
    cat('TEST CASE : poly2str(add(p, list())) == "2*X^5 + -1*X^4 + -2*X^1" TRUE\n')
    cat('TEST CASE : poly2str(add(list(), q)) == "1*X^4 + 7*X^2 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(add(p,q)) == "2*X^5 + 7*X^2 + -2*X^1 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(sub(p,p)) == "" TRUE\n')
    cat('TEST CASE : poly2str(sub(p,q)) == "2*X^5 + -2*X^4 + -7*X^2 + -2*X^1 + 1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(sub(q,p)) == "-2*X^5 + 2*X^4 + 7*X^2 + 2*X^1 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(integ(p)) == "0.333333333333333*X^6 + -0.2*X^5 + -1*X^2" TRUE\n')
    cat('TEST CASE : poly2str(integ(q)) == "0.2*X^5 + 2.33333333333333*X^3 + -1*X^1" TRUE\n')
    cat('TEST CASE : poly2str(deriv(p)) == "10*X^4 + -4*X^3 + -2*X^0" TRUE\n')
    cat('TEST CASE : poly2str(deriv(q)) == "4*X^3 + 14*X^1" TRUE\n')
    cat('TEST CASE : poly2str(mult(p1,p2)) == "1*X^2 + -1*X^0" TRUE\n')
    cat('TEST CASE : poly2str(mult(p3,p3)) == "1*X^4 + -2*X^3 + 3*X^2 + -2*X^1 + 1*X^0" TRUE\n')
    cat('---TEST POLYNOMES P EN UN POINT X---\n')
    cat('UTILISATION DE POLYVAL\n')
    print(poly2str(p))
    for(i in -1:1) {
        print(paste("p(",i,") = ",polyval(p,i), sep=""))
    }
    print(poly2str(q))
    for(i in -1:1) {
        print(paste("q(",i,") = ",polyval(q,i), sep=""))
    }
    cat('UTALISATION DE POLYHORN\n')
    print(poly2str(p))
    for(i in -1:1) {
        print(paste("p(",i,") = ",polyhorn(p,i), sep=""))
    }
    print(poly2str(q))
    for(i in -1:1) {
        print(paste("q(",i,") = ",polyhorn(q,i), sep=""))
    }
    cat('dessiner(p, x) -> (voir plot)\n')
    x <- seq(-2,4,length.out=1000)
    p1 <- make_poly(c(-1,-1,1))
    dessiner(p1,x)
}

demonstration()

### N'AFFICHE PAS COMME DANS L'EXEMPLE DE L'ACTIVITE MAIS A LES MEMES RESULTAT
### EN COMPARANT vh, vn et vr ci-dessous (sachant que polyhorn et polyval fonctionnent bien avec de multiple tests)
x <- seq(2-0.02,2.02,length.out=1001)
vec <- c(-2,0,1)
## p(x) = (x^2-2)^16
p1 <- make_poly(vec)
for(i in 1:4) {
  p1 <- mult(p1,p1)
}
## Evaluate p using our methods (observed)
vn <- sapply(x, polyval, p=p1)
vh <- sapply(x, polyhorn, p=p1)

library("polynom")
## Evaluate p using R package (expected)
pr <-as.polynomial(c(-2,0,1))
## p is an R object ! I directly used the power operator.
pr <- pr ** 16
## I also use a generic function
vr <- predict(pr,x)

## Last, visualize the results
cols <- c("red", "gold")
matplot(x, cbind(vn-vr,vh-vr),t="l", lwd=2, lty=1,col=cols, xlab="x",ylab="P(x)-P^R(x)")
legend("topleft", inset=.05, legend=c("Naive", "Horner"), horiz=TRUE, lwd=2, lty=1, col=cols)


true.lambda <- 2.4
true.mu <- .000000005
N0 <- 2
y0 <- statmod::rinvgauss(N0, mean = true.mu, shape = true.lambda)

a_0 <- .9

log(prod(statmod::dinvgauss(y0, mean = true.mu, shape = true.lambda)^a_0) )
a_0* sum(statmod::dinvgauss(y0, mean = true.mu, shape = true.lambda, log = TRUE))
sum(a_0 * statmod::dinvgauss(y0, mean = true.mu, shape = true.lambda, log = TRUE))

logP <- sum(log(y0))
S <- sum(y0)
Sprime <- sum(1/y0)

a_0 * N0 * .5 * ( log(true.lambda) - log(2*pi) ) -3/2 * a_0 * logP  + (a_0*N0*true.lambda)/true.mu -(a_0*S*true.lambda)/(2*true.mu^2)-(a_0*Sprime*true.lambda)/2
a_0 * N0 * .5 * ( log(true.lambda) - log(2*pi) ) -3/2 * a_0 * logP  + true.lambda * ( (a_0*N0)/true.mu -(a_0*S)/(2*true.mu^2)-(a_0*Sprime)/2   )
a_0 * N0 * .5 * ( log(true.lambda) - log(2*pi) ) -3/2 * a_0 * logP  - ( -(a_0*N0)/true.mu +(a_0*S)/(2*true.mu^2) + (a_0*Sprime)/2 ) * true.lambda

-(a_0*N0)/true.mu +(a_0*S)/(2*true.mu^2) + (a_0*Sprime)/2


blockMiss = function(n){
  # n = length of song

  nsections = sqrt(n)	# quick way to determine number of sections in the song

  mix = c(0.3,0.4,0.2,0.1)	# mixture probabilities of difficulty of a section: Easy, Medium ,Hard, Very Hard
  missprop = c(0.01,0.05,0.25,0.5)	# Probability of missing a note for each of the four types of sections

  sectiontype = sample(1:4,nsections,mix,replace=T)	# randomly assign a difficulty to each section with probability from the mix vector

  sectionsize = rmultinom(1,n,rep(1,nsections))[,1]	# randomly allocate section sizes for song using multinomial distribution

  song = numeric(n)

  notes = 0
  for(i in 1:nsections){
    song[(notes+1):(notes + sectionsize[i])] = rbinom(sectionsize[i],1,missprop[sectiontype[i]])
    notes = notes + sectionsize[i]
  }

  return(song)

}

x = matrix(0,200,100)

for(j in 1:100){
	x[,j] = blockMiss(200)
}

write(t(x),"p.varies_block_n200_r100.txt",ncol=200)  # each row in this file is a different simulated song

y = matrix(0,600,100)
for(j in 1:100){
	y[,j] = blockMiss(600)
}

write(t(y),"p.varies_block_n600_r100.txt",ncol=600)  # each row in this file is a different simulated song


# The probability of observing y successes in n trials of a binomial experiment
# number of trials
n<-20
#  let probability of success on a single trial be z
z<-0.85
# probability that 18 or more of the 20 seeds will germinate?
y<-18
probability_for18seeds<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
y<-19
probability_for19seeds<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
y<-20
probability_for20seeds<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
total_probability<-probability_for18seeds+probability_for19seeds+probability_for20seeds
print(total_probability)


#' @name GLMGA
#' @rdname  GLMGA
#' @title The GLMGA distribution
#'
#' @param y vector of quantiles.
#' @param u vector of probabilities.
#' @param sigma parameter of GLMGA distribution.
#' @param a parameter of GLMGA distribution.
#' @param b parameter of GLMGA distribution.
#' @param log logical; if TRUE, probabilities/densities p are returned as log(p).
#' @param n number of observations. If length(n) > 1, the length is taken to be the number required.
#' @importFrom stats runif
#' @importFrom stats pbeta
#' @description Density (\code{dGLMGA}), distribution function (\code{pGLMGA}), quantile function (\code{qGLMGA}) and random generation (\code{rGLMGA}) for the GLMGA distribution with parameters sigma, a and b.
#' @references Zhengxiao Li, Jan Beirlant, Shengwang Meng. Generalizing The Log-Moyal Distribution And Regression Models For Heavy-Tailed Loss Data. ASTIN Bulletin: The Journal of the IAA, 11(1):57-99, 2021.
#' @details
#' The GLMGA distribution with parameters (sigma, a, b) has density
#' \deqn{f(y)=\frac{(2b)^a}{\sigma B(a,\frac{1}{2})}\frac{y^{-(\frac{1}{2\sigma}+1)}}{(y^{-\frac{1}{\sigma}}+2b)^{a + \frac{1}{2}}},}
#' for \eqn{y>0,\sigma>0, a>0, b>0}.
#'
#' The cumulative distribution function \eqn{F(y)} is
#'
#' \deqn{F(y)=1-I_{\frac{1}{2},a}(\frac{y^{-1/\sigma}}{y^{-1/\sigma}+2b}).}
#'
#' Here \eqn{I_{m,n}()} is the beta cumulative distribution function (or regularized incomplete beta function) with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{pbeta}} and defined in its help.
#'
#' The quantile function \eqn{F^{-1}(u)} is
#'
#' \deqn{(2b)^{-\sigma}[\frac{I^{-1}_{\frac{1}{2},a}(1-p)}{1-I^{-1}_{\frac{1}{2},a}(1-p)}]^{-\sigma},}
#' where \eqn{u \in (0,1)}, and \eqn{I_{m,n}^{-1}()} denotes the inverse of the beta cumulative distribution function (or regularized incomplete beta function)
#' with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{qbeta}}.
#'
#'
#'
#' @return
#' \code{dGLMGA} gives the density, \code{pGLMGA} gives the distribution function, \code{qGLMGA} gives the quantile function, and \code{rGLMGA} generates random deviates.
#'
#' Invalid arguments will result in return value NaN, with a warning.
#'
#' The length of the result is determined by n for rgamma, and is the maximum of the lengths of the numerical arguments for the other functions.
#'
#' The numerical arguments other than n are recycled to the length of the result. Only the first elements of the logical arguments are used.
#'
#'
NULL

#' @rdname  GLMGA
#' @export
#' @examples
#' # density function at value 0.5 and 0.1
#' dGLMGA(c(0.5, 0.1), sigma = 2, a = 2, b = 3, log = FALSE)
dGLMGA <- function(y, sigma, a, b, log = FALSE) {
  if (log == FALSE) {
    exp(-0.5 * log(2 * pi) - log(sigma) + a * log(b) + lgamma(a + 0.5) - lgamma(a) - (1 / (2 * sigma) + 1) * log(y) - (a + 0.5) * log(0.5 * (1 / y)^(1 / sigma) + b))
  } else if (log == TRUE) {
    -0.5 * log(2 * pi) - log(sigma) + a * log(b) + lgamma(a + 0.5) - lgamma(a) - (1 / (2 * sigma) + 1) * log(y) - (a + 0.5) * log(0.5 * (1 / y)^(1 / sigma) + b)
  }
}

#' @rdname GLMGA
#' @export
#'
#' @examples
#' # cdf at value 10 and 20.
#' pGLMGA(c(10, 20), sigma = 2, a = 2, b = 3)
pGLMGA <- function(y, sigma, a, b) {
  z <- y^(-1 / sigma) / (y^(-1 / sigma) + 2 * b)
  p <- 1 - pbeta(z, shape1 = 0.5, shape2 = a)
  p
}

#' @rdname GLMGA
#' @export
#'
#' @examples
#' # quantile function at level 50% and 10%
#' qGLMGA(c(0.5, 0.1), sigma = 2, a = 2, b = 3)
qGLMGA <- function(u, sigma, a, b) {
  c <- (2 * b)^(-sigma)
  # I <- pbeta(u, shape1 = 0.5, shape2 = a)
  Iinv <- qbeta(1 - u, shape1 = 0.5, shape2 = a)
  c * (Iinv / (1 - Iinv))^(-sigma)
}

#' @rdname GLMGA
#' @export
#' @examples
#' # simulate 10 samples from GLMGA distribution with parameters (2, 2, 3)
#' rGLMGA(n = 10, sigma = 2, a = 2, b = 3)
rGLMGA <- function(n, sigma, a, b) {
  u <- runif(n, min = 0, max = 1)
  qGLMGA <- Vectorize(qGLMGA)
  r <- qGLMGA(u, sigma = sigma, a = a, b = b)
  r
}

#' #' Sum of vector elements
#' #'
#' #' \code{sum} returns the sum of all the values present in its arguments.
#' #'
#' #' This is a generic function: methods can be defined for it directly
#' #' or via the \code{\link{Summary}} group generic. For this to work properly,
#' #' the arguments \code{...} should be unnamed, and dispatch is on the
#' #' first argument.
#' #'
#' #' @param ... Numeric, complex, or logical vectors.
#' #' @param na.rm A logical scalar. Should missing values (including NaN)
#' #'   be removed?
#' #' @return If all inputs are integer and logical, then the output
#' #'   will be an integer. If integer overflow
#' #'   \url{https://en.wikipedia.org/wiki/Integer_overflow} occurs, the output
#' #'   will be NA with a warning. Otherwise it will be a length-one numeric or
#' #'   complex vector.
#' #'
#' #'   Zero-length vectors have sum 0 by definition. See
#' #'   \url{https://en.wikipedia.org/wiki/Empty_sum} for more details.
#' #' @examples
#' #' sum(1:10)
#' #' sum(1:5, 6:10)
#' #' sum(F, F, F, T, T)
#' #'
#' #' sum(.Machine$integer.max, 1L)
#' #' sum(.Machine$integer.max, 1)
#' #'
#' #' \dontrun{
#' #' sum("a")
#' #' }
#' sum <- function(..., na.rm = TRUE) {}


## Plotting Sierpinski carpet fractal v.2. aev 4/2/17
## ord - order, fn - file name, ttl - plot title, clr - color
pSierpinskiC2 <- function(ord, fn="", ttl="", clr="brown") {
  m=640; abbr="SCR2"; dftt="Sierpinski carpet fractal v.2";
  cat(" *** START", abbr, date(), "\n");
  if(fn=="") {pf=paste0(abbr,"o", ord)} else {pf=paste0(fn, ".png")};
  if(ttl!="") {dftt=ttl}; ttl=paste0(dftt,", order ", ord);
  cat(" *** Plot file:", pf,".png", "title:", ttl, "\n");
  S = matrix(1,1,1);
  for (i in 1:ord) {
    Q = cbind(S,S,S); R = cbind(S,0*S,S); S = rbind(Q,R,Q);
  }
  plotmat(S, pf, clr, ttl);
  cat(" *** END", abbr, date(), "\n");
}
## Executing:
pSierpinskiC2(5);


x <- c(-12, 1, 16)
y <- c(-19, -14, -9, 8)

prob.x <- c(0.35, 0.3, 0.35)

prob.y_x <- c(0.2, 0.33, 0.23, 0.17,
              0.25, 0.25, 0.22, 0.28,
              0.23, 0.25, 0.23, 0.29)

parametro_a <- -0.41
parametro_b <- 0.56
parametro_c <- 0.15
parametro_d <- 0.35

mat.y_x <- matrix(data = prob.y_x, ncol = length(y), nrow = length(x), byrow = TRUE);

prob.xy <- c()

for( i in 1:length(x) ){

  for( j in 1:length(y) ){

    prob.xy <- c(prob.xy, mat.y_x[i,j] * prob.x[i]);

  }

}

mat.xy <- matrix(data = prob.xy, ncol = length(y), nrow = length(x), byrow = TRUE);

prob.y <- c(sum(mat.xy[1:3,1]),sum(mat.xy[1:3,2]),sum(mat.xy[1:3,3]),sum(mat.xy[1:3,4]))

e.x <- sum(x*prob.x)
e.y <- sum(y*prob.y)

e.xy <- c()
for(i in 1:length(x)) {
  for(j in 1:length(y)) {
    e.xy <- c(e.xy, mat.xy[i,j]*x[i]*y[j])
  }
}
e.xy <- sum(e.xy)
cov <- e.xy - e.x*e.y

cov2 <- cov*parametro_a*parametro_c

var.x <- sum(x^2*prob.x)-e.x^2
var.y <- sum(y^2*prob.y)-e.y^2

ro <- cov/sqrt(var.x*var.y)

sgn.ac <- parametro_a*parametro_c/abs(parametro_a*parametro_c)

cat("X\n")
print(x)
print(prob.x)
cat("\nY\n")
print(y)
print(prob.y)
cat("\nCongiunta\n")
print(mat.xy)
cat("\nE(XY)\n")
print(e.xy)
cat("\nE(X)\n")
print(e.x)
cat("\nE(Y)\n")
print(e.y)
cat("\nCovarianza\n")
print(cov)
cat("\nCovarianza della combinazione lineare\n")
print(cov2)
cat("\nVar(X)\n")
print(var.x)
cat("\nVar(Y)\n")
print(var.y)
cat("\nRo\n")
print(ro)
cat("\nRo della comb. lineare\n")
print(sgn.ac*ro)


=begin
  # sample-factorize01.rb

  require "algebra"

  P = Polynomial(Integer, "x")
  x = P.var
  f = 8*x**7 - 20*x**6 + 6*x**5 - 11*x**4 + 44*x**3 - 9*x**2 - 27
  p f.factorize #=> (2x - 3)^3(x^2 + x + 1)^2
((<_|CONTENTS>))
=end


library(stats)

create_model <- function(input,resp,name) {
    fit <- nls(resp~exp(a+b*input),start = list(a=log(20),b=-0.001))
    B <- coef(fit)
    n <- length(input)
    d <- 2

    pred <- function(x) {
        #Generate predictions
        return(exp(B["a"]+B["b"]*x))
    }
    sig.est = sqrt(sum((resp-pred(input))^2)/(n-d))

    #Linearize model for confidence and prediction
    #f(x|B) ~ f(x|B_hat) + gradient(f(x|B_hat)*(B - B_hat)
    #y~f(x|B)+e  <=> g = gradient()(a,b)
    #                z = y - g + g*B
    mdiv <- deriv(y~exp(a+b*x),c("a","b"),function(a,b,x){})
    G <- mdiv(a=B["a"],b=B["b"],input)
    G <- attr(G,"gradient")
    z <- resp - pred(input) + G%*%B

    #Find linear standard error
    var.lin <- ((sig.est^2)*solve(t(G)%*%G))
    se.lin <- sqrt(diag(var.lin))

    #Model parameters of lineraized version can be treated
    #linearly

    #Confidence of parameters
    level <- 0.95
    alpha <- 1-level
    B.ci <- cbind(B + qt(alpha/2,n-d)*se.lin, B + qt(1-alpha/2,n-d)*se.lin)
    row.names(B.ci) <- names(B)
    colnames(B.ci) <- c(paste0((1-level)/2*100,"%"),paste0((1+level)/2 * 100,"%"))

    #Confidence
    input.new <- seq(0,100,1)
    pred.input.new <- pred(input.new)
    grad2 <- mdiv(a=B["a"],b=B["b"],input.new)
    G2 <- attr(grad2,"gradient")
    GS <- rowSums((G2%*%vcov(fit))*G2)
    delta <- sqrt(GS)*qt(1-alpha/2, n-d)
    df.delta <- data.frame(odometer=input.new,price = pred.input.new,
                            lwr.conf = pred.input.new-delta,upr.conf = pred.input.new+delta)

    #Prediction
    sig2.est <- summary(fit)$sigma
    pred.delta <- sqrt(GS + sig2.est^2)*qt(1-alpha/2,n-d)
    df.delta[c("lwr.pred","upr.pred")] <- cbind(pred.input.new - pred.delta,
                                                 pred.input.new + pred.delta)
    input.df <- data.frame(odometer=input,price=resp)

    #Create plot
    p = ggplot(data = df.delta,aes(x=odometer,y=price))+geom_point(data=input.df)+
                geom_line(size = 1.5,col="green")+
                geom_ribbon(aes(ymin = lwr.conf,ymax = upr.conf,color="95% Confidence"),alpha = 0.2,fill = "green")+
                geom_ribbon(aes(ymin = lwr.pred,ymax = upr.pred,color="95% Prediction"),alpha = 0.2,fill = "blue") +
                scale_colour_manual(name="",values=c("95% Confidence"="green","95% Prediction"="blue"))+
                labs(title = paste(name, "prediction plot"))

    return(list(fit = fit,B.conf = B.ci, pred = df.delta,df = input.df,plot = p))
}


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

## Check residual plots for patterns
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.ibm <- residuals(model.ibm)
plot(model.ibm$fitted, res.ibm)  # plot residuals vs fitted values
plot(bigdataset$date, res.ibm)  # plot residuals versus date

## Test for Autocorrelations
library{lmtest}
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.ibm <- residuals(model.ibm)
dwtest(res.ibm ~ 1)

## Test for Cross-Correlations
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.ibm <- residuals(model.ibm)
model.aapl <- lm(logret.aapl ~ logret.factor1, data=bigdataset)
res.aapl <- residuals(model.aapl)
# Compute Pearson and Fisher tests
cor.test(res.ibm, res.aapl, method="pearson")

## Check for Influential Points
model.ibm <- lm(logret.ibm ~ logret.factor1, data=bigdataset)
res.student.ibm <- rstudent(model.ibm)
plot(res.student.ibm)

cooks.distances.ibm <- cooks.distance(model.ibm)
plot(cooks.distances.ibm)

# Compute Pena's sensitivities
p <- length(coef(model.ibm))
Q <- qr.Q(model.ibm$qr)  # the Q of the QR decomposition
H <- Q %*% t(Q)  # the hat matrix
h <- diag(H)
S <- H^2 %*% rstudent(model.ibm)^2/(p*h*(1-h))

## Check for Multicollinearity
cor.coeff <- cov2cor(vcov(model.ibm))
cor.coeff                     # coefficient correlation matrix
eigen(cor.coeff)              # compute eigenvectors, eigenvalues
det(cor.coeff)                # determinant
kappa(cor.coeff, exact=TRUE)  # condition number


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

# calculate moments to pass to Edgeworth expansion
mean.obs <- mean(x.obs)
var.obs <- var(x.obs)
skew.obs <- skewness(x.obs, method="moment")*n.obs/(n.obs-2)
exkurt.obs <- kurtosis(x.obs, method="moment")*n.obs/(n.obs-3)-3

# create the Edgeworth expansion. Since we have moments, we
# do this for a "sum" with 1 term.
edge.expand <- edgeworth(x, 1, rho3=skew.obs, rho4=exkurt.obs,
                         mu=mean.obs, sigma2=var.obs, type="sum")

# without EQL, we would have to do this:
dedge <- function(x) {
    z <- (x-mean.obs)/sqrt(var.obs)
    dnorm(z)*(1 + skew.obs*(z^3-3*z)/6 + exkurt.obs*(z^4-6*z^2+3)/24
              + skew.obs^2*(z^6-15*z^4+45*z^2-15)/72)/sqrt(var.obs)
}


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 01

rm(list = ls())

observed <- c(6, 18, 32, 35, 17, 10, 2)

(k <- length(observed))
# 7

(n <- sum(observed))
# 120

LogLikelihood <- function(lamdba, y, k) {
  (sum(y[1:(k - 1)] * dpois(0:(k - 2), lambda = lamdba, log = TRUE)) +
    y[k] * ppois(k - 2, lambda = lamdba, log = TRUE, lower.tail = FALSE))
}

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

opt <- optim(1, NegativeLogLikelihood, lower = 10e-4, y = observed, k = k,
             method = "L-BFGS-B")

(lambda.hat <- opt$par)
# 2.65019719097978

(expected <- n * c(dpois(0:(k - 2), lambda = lambda.hat),
                   1 - ppois(k - 1, lambda = lambda.hat)))
# 8.47647391824289 22.4643273675407 29.7674486433533 26.2965362590832 ...

(Q <- sum((observed - expected) ^ 2 / expected))
# 4.76208557778011

(pvalue <- 1 - pchisq(Q, df = (k - 1) - 1))
# 0.445600066398024


print ("first task")

a <- c(-5, 1, 6, -3, 2, -2, 5, 2, 0, -6, 2, 1, 0, -2, -3, 1)
b <- c(3, -2, 6, -4, -7, 8, -1, 0, 9, -2, 8, 9, -2, 1, 0, -1)
p <- c ( -8, 4, -2, 8, 0, 3, -5, 3, 2, -3, -4, 5, 9, 1, -3, 0)
fir <- ((5)*a)-(6*b)
print ("first answer")
fir
sec <- ((5)*as.numeric(a%*%p))*b+3*(norm(p, type="2"))*b
print ("second answer")
sec
thr <- (-2)*(norm(p, type="2"))*p+5*as.numeric(a%*%p)*a+3*as.numeric(b%*%p)*b
print ("third answer")
thr

2 задание

print ("second task")
mat <- rbind(c(-4,3,0,-10,8,0,0,0),c(12,-5,0,-1,8,0,0,0),c(-1,6,0,2,8,0,0,0),c(7,0,12,0,0,1,0,-3),c(-7,0,0,0,0,-1,-4,3),c(0,0,0,-3,-8,0,1,-2),c(0,0,0,8,-1,0,-4,-2),c(0,0,0,-6,2,0,-9,1))
rua <- c(34,44,-6,-44,-4,-61,-13,50)
X <- solve(mat)%*%rua
print ("Answer for the sec task")
X
mat%*%X
rua

4 задание

print ("fourth task")
A <- rbind(c(19, 0, 0, 0, 0 ,0 ,0 ,20),c(0, 7 ,0 ,0 ,7 ,0 ,0 ,0),c(0, 0, 13, 0, 0, 0, 0, 0),c(0 ,0 ,0 ,11, 0, 0, 0, 0),c(0 ,7 ,0 ,0, 17, 0, 0 ,0),c(0, 0, 0, 0, 0 ,5, 0, 0),c(0, 0, 0, 0, 0, 0, 3 ,0),c(0, 0, 0, 0, 0, 0, 0, 1))
A
options(digits=3) # Задать количество значащих цифр для вывода
print ("собственные числа ")
d <- eigen(A)$values; d # Собственные значения матрицы A
print ("собственные вектора")
P <- eigen(A)$vectors; P # Собственные векторы A, стоящие в столбцах матрицы
P
print (" Проверим ортогональность полученного собственного базиса ")
sum(P[,1]^2) # Например, длина первого собственного вектора
P[,1] %*% P[,2] # Например, скалярное произведение (f1, f2)
sum(P[,2]^2); P[,2] %*% P[,3] # длина 2 собственного вектора и (f2, f3)
sum(P[,3]^2); P[,3] %*% P[,4] # длина 3 собственного вектора и (f3, f4)
sum(P[,4]^2); P[,4] %*% P[,5] # длина 4 собственного вектора и (f4, f5)
sum(P[,5]^2); P[,5] %*% P[,6] # длина 5 собственного вектора и (f5, f6)
sum(P[,6]^2); P[,6] %*% P[,7] # длина 6 собственного вектора и (f6, f7)
sum(P[,7]^2); P[,7] %*% P[,8] # длина 7 собственного вектора и (f7, f8)
sum(P[,8]^2); P[,8] %*% P[,1] # длина 8 собственного вектора и (f8, f1)
print ("Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.
Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.")

6 задание

print ("sixth task")
install.packages("lpSolveAPI") # Загружаем библиотеку
library(lpSolveAPI) # Активируем библиотеку линейного программирования
M <- make.lp(ncol= 2) # Объявляем количество неотрицательных переменных в M
name.lp(M, "Example") # Объявляем название "Example"для задачи(модели) М
colnames(M) <- c("X1", "X2") # Объявляем названия переменных в модели М
lp.control(M, sense = "min")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(-6, 2)) # Задаем целевую функцию: f = 5*X1 +3*X2 для модели М
add.constraint(M, c(5,7), ">=", 35) # Задаем ограничение:
add.constraint(M, c(-3, 9/2), ">=", -27/2) # Аналогично
add.constraint(M, c(1, -3), ">=", -12) # Аналогично
add.constraint(M, c(1, 0), "<=", 8) # Аналогично
rownames(M) <- c("A", "B", "C", "D") # Называем ограничения в модели М
M
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M)
X1.opt<- get.variables(M)[1]; X1.opt # Оптимальное значение для X1
X2.opt<- get.variables(M)[2]; X2.opt # Оптимальное значение для X2
f.max<- get.objective(M); f.max


.overall_f_statistics <- function(X, y){
    n <- dim(X)[1]
    k <- dim(X)[2]
    intercept <- matrix(rep(1, length(y)), ncol=1)
    intecept_only_residual.2 <- sum(residual(intercept, y)^2)
    regression_residual.2 <- sum(residual(X, y)^2)
    f_stat <- (n-k)/k * (intecept_only_residual.2 - regression_residual.2)/regression_residual.2
    return(f_stat)
}

#' @export
overall_significance_f_test <- function(X, y){
    n <- dim(X)[1]
    k <- dim(X)[2]
    f_stat <- .overall_f_statistics(X, y)

    return(TestResult(test_name = "Overall Significant F Test",
                      H0_description = "All coefficients (except intercept) equal 0: β1 = β2 = ... = βk = 0",
                      test_statistic = f_stat,
                      distribution = "f",
                      df1 = k,
                      df2 = n-k))
}


#Example : 2.3b    Chapter : 2.3   Pageno  : 61
#Multiplication with Elimination and Permutation matricies
Ab<-matrix(c(1,4,0,2,8,3,2,9,2,1,3,1),ncol=4)
E21<-matrix(c(1,0,0,-4,1,0,0,0,1),ncol=3,byrow=T)
P32<-matrix(c(1,0,0,0,0,1,0,1,0),ncol=3,byrow=T)
E21Ab<-E21%*%Ab
print(E21Ab)
P32E21Ab<-P32%*%E21Ab
print(P32E21Ab)
P32E21<-P32%*%E21
print(P32E21)
P32E21Ab<-P32E21%*%Ab
print(P32E21Ab)
#Solution for this system is
b<-P32E21Ab[,4]
P32E21Ab<-P32E21Ab[,-4]
x<-solve(P32E21Ab,b)
print(x)


#Data

x1 <- 4
x2 <- 9
x3 <- 10

expected <- 8.609
variance <- 3.869

#install.packages("pracma", repos="http://R-Forge.R-project.org")
library(pracma)

data <- c(x1,x2,x3)

momento <- function(x, y, r, centrato = FALSE) {
  res <- 0

  if(length(x) != length(y) || r < 0 || r %% 1 != 0 ) {
    res <- NaN
  }

  if(centrato == FALSE) {
    for(i in 1:length(x)) {
      res <- res + x[i]^r*y[i]
    }
  } else {
    res <- ifelse(r == 1, 0,
             ifelse(r == 2, momento(x, y, 2)-(momento(x, y, 1)^2),
               ifelse(r == 3, momento(x, y, 3) - momento(x, y, 1)^3 -
                              3*momento(x, y, 1)*momento(x, y, 2, centrato = TRUE),
                  res <- NaN)))
  }
  return(res)
}

mat_original <- matrix(c(data[1], data[2], data[3], expected,
                       data[1]^2, data[2]^2, data[3]^2, variance+expected^2,
                       1, 1, 1, 1), byrow = TRUE, nrow = 3, ncol = 4)

mat <- rref(mat_original)
prob <- c(mat[10],mat[11],mat[12])

print(matrix(c(data[1], data[2], data[3], prob[1], prob[2], prob[3]),
             byrow = TRUE, nrow = 2, ncol = 3))

mnnoncentrato3 <- momento(data, prob, 3)
mncentrato3 <- momento(data, prob, 3, centrato = TRUE)

print(mnnoncentrato3)
print(mncentrato3)


#   __      _____             _              __        _
# <(o )___ |  _  |___ ___ ___| |_ ___ ___   |  |   ___| |_ ___
# ( ._> /  |   __|  _| -_|_ -|  _| -_|_ -|  |  |__| .'| . |_ -|
#  `---'   |__|  |_| |___|___|_| |___|___|  |_____|__, |___|___|
#==============================================================================
# Nonparametric Smoothing in Regression
#==============================================================================
# Title          : Nonparametric_regression_kernel.r
# Description    : Nonparametric regression using kernel weights.
# Author         : Isaias V. Prestes <isaias.prestes@gmail.com>
# Date           : 20170604
# Version        : 0.0.1
# Usage          : Run in R 3.4
# Notes          : Reference
#                  http://www.stat.cmu.edu/~cshalizi/uADA/12/lectures/ch04.pdf
# R version      : 3.4
#==============================================================================

# Using Nonparametric Smoothing in Regression
x = runif(300, 0, 3)
yf = sin(x)*cos(20*x) + rnorm(length(x), 0, 0.15)
yg = log(x + 1) + rnorm(length(x), 0, 0.15)
par(mfcol=c(2, 1))
plot(x, yf, xlab="x", ylab=expression(f(x) + epsilon))
curve(sin(x)*cos(20*x), col="grey", add=TRUE)
plot(x, yg, xlab="x", ylab=expression(g(x) + eta))
curve(log(x + 1), col="grey", add=TRUE)

# Selecting a region
windows()
par(mfcol=c(2,1))
colors=ifelse((x<1.7)&(x>1.5),"black","grey")
plot(x,yf,xlab="x",ylab=expression(f(x)+epsilon),col=colors)
curve(sin(x)*cos(20*x),col="grey",add=TRUE)
points(1.6,mean(yf[(x<1.7)&(x>1.5)]),pch="*",cex=2)
plot(x,yg,xlab="x",ylab=expression(g(x)+eta),col=colors)
curve(log(x+1),col="grey",add=TRUE)
points(1.6,mean(yg[(x<1.7)&(x>1.5)]),pch="*",cex=2)

#
loc_ave_err <- function(h,y,y0) {abs(y0-mean(y[(1.6-h < x) & (1.6+h>x)]))}
yf0=sin(1.6)*cos(20*1.6)
yg0=log(1+1.6)
f.LAE = sapply(0:100/100,loc_ave_err,y=yf,y0=yf0)
g.LAE = sapply(0:100/100,loc_ave_err,y=yg,y0=yg0)
plot(0:100/100,f.LAE,xlab="Radius of averaging window",
ylab="Absolute value of error",type="l")
lines(0:100/100,g.LAE,lty=2)
abline(h=0.15,col="grey")

# Cross-validation for univariate kernel regression
cv_bws_npreg <- function(x,y,bandwidths=(1:50)/50, num.folds=10) {
	require(np)
	n <- length(x)
	stopifnot(n> 1, length(y) == n)
	stopifnot(length(bandwidths) > 1)
	stopifnot(num.folds > 0, num.folds==trunc(num.folds))
	fold_MSEs <- matrix(0,nrow=num.folds,
	ncol=length(bandwidths))
	colnames(fold_MSEs) = bandwidths
	case.folds <- rep(1:num.folds,length.out=n)
	case.folds <- sample(case.folds)
	for (fold in 1:num.folds) {
		train.rows = which(case.folds==fold)
		x.train = x[train.rows]
		y.train = y[train.rows]
		x.test = x[-train.rows]
		y.test = y[-train.rows]
		for (bw in bandwidths) {
			fit <- npreg(txdat=x.train,tydat=y.train,
			exdat=x.test,eydat=y.test,bws=bw)
			fold_MSEs[fold,paste(bw)] <- fit$MSE
		}
	}
	CV_MSEs = colMeans(fold_MSEs)
	best.bw = bandwidths[which.min(CV_MSEs)]
	return(list(best.bw=best.bw, CV_MSEs=CV_MSEs, fold_MSEs=fold_MSEs))
}

fbws <- cv_bws_npreg(x,yf,bandwidths=(1:100)/200)
gbws <- cv_bws_npreg(x,yg,bandwidths=(1:100)/200)
plot(1:100/200,sqrt(fbws$CV_MSEs),xlab="Bandwidth", ylab="Root CV MSE",type="l",ylim=c(0,0.6))
lines(1:100/200,sqrt(gbws$CV_MSEs),lty=2)
abline(h=0.15,col="grey")

x.ord = order(x)
par(mfcol = c(2, 1))
plot(x, yf, xlab = "x", ylab = expression(f(x)+epsilon))
fhat <- npreg(bws = fbws$best.bw, txdat = x, tydat = yf)
lines(x[x.ord], fitted(fhat)[x.ord], lwd = 4)
curve(sin(x)*cos(20*x), col = "grey", add = TRUE, lwd = 2)
plot(x, yg, xlab = "x", ylab = expression(g(x)+eta))
ghat <- npreg(bws = fbws$best.bw, txdat = x, tydat = yg)
lines(x[x.ord], fitted(ghat)[x.ord], lwd = 4)
curve(log(x+1), col = "grey", add = TRUE, lwd = 2)

# Gaussian kernel regression of the points
noise.np <- npreg(y~x1+x2,data=noise)
y.out <- matrix(0,100,100)
y.out <- predict(noise.np,newdata=x12grid)
wireframe(y.out~x12grid$x1*x12grid$x2,scales=list(arrows=FALSE),xlab=expression(x^1),ylab=expression(x^2),zlab="y")

# Average Predictive Comparisons
new.frame <- data.frame(x=seq(-3,3,length.out=300),y=median(y.noise))
plot(new.frame$x,predict(noise.np,newdata=new.frame),
type="l",xlab=expression(x^1),ylab="y",ylim=c(0,1.0))
new.frame$y <- quantile(y.noise,0.25)
lines(new.frame$x,predict(noise.np,newdata=new.frame),lty=2)
new.frame$y <- quantile(y.noise,0.75)
lines(new.frame$x,predict(noise.np,newdata=new.frame),lty=3)

curve(exp(7*x)/(1+exp(7*x)),from=-5,to=5,ylab="y")


# define x and z
library(tidyverse)
library(dslabs)
data(heights)
index <- heights$sex=="Male"
x <- heights$height[index]
z <- scale(x)

# proportion of data below 69.5
mean(x <= 69.5)

# calculate observed and theoretical quantiles
p <- seq(0.05, 0.95, 0.05)
observed_quantiles <- quantile(x, p)
theoretical_quantiles <- qnorm(p, mean = mean(x), sd = sd(x))

# make QQ-plot
plot(theoretical_quantiles, observed_quantiles)
abline(0,1)

# make QQ-plot with scaled values
observed_quantiles <- quantile(z, p)
theoretical_quantiles <- qnorm(p)
plot(theoretical_quantiles, observed_quantiles)
abline(0,1)


# Example : 4   Chapter : 4.4     Page No: 233
# Projections of the vector onto line,plane if basis are given as orthonormal vectors
Q<-matrix(c(-1,2,2,2,-1,2,2,2,-1),ncol=3)
Q<-(1/3)*Q
q1<-Q[,1]
q2<-Q[,2]
q3<-Q[,3]
b<-c(0,0,1)
p1<-sum(q1*b)*q1
p2<-sum(q2*b)*q2
p3<-sum(q3*b)*q3
print("Projection of b onto q1")
print(p1)
print("Projection of b onto q2")
print(p2)
print("Projection of b onto q3")
print(p3)
print("Projection of b onto plane of q1 and q2")
print(p1+p2)
print("Projection of b onto space of q1,q2, and q3")
print(p1+p2+p3) # same as vector b


## Author: Sergio García Prado
## Title: Statistical Inference - Goodness of Fit - Exercise 09

rm(list = ls())

observed <- c(8, 46, 55, 40, 11)

(k <- length(observed))
# 5

(n <- sum(observed))
# 160

(p.hat <- sum(observed * 0:(k-1)) / (n * (k - 1)))
# 0.5

(expected <- n * dbinom(0:(k - 1), size = k - 1, prob = p.hat))
# 10 40 60 40 10

(Q <- sum((observed - expected ) ^ 2 / expected))
# 1.81666666666666

(pvalue <- 1 - pchisq(Q, df = (k - 1) - 1))
# 0.611314815940897


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


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


# 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


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


# 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


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


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