#задание 2
print ("task 2")
A <- matrix (c(0,-12,-11,13,11,11,-3,12,9,-11,12,-13,0,-8,11,14,14,-13,7,8,-1,-10,14,-6,-2,-14,-7,8,1,14,13,9,-6,7,-3,2),6,6)
A
#определитель
det(A) # Определитель A

#задание 4
print ("task 4")
A <- matrix (c(-1,3,-5,0,0,-7,-1,-3,10,-6,-1,6,-3,4,-9,1,7,-8,5,12,4,-12,10,5,-2,-12,-7,-5,-6,-4,7,-9,11,-2,5,5),6,6)
A
B <- matrix (c(-6,1,8,6,5,2,6,3,-6,-6,9,-2,3,5,2,0,-3,9,4,-1,-6,4,-1,1,6,-9,0,6,5,1,8,-6,8,-4,-1,0),6,6)
B
x <- solve(B,A)
print ("x равен")
x

#задание 5
print ("5 task")
a <- c(0,-4,2,3,1,1,1,0,-5,-2,-1,3)
b <- c(-4,-4,0,3,-2,-1,-2,3,3,1,1,5)
p <- c(1,5,2,4,3,0,-4,-5,1,2,2,1)

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

#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 = "max")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(2,1)) # Задаем целевую функцию:
add.constraint(M, c(4,3), "<=", 1) # Задаем ограничение:
add.constraint(M, c(-0.2, -0.6), ">=",-1.5) #

rownames(M) <- c("A", "B") # Называем ограничения в модели М
M # Выводим модель M на экран
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M) # Достигнутый min
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# Значение целевой функции на оптимальном решении


check_mod <- function(num,base){
  return(ifelse(num%%base == 0,num,0))
}

sum_sequence <- function(max,base){
  val <- 1:max
  ret_val <- sum(sapply(X = val,FUN = function(x){check_mod(num = x,base = base)}))
  return(ret_val)}

sum_sequence(1000,3)+sum_sequence(1000,5)-sum_sequence(1000,15)


#' @export
#'
#' @title Baysian estimation of a multinomial
#' proportion vector assuming a conjugate
#' prior.
#'
#' @description This routine assumes you have an observation
#' from a multinomial distribution with k classes (k >= 2, parameter
#' \code{x}) and have assumed that the multinomial distribution's
#' proportion vector ("pi vector") follows a Dirichelet distribution.
#' If so, this routine estimates the proportion vector's
#' posterior distribution mean, variance, and mode.
#'
#' @param x An integer vector
#' containing the number of observed 'successes' in
#' each catagory of the multinomial. Total number of trials is \code{sum(x)}.
#' The number of catagories is K = \code{length(x)}.
#'
#' @param pseudoCounts A vector of real-valued "pseudo counts"
#' for the K catagories in the problem. This is sometimes called
#' the "concentration" parameter.
#'
#'
#' @details
#'
#' Computations are elementary because the Dirichlet(a1, a2, ..., aK) prior is
#' conjugate for the multinomial. Nearly every text on Bayesian
#' estimation shows that given values for \code{x} and \code{pseudoCounts},
#' the posterior distribution of the mulitinomial's p vector
#' is,
#' \deqn{Dirichlet(x1+a1, x2+a2, ..., xk+ak).}
#' Hence, the Bayes point estimator of the multinomial's proportions is,
#' \deqn{phat_i = (xi+ai) / sum(xi + ai),}
#' which is the mean of the posterior. Standard error of the
#' posterior is,
#' \deqn{se.phat_i=sqrt((xi+ai)*(A-ai)/(A^2*(A+1))).}
#' where A = sum(xi + ai).  If \code{(xi+ai)>1} for all i, mode of the
#' posterior for the proportion vector is,
#' \deqn{(xi+ai-1)/(A-K).}
#'
#'
#' The default value for \code{pseudoCounts}
#' corresponds to the Jeffery's prior.  The Jeffery's prior is
#' proportional to the root of Fisher's information and
#' is equal to Dirichlet(1/K,1/K, ..., 1/K).
#'
#' @return A data frame with number of rows equal to
#' \code{length(x)}
#' containing the Baysian point estimates for the proportion
#' in each catagory.
#' The data frame has the
#' following columns:
#' \enumerate{
#'   \item \code{phat} : the Bayes point estimates equal to the
#'   mean vector of the posterior distribution. This column sums to 1.0
#'   \item \code{phat.mode} : if \code{xi+ai} > 1 for all i, this
#'   column contains the mode vector of the posterior. Mode vector
#'   is the most vector of proportions with maximum likelihood.
#'   If any \code{xi+ai} < 1, \code{phat.mode = NA}.
#'   \item \code{se.phat} : the standard
#'   error vector of the posterior distribution.
#'   \item \code{psuedoCounts} : the vector of pseudoCounts
#'   associated with the Dirichlet posterior.  This vector
#'   can be used to accumulate counts over muliple calls.
#' }
#'
#' @author Trent McDonald
#'
#'
#' @seealso \code{\link{agrestiCoullPhat}}
#'
#' @examples
#' bayesPiVector(c(1,5), c(.5,.5))  # Jeffery's prior
#' bayesPiVector(c(1,5), c(1, 1)) # flat prior
#'
#' # When prior data is available:
#' x.prior <- 5
#' n.prior <- 100
#' bayesPiVector(c(1,5), c(x.prior+0.5, n.prior-x.prior+0.5))
#'
#' # Simulation: point est bias and ci coverage
#' trueP <- c(0.01, 0.04, 0.95)
#' n <- 20
#' x <- rbinom( 1000, n, trueP)
#' baPhat <- apply(x, 1, bayesPiVector, pseudoCounts=rep(1,3)/3 )
#' muBA <- mean(baPhat$phat)
#'
bayesPiVector <- function(x, pseudoCounts=rep(1,length(x))/length(x)){
  aPost <- x + pseudoCounts
  A <- sum(aPost)
  phat <- aPost / A

  se <- sqrt(aPost*(A-aPost) / (A^2*(A+1)))

  if( all(aPost>1) ){
    phat.mode <- (aPost-1) / (A - length(aPost))
  } else {
    phat.mode <- NA
  }

  data.frame(phat=phat, se.phat=se, phat.mode=phat.mode, pseudoCounts=aPost)
}


N <- 1000
c <- c(0.2, 0.15, 0.25, 0.4)
u <- runif(N)
r <- 1:N * 0
r2 <- 1:N * 0

# Varianta 1
count1 <- 0
for(i in 1:N){
  if(u[i] < c[1]){
    r[i] <- 1
    count1 <- count1 + 1
  }else
    if(u[i] < c[1] + c[2]) {
      r[i] <- 2
      count1 <- count1 + 2
    }else
      if(u[i] < c[1] + c[2] + c[3]) {
        r[i] <- 3
        count1 <- count1 + 3
      }else {
        r[i] <- 4
        count1 <- count1 + 3
      }
}
count1

# Varianta 2
count2 <- 0
for(i in 1:N){
  if(u[i] < c[4]){
    r2[i] <- 4
    count2 <- count2 + 1
  }else
    if(u[i] < c[4] + c[3]) {
      r2[i] <- 3
      count2 <- count2 + 2
    }else
      if(u[i] < c[4] + c[3] + c[1]) {
        r2[i] <- 1
        count2 <- count2 + 3
      }else {
        r2[i] <- 2
        count2 <- count2 + 3
      }
}
count2

length(r[r == 1]) / length(r)
length(r[r == 2]) / length(r)
length(r[r == 3]) / length(r)
length(r[r == 4]) / length(r)
rr <- sample(1:4, size=N, prob = c, replace=TRUE)
length(rr[rr == 1]) / length(rr)
length(rr[rr == 2]) / length(rr)
length(rr[rr == 3]) / length(rr)
length(rr[rr == 4]) / length(rr)

length(r2[r2 == 1]) / length(r2)
length(r2[r2 == 2]) / length(r2)
length(r2[r2 == 3]) / length(r2)
length(r2[r2 == 4]) / length(r2)
length(rr[rr == 1]) / length(rr)
length(rr[rr == 2]) / length(rr)
length(rr[rr == 3]) / length(rr)
length(rr[rr == 4]) / length(rr)

sample(1:4)
y <- c(1:5, 3:6)
sample(y)
sample(1:4, size=3)
sample(1:4, size=3, replace=TRUE)
s <- sample(y, size=900, replace=TRUE) # doar 1, 2 si 6 au prob 1/9, in timp ce 2,4 si 5 au 2/9
length(s[s == 1]) / length(s)
length(s[s == 2]) / length(s)
length(s[s == 3]) / length(s)
length(s[s == 4]) / length(s)
length(s[s == 5]) / length(s)
length(s[s == 6]) / length(s)

t <- sample(1:4, size=100, prob=c(0.2, 0.15, 0.25, 0.4), replace=TRUE)
length(t[t == 1]) / length(t)
length(t[t == 2]) / length(t)
length(t[t == 3]) / length(t)
length(t[t == 4]) / length(t)

Bachelors Year 3/Simulation techniques/Simulation of discrete distributions.r


## calculate beta (1st moment of inertia) for piecewise linear function y = f(x)
beta <- function(x, y) {

    beta <- 0
    for (i in 2:length(x)) {
        ## for each segment

        if (x[i] != x[i-1]) {
            ## not a step change so segment will add to beta for segment of length base
            base      <-  x[i] - x[i-1]

            ## calculate beta for rectangular part
            rheight   <- min(y[i], y[i-1])
            rarea     <- base * rheight
            rcentroid <- (x[i] + x[i-1]) / 2
            beta      <- beta + rarea * rcentroid

            ## calculate additional beta for triangular part, if any
            if (y[i-1] != y[i]) {
                ## there is additional area to consider
                theight <- max(y[i], y[i-1]) - rheight
                tarea   <- base * theight / 2
                if (y[i-1] < y[i]) {
                    ## triangle height increasing with distance
                    tcentroid <- x[i-1] + base * 2 / 3
                } else {
                    ## triangle height decreases with distance
                    tcentroid <- x[i-1] + base * 1 / 3
                }
                beta <- beta + tarea * tcentroid
            }
        }
    }
    return(beta)
}

## x <- c(0, 10, 10, 15, 20)
## y <- c(5,  5, 10, 10,  5)
## beta(x,y)


newton.raphson <- function(f, ..., xguess=0, tol = 1e-5, n = 1000, plot='no') {
    ## use newton raphson to find x where f(x, ...) = 0
    ## where "..." is a list of additional arguments needed by f, if any
    ## starts search from xguess

    args <- unlist( list(...) )

    ## following modified from https://rpubs.com/aaronsc32/newton-raphson-method
    library(numDeriv) # Package for computing f'(x)

    x0 <- xguess      # Set start value to supplied guess
    xvalue <- n       # Initialize for iteration results
    yvalue <- n       # Initialize for iteration results

    ## Check to see if xguess result in 0
    ## if (f(x0, ...) == 0.0) return(x0)
    if (length(args) == 1) {
        if (f(x0) == 0.0) return(x0)
    } else {
        if (f(x0, ...) == 0.0) return(x0)
    }

    ## iterate to find where f(x, ...) = 0
    xvalue[1] <- x0          # store x values
    yvalue[1] <- f(x0, ...)  # store y values
    for (i in 2:(n+1)) {
        dx <- genD(func = f, ..., x = x0)$D[1] # First-order derivative f'(x0)
        x1 <- x0 - (f(x0, ...) / dx)           # Calculate next guess x1
        ## Once the difference between x0 and x1 becomes sufficiently small, output the results.
        if (abs(x1 - x0) < tol) {
            root.approx <- tail(xvalue, n=1)
            res <- list('root' = root.approx, 'iterations' = xvalue)
            if (plot != 'no') {
                main <- 'Solution found within tolerance'
                plot(xvalue, yvalue, col='red', main=main)
                points(xvalue[1], yvalue[1], col='black', pch=19)  # solid black initial guess
                last <- length(xvalue)
                points(xvalue[last], yvalue[last], col='red', pch=19)  # solid red final result
                x <- seq(min(xvalue), max(xvalue), (max(xvalue)-min(xvalue))/100)
                y <- f(x, ...)
                points(x,y,type='l')
                legend('bottomright',
                       legend=c('initial guess', 'intermediate steps', 'final result'),
                       col   =c('black',         'red',                'red'),
                       pch   =c(19,              1,                    19))
            }
            return(res)
        }

        ## save new valeus of x and y
        xvalue[i] <- x1
        yvalue[i] <- f(x1, ...)

        ## If search has not yet reached convergence, set new x0 guess
        ## check whether solution is bracketed
        if (yvalue[i] / yvalue[i-1] < 0) {
            ## bracketed solution since successive y values have opposite sign
            ## use bisection to keep solution from diverging
            x0 <- (x0 + x1)/2
        } else {
            ## have not bracketed solution so use X1 as next guess
            x0 <- x1
        }
    }
    main <- 'Too many iterations in method'
    plot(xvalue, yvalue, col='red', main=main)
    points(xvalue[1], yvalue[1], col='black', pch=19)  # solid black initial guess
    last <- length(xvalue)
    points(xvalue[last], yvalue[last], col='red', pch=19)  # solid red final result
    x <- seq(min(xvalue), max(xvalue), (max(xvalue)-min(xvalue))/100)
    y <- f(x, ...)
    points(x,y,type='l')
    legend('bottomright',
           legend=c('initial guess', 'intermediate steps', 'final result'),
           col   =c('black',         'red',                'red'),
           pch   =c(19,              1,                    19))
}

test_newton.raphson <- function() {
    set.seed(1)

    ## example: this works
    x <- rnorm(1000)
    jparms  <- SuppDists::JohnsonFit(x)
    zero <- function(x, parms, z)  john_z(x, parms) - z
    x.out <- newton.raphson(
        zero,
        parms = jparms,
        z=2.4,
        xguess = mean(x),
        tol=1E-10,
        plot='yes'
    )
    x.out$root

    ## example: this works
    set.seed(1)
    x <- rnorm(1000)
    zero <- function(x, parm1, parm2, z)  (x^2 + parm1 + parm2) - z
    plotspace(2,1)
    x.out <- newton.raphson(
      zero,
      parm1 = 11,
      parm2 = mean(x),
      z=30,
      xguess = 30,
      tol=1E-10,
      plot='yes'
    )
    x.out$root
    plot(x, y = x^2 + 11 + mean(x), main='wider view of function')

    ## example: this works
    x <- rnorm(1000)
    zero <- function(x, mean, sd, z)  (x - mean)/sd - z
    x.out <- newton.raphson(
        zero,
        mean=mean(x),
        sd=sd(x),
        z=2.4,
        xguess = mean(x),
        tol=1E-10,
        plot='yes'
    )
    x.out$root

    ## example: This fails because only 1 xguess is passed into the function so sd(xguess) is NA
    ##          It aborts when the newton.raphson function tries using the zero function
    ##          e.g., zero(x=2, z=3) returns NA
    ##                zero(x=c(2,4), z=3) returns -3.71 and -2.29
    ##          Note that mean(x) = x also does not make much sense for a single x value,
    ##          but that does not make the function abort
    x <- rnorm(1000)
    zero <- function(x, z)  (x - mean(x))/sd(x) - z
    x.out <- newton.raphson(
        zero,
        z=2.4,
        xguess = mean(x),
        tol=1E-10,
        plot='yes'
    )
    x.out$root
}


### Distribuição a priori
## ! Dica: brinque com os hiperparâmetros da priori e olhe o que acontece com o segundo gráfico.
alpha <- 1
beta <- 2
theta <- rgamma(1e6, shape = alpha, rate = beta)

curve(dgamma(x, shape = alpha, rate = beta), min(theta), max(theta),
      xlab = expression(theta), ylab = expression(xi(theta)), lwd = 3,  cex.lab=1.5)

## Gerando alguns dados

n <- 10
## ! Dica: mude o número de observações e veja o que acontece com a posteriori no segundo gráfico.

theta.vdd <- 0.65 # theta "verdadeiro"

X <- rexp(n = n, rate = theta.vdd)
mean(X); sd(X)

S <- sum(X)

curve(dgamma(x, shape = alpha, rate = beta), min(theta), max(theta),
      xlab = expression(theta), ylab = "Densidade", lwd = 3,  cex.lab = 1.5)
curve(dgamma(x, shape = alpha + n + 1, rate = beta + S), min(theta), max(theta),
      lwd = 3, lty = 2, col = "grey50", add = TRUE)
legend(x = "topright", legend = c("Priori", "Posteriori"), bty = 'n', lwd = 2, lty = 1:2, col = c("black", "grey50"))

## Agora, o aprendizado sequencial

curve(dgamma(x, shape = alpha, rate = beta), min(theta), max(theta),
      xlab = expression(theta), ylab = "Densidade", lwd = 4,  cex.lab = 1.5)
for(i in 1:n){
  curve(dgamma(x, shape = alpha + n + 1, rate = beta + sum(X[1:i])), min(theta), max(theta),
        lwd = 4, lty = 2, col = rev(heat.colors(n))[i], add = TRUE)
}
legend(x = "topright",
       legend = c("Priori", paste("Posteriori até x_", 1:n, sep = "")), bty = 'n', lwd = 3, lty = c(1, rep(2, n)),
       col = c("black", rev(heat.colors(n)[1:n])))


### Code skeleton for Series 8, task 2

## read in data
## data(ozone, package = "gss")

## alternative
ozone <- read.table("http://stat.ethz.ch/Teaching/Datasets/ozone.dat", header = TRUE)

###################################################
### TASK a)
###################################################

ozone$logupo3 <- log(ozone$upo3)
d.ozone <- subset(ozone, select = -upo3)
pairs(ozone, pch = ".", gap = 0.1)

## delete outlier
out <- 92
d.ozone.e <- d.ozone[-out,]

###################################################
### TASK b)
###################################################

## package for wrapFormula()  [sfsmisc := miscellaneous from SfS
##                             ---        SfS = Seminar für Statistik, ETH Z ]
require(sfsmisc)

## Linear models
## fit 1 (polynomial of degree 1)
# write a formula as you know it from lm()
form1 <- as.formula(logupo3 ~ .)
fit1 <- lm(form1, d.ozone.e)

## fits of degree 2 to 5
form2 <- wrapFormula(f = form1, data = d.ozone.e, wrapString = "poly(*, degree = 2)")
fit2 <- lm(form2, d.ozone.e)

form3 <- wrapFormula(f = form1, data = d.ozone.e, wrapString = "poly(*, degree = 3)")
fit3 <- lm(form3, d.ozone.e)

form4 <- wrapFormula(f = form1, data = d.ozone.e, wrapString = "poly(*, degree = 4)")
fit4 <- lm(form4, d.ozone.e)

form5 <- wrapFormula(f = form1, data = d.ozone.e, wrapString = "poly(*, degree = 5)")
fit5 <- lm(form5, d.ozone.e)

## GAM
require(mgcv)
gamForm <- wrapFormula(form1, data=d.ozone.e, wrapString = "s(*)")
g1 <- gam(formula = gamForm, data = d.ozone.e)
summary(g1)

###################################################
### TASK c)
###################################################

## plot the fits

## for the linear models
par(mfrow=c(3, 3))
termplot(fit1, partial.resid = TRUE, rug = TRUE, se = TRUE, pch = 19)

par(mfrow=c(3, 3))
termplot(fit2, partial.resid = TRUE, rug = TRUE, se = TRUE, pch = 19)

par(mfrow=c(3, 3))
termplot(fit3, partial.resid = TRUE, rug = TRUE, se = TRUE, pch = 19)

par(mfrow=c(3, 3))
termplot(fit4, partial.resid = TRUE, rug = TRUE, se = TRUE, pch = 19)

par(mfrow=c(3, 3))
termplot(fit5, partial.resid = TRUE, rug = TRUE, se = TRUE, pch = 19)

## for the additive model
mult.fig(nr.plots = 9, main = "gam(gamForm, data = d.ozone.e)")
plot(g1, shade = TRUE)

###################################################
### TASK d)
###################################################

## Mallows Cp function

Cp <- function(object, sigma){
  res <- residuals(object)
  n <- length(res)
  p <- n - object$df.residual
  SSE <- sum(res^2)
  SSE / sigma^2 - n + 2 * p
}

## set sigma (use estimated sigma from fit5)
sigma <- sigma(fit5)

## Calculate Mallows's Cp statistic for all 6 models
Cp1 = Cp(fit1, sigma)
Cp2 = Cp(fit2, sigma)
Cp3 = Cp(fit3, sigma)
Cp4 = Cp(fit4, sigma)
Cp5 = Cp(fit5, sigma)
Cpg1 = Cp(g1, sigma)

###################################################
### TASK e)
###################################################
require(earth)
m1 <- earth(form1, d.ozone.e, degree = 1)
summary(m1)

###################################################
### TASK f)
###################################################
set.seed(1)
n <- nrow(d.ozone.e)
K <- 10
folds <- sample(cut(seq(1, n), breaks = K, labels = FALSE), replace = FALSE)

fold.error.m1 <- numeric(K)
fold.error.m2 <- numeric(K)
fold.error.m3 <- numeric(K)
fold.error.g1 <- numeric(K)

for (i in 1:K) {
  test.ind <- which(folds == i)
  df.train <- d.ozone.e[-test.ind, ]
  df.test <- d.ozone.e[test.ind, ]

  m1i <- earth(formula = form1, data = df.train, degree = 1)

  yhat.m1 <- predict(m1i, newdata = df.test, type = "response")

  fold.error.m1[i] <- mean((yhat.m1 - df.test$logupo3) ** 2)

  m2i <- earth(formula = form1, data = df.train, degree = 2)

  yhat.m2 <- predict(m2i, newdata = df.test, type = "response")

  fold.error.m2[i] <- mean((yhat.m2 - df.test$logupo3) ** 2)

  m3i <- earth(formula = form1, data = df.train, degree = 3)

  yhat.m3 <- predict(m3i, newdata = df.test, type = "response")

  fold.error.m3[i] <- mean((yhat.m3 - df.test$logupo3) ** 2)

  g1i <- gam(formula = gamForm, data = df.train)

  yhat.g1 <- predict(g1i, newdata = df.test, type = "response")

  fold.error.g1[i] <- mean((yhat.g1 - df.test$logupo3) ** 2)
}

c(m1 = mean(fold.error.m1), m2 = mean(fold.error.m2), m3 = mean(fold.error.m3),
  g1 = mean(fold.error.g1))


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

#=========================================
# TASK 3
#=========================================
# original data
species.richness <- c(32, 29, 35, 36, 41)
lake.area <- c(2.0, 0.9, 3.1, 3.0, 3.0)

# pearson's correlation - original
cor.original <- cor(species.richness, lake.area)

# 1000 times of permutations
N <- 1000
cnt <- 0
for (i in 1:N) {
  # randomly sampling vectors
  species.richness.random <- sample(species.richness)
  lake.area.random <- sample(lake.area)

  # pearson's correlation - random
  cor.random <- cor(species.richness.random, lake.area.random)

  # if cor.random is greater than or equal to cor.original
  # count variable + 1
  if (cor.random >= cor.original) {
    cnt <- cnt+1
  }
}
print ("===============")
print (paste("P-Value: ", cnt/N))


train <- function(df, n) {	# df - input dataframe, n - learning rate
	l <- length(df$X1)	# records in dataframe
#	w <- c(0.001,0.001)
	w <- c(5.0,5.0)
	b <- 0
	R <- max(sqrt(df$X1^2 + df$X2^2))

	repeat {
		mistake <- FALSE
		for (i in 1:l) {
			xi <- c(df$X1[i],df$X2[i])
			yi <- df$Y[i]
			if (sign(sum(w*xi) - b) != yi) {
				mistake <- TRUE
				w <- w + n*yi*xi
				b <- b - n*yi*R^2
			}
		}
		surface(list("w"=w,"b"=b)) # keep plotting the evolving decision surface
		if (interactive)
			readline(prompt="Paused")
		if (!mistake)
			break
	}

	finalsurface(list("w"=w,"b"=b))
	slope = -(w[1]/w[2])
#	offset = - (b/w[2])
	offset =  (b/w[2])
	list("slope"=slope,"offset"=offset)

}

surface <- function(m) {
	w <- m$w
	b <- m$b

	slope = -(w[1]/w[2])
#	offset = - (b/w[2])
	offset =  (b/w[2])

	# assumes that there was something like this, plot(0:9,0:9,type="n"), before
	abline(offset,slope,lty="dashed")
}

finalsurface <- function(m) {
	w <- m$w
	b <- m$b

	slope = -(w[1]/w[2])
#	offset = - (b/w[2])
	offset =  (b/w[2])

	# assumes that there was something like this, plot(0:9,0:9,type="n"), before
	abline(offset,slope,lty="solid",lwd=2,col="green")
}

dataset <- function(df) {
	quartz(width=8,height=8)
	# setup the plot
	plot(-20:20,-20:20,type="n",main="Perceptron Learning",xlab="X1",ylab="X2")
	abline(h=0)
	abline(v=0)

	# plot the classes
	for (i in 1:length(df$X1))
		if (df$Y[i] > 0 )
			points(df$X1[i],df$X2[i],col="red")
		else
			points(df$X1[i],df$X2[i],col="blue")
}

#### main driver routine ###
#ds <- read.table("ds1.csv", header=TRUE, sep=",")
ds <- as.data.frame(list("X1" = c(1,3,4,5,1,2,2.5,3), "X2"=c(6,7,1,3,4,1,1.5,1), "Y"=c(-1,-1,-1,-1,1,1,1,1)))
interactive <- TRUE

run <- function(learningrate) {
	dataset(ds)
	train(ds,learningrate)
}


#!/usr/bin/Rscript

require(deSolve)

## =======================================================================
## Example: Numerical solution of the famous Lorenz equation, with a
## strange attractor
## =======================================================================

parameters <- c(a = -8/3,
                b = -10,
                c = 28)

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

## the Lorenz ODE system

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

# rate of change

        dX <- a*X + Y*Z
        dY <- b * (Y-Z)
        dZ <- -X*Y + c*Y - 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, "Lorenz model", cex = 1.5)


# Goal: To do OLS by MLE.

# OLS likelihood function
# Note: I am going to write the LF using sigma2=sigma^2 and not sigma.
ols.lf1 <- function(theta, y, X) {
  beta <- theta[-1]
  sigma2 <- theta[1]
  if (sigma2 <= 0) return(NA)
  n <- nrow(X)
  e <- y - X%*%beta                                  # t() = matrix transpose
  logl <- ((-n/2)*log(2*pi)) - ((n/2)*log(sigma2)) - ((t(e)%*%e)/(2*sigma2))
  return(-logl) # since optim() does minimisation by default.
}

# Analytical derivatives
ols.gradient <- function(theta, y, X) {
  beta <- theta[-1]
  sigma2 <- theta[1]
  e <- y - X%*%beta
  n <- nrow(X)

  g <- numeric(length(theta))
  g[1] <- (-n/(2*sigma2)) + (t(e)%*%e)/(2*sigma2*sigma2) # d logl / d sigma
  g[-1] <- (t(X) %*% e)/sigma2                           # d logl / d beta

  return(-g)
}

X <- cbind(1, runif(1000))
theta.true <- c(2,4,6) # error variance = 2, intercept = 4, slope = 6.
y <- X %*% theta.true[-1] + sqrt(theta.true[1]) * rnorm(1000)

# Estimation by OLS --
d <- summary(lm(y ~ X[,2]))
theta.ols <- c(sigma2 = d$sigma^2, d$coefficients[,1])
cat("OLS theta = ", theta.ols, "\n\n")

cat("\nGradient-free (constrained optimisation) --\n")
optim(c(1,1,1), method="L-BFGS-B", fn=ols.lf1,
      lower=c(1e-6,-Inf,-Inf), upper=rep(Inf,3), y=y, X=X)

cat("\nUsing the gradient (constrained optimisation) --\n")
optim(c(1,1,1), method="L-BFGS-B", fn=ols.lf1, gr=ols.gradient,
      lower=c(1e-6,-Inf,-Inf), upper=rep(Inf,3), y=y, X=X)

cat("\n\nYou say you want a covariance matrix?\n")
p <- optim(c(1,1,1), method="L-BFGS-B", fn=ols.lf1, gr=ols.gradient,
           lower=c(1e-6,-Inf,-Inf), upper=rep(Inf,3), hessian=TRUE,
           y=y, X=X)
inverted <- solve(p$hessian)
results <- cbind(p$par, sqrt(diag(inverted)), p$par/sqrt(diag(inverted)))
colnames(results) <- c("Coefficient", "Std. Err.", "t")
rownames(results) <- c("Sigma", "Intercept", "X")
cat("MLE results --\n")
print(results)
cat("Compare with the OLS results --\n")
d$coefficients

# Picture of how the loglikelihood changes if you perturb the sigma
theta <- theta.ols
delta.values <- seq(-1.5, 1.5, .01)
logl.values <- as.numeric(lapply(delta.values,
                                 function(x) {-ols.lf1(theta+c(x,0,0),y,X)}))
plot(sqrt(theta[1]+delta.values), logl.values, type="l", lwd=3, col="blue",
     xlab="Sigma", ylab="Log likelihood")
grid()

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


# Polynomial regression for machine learning.
#
# polynomial regression is a form of regression analysis in which the
# relationship between the independent variable x and the dependent variable y is
# modelled as an nth degree polynomial in x. Polynomial regression fits a
# nonlinear relationship between the value of x and the corresponding conditional
# mean of y, denoted E(y |x)Although polynomial regression fits a nonlinear model
# to the data, as a statistical estimation problem it is linear, in the sense
# that the regression function E(y | x) is linear in the unknown parameters that
# are estimated from the data. For this reason, polynomial regression is
# considered to be a special case of multiple linear regression.

# Importing the data set
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3]

# no need to split
# # Splitting the Dataset into a Training set and a Test set
# # install.packages('caTools')
# # library(caTools)
# set.seed(123) # choose random number, only same number for debugging
# split = sample.split(dataset$Salary, SplitRatio = 0.8)
# training_set = subset(dataset, split==TRUE)
# test_set = subset(dataset, split==FALSE)

# Fit Polynomial regression to the dataset
dataset$Level2 = dataset$Level^2
dataset$Level3 = dataset$Level^3
dataset$Level4 = dataset$Level^4
dataset$Level5 = dataset$Level^5
poly_reg = lm(formula = Salary ~ ., data = dataset)
summary(poly_reg)

# Visualize graphic result of Polynomial regression
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             colour='red') +
  geom_line(aes(x = dataset$Level, y = predict(poly_reg, newdata = dataset)),
            colour='blue') +
  xlab('Level') + ylab('Salary')

# Predict a new result with Polynomial regression
y_pred = predict(poly_reg, newdata = data.frame(Level = 6.5,
                                                Level2 = 6.5^2,
                                                Level3 = 6.5^3,
                                                Level4 = 6.5^4,
                                                Level5 = 6.5^5))


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

rm(list = ls())

## H0: T(x) >= C(x)
## H1: T(x) < C(x)

n.c <- 9
n.t <- 9

(n <- n.c + n.t)
# 18

(W.t <- sum(1:8) + 18)
# 54

(W.t.mean <- n.t * (n + 1) / 2)
# 85.5

(W.t.var <- n.t * n.c * (n + 1) / 12)
# 128.25

(W.tc <- W.t - n.t * (n.t + 1) / 2)
# 9

(W.tc.mean <- n.t * n.c / 2)
# 40.5

(W.tc.var <- n.t * n.c * (n + 1) / 12)
# 128.25

pnorm((W.tc + 0.5 - W.tc.mean) / sqrt(W.tc.var))
# 0.00309665908702214

pwilcox(W.tc, n.t, n.c)
# 0.00199506375976964

## We'll reject H0 due to there aren't enough evidences in favor of T >= C,
## so we assume that T < C


dat = read.table(file="cookies.dat", header=TRUE)

table(dat$location)

hist(dat$chips)

boxplot(chips ~ location, data=dat)

set.seed(112)
n_sim = 500 #number of monti carlo samples
alpha_pri = rexp(n_sim, rate=1.0/2.0) # draw for alpha prior from exponential dist
beta_pri = rexp(n_sim, rate=5.0) # draw beta prior from exp
mu_pri = alpha_pri/beta_pri # simulate mean of lambda
sig_pri = sqrt(alpha_pri/beta_pri^2) # standard dev

summary(mu_pri) # shows lambda of gamma (gamma decides how correlated our groups are)

summary(sig_pri) # SD of gamma

lam_pri = rgamma(n=n_sim, shape=alpha_pri, rate=beta_pri) # sample from gamma to get lambda distribution, to tighten values then we could modify prior to be gamma dists
summary(lam_pri)

y_pri = rpois(n_sim, lam_pri)
summary(y_pri)

lam_pri = rgamma(n=5, shape=alpha_pri[1:5], rate=beta_pri[1:5])

y_pri = rpois(n=150, lambda=rep(lam_pri, each=30))

library("rjags")

# place priors on mean and SD of gamma distribution, using informative priors

mod_string = " model {
for (i in 1:length(chips)) {
  chips[i] ~ dpois(lam[location[i]])
}

for (j in 1:max(location)) {
  lam[j] ~ dgamma(alpha, beta)
}

alpha = mu^2 / sig^2
beta = mu / sig^2

mu ~ dgamma(2.0, 1.0/5.0)
sig ~ dexp(1.0)

} "

set.seed(113)

data_jags = as.list(dat)

params = c("lam", "mu", "sig")

mod = jags.model(textConnection(mod_string), data=data_jags, n.chains=3)
update(mod, 1e3)

mod_sim = coda.samples(model=mod,
                       variable.names=params,
                       n.iter=5e3)
mod_csim = as.mcmc(do.call(rbind, mod_sim))

## convergence diagnostics
plot(mod_sim)

gelman.diag(mod_sim)
autocorr.diag(mod_sim)
autocorr.plot(mod_sim)
effectiveSize(mod_sim)

## compute DIC
dic = dic.samples(mod, n.iter=1e3)

## observation level residuals
(pm_params = colMeans(mod_csim))

yhat = rep(pm_params[1:5], each=30)
resid = dat$chips - yhat
plot(resid)

plot(jitter(yhat), resid)

var(resid[yhat<7])

var(resid[yhat>11])

## location level residuals
lam_resid = pm_params[1:5] - pm_params["mu"]  # mu is the global eatimate for lambda (number of chips in cookies globally)
plot(lam_resid)
abline(h=0, lty=2)

summary(mod_sim)

n_sim = nrow(mod_csim)

lam_pred = rgamma(n=n_sim, shape=mod_csim[,"mu"]^2/mod_csim[,"sig"]^2,
                  rate=mod_csim[,"mu"]/mod_csim[,"sig"]^2)
hist(lam_pred)# prediction of lambda for new locations

mean(lam_pred > 15) # probability the new location's lambda is > 15

y_pred = rpois(n=n_sim, lambda=lam_pred)
hist(y_pred) # posterior distribution of the number of chips per cookies of new lcations

mean(y_pred > 15)

hist(dat$chips)

y_pred1 = rpois(n=n_sim, lambda=mod_csim[,"lam[1]"]) # use lambda for location 1
hist(y_pred1) # posterior predictive dist for number of chips for a future cookie in location 1

mean(y_pred1 < 7) # prob the next cookie will have less than 7 chips


#!/usr/bin/Rscript

require(deSolve)

## =======================================================================
## Example: Analytical and numerical solutions of logistic growth
## =======================================================================

## the derivative of the logistic
logist <- function(t, x, parms) {
  with(as.list(parms), {
    dx <- r * x[1] * (1 - x[1]/K)
    list(dx)
  })
}

time  <- 0:100
N0    <- 0.1; r <- 0.5; K <- 100
parms <- c(r = r, K = K)
x <- c(N = N0)

## analytical solution
plot(time, K/(1 + (K/N0-1) * exp(-r*time)), ylim = c(0, 120),
  type = "l", col = "red", lwd = 2)

## reasonable numerical solution with rk4
time <- seq(0, 100, 2)
out <- as.data.frame(rk4(x, time, logist, parms))
points(out$time, out$N, pch = 16, col = "blue", cex = 0.5)

## same time step with euler, systematic under-estimation
time <- seq(0, 100, 2)
out <- as.data.frame(euler(x, time, logist, parms))
points(out$time, out$N, pch = 1)

## unstable result
time <- seq(0, 100, 4)
out <- as.data.frame(euler(x, time, logist, parms))
points(out$time, out$N, pch = 8, cex = 0.5)

## method with automatic time step
out <- as.data.frame(lsoda(x, time, logist, parms))
points(out$time, out$N, pch = 1, col = "green")

legend("bottomright",
  c("analytical","rk4, h=2", "euler, h=2",
    "euler, h=4", "lsoda"),
  lty = c(1, NA, NA, NA, NA), lwd = c(2, 1, 1, 1, 1),
  pch = c(NA, 16, 1, 8, 1),
  col = c("red", "blue", "black", "black", "green"))


#' Coefficient of variation (CV)
#'
#' @description Coefficient of variation
#'
#' @param x numeric vector
#' @param perc as percentage (default = T)
#'
#' @return Coefficient of variation
#' @export
#'
#' @examples
#'
#' x <- rnorm(100,1)
#'
#' cv(x)
#'

cv <- function(x, perc = TRUE){

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

  if(!is.logical(perc)){
    stop("perc must be logical.")
  }

  mu_x <- mean(x, na.rm = TRUE)

  if(is.na(mu_x)){
    return(NA_real_)
  }else{

    if(mu_x == 0){
      warning("mean = 0 -> cv is NaN.")
    }

    if(perc == T){
      out <- 100*sd(x, na.rm = TRUE)/mu_x
    } else{
      out <- sd(x, na.rm = TRUE)/mu_x
    }

    out <- abs(round(out,2))

    return(out)
  }

}


p_grid <- seq(from=0, to=1, length.out=1000)
prob_p <- rep(1, 1000)
prob_data <- dbinom(6, size=9, prob=p_grid)
posterior <- prob_data * prob_p
posterior <- posterior / sum(posterior)

set.seed(100)
samples <- sample(p_grid, prob=posterior, size=1e4, replace=TRUE)

# 3E1
sum(samples < .2) / 1e4
# [1] 4e-04

# 3E2
sum(samples > .8) / 1e4
# [1] 0.1116

# 3E3
sum(samples > .2 & samples < .8) / 1.e4
# [1] 0.888

# 3E4
quantile(samples, .2)
# 20%
# 0.5185185

# 3E5
quantile(samples, .8)
#       80%
# 0.7557558

# 3E6
HPDI(samples, prob=.66)
#     |0.66     0.66|
# 0.5085085 0.7737738

# 3E7
PI(samples, prob=.66)
#       17%       83%
# 0.5025025 0.7697698

# 3M1
p_grid <- seq(from=0, to=1, length.out=1000)
p_prior <- rep(1, 1000)
likelihood <- dbinom(8, size=15, prob=p_grid)
posterior <- likelihood * p_prior
posterior <- posterior / sum(posterior)

# 3M2
samples <- sample(p_grid, 1e4, replace=TRUE, prob=posterior)
HPDI(samples, .9)
#      |0.9      0.9|
# 0.3293293 0.7167167

# 3M3
# Weighted by the posterior samples.
w <- rbinom(1e4, size=15, prob=samples)

table(w)[9] / 1e4
#      8
# 0.1483

# 3M4
# So I've got this posterior distribution of `p`.
# That's actually not related to the size of the trial.
# Let's sample binomially, randomly, at this size, with these parameter
# likelihoods.

# Sample the parameter space (done)
samples <- sample(1e4, p_grid, prob=posterior, replace=TRUE)
# Do a random binomial trial for all of those parameters
w <- rbinom(1e4, size=9, prob=samples)
# Events over event space:
sum(w == 6) / 1e4
# [1] 0.1777

# 3M5
## 3M1*
p_grid <- seq(from=0, to=1, length.out=1000)
p_prior <- rep(1, 1000)
p_prior[1:500] = 0
likelihood <- dbinom(8, size=15, prob=p_grid)

posterior <- p_prior * likelihood
posterior <- posterior / sum(posterior)

## 3M2*
samples <- sample(p_grid, 1e4, prob=posterior, replace=TRUE)
HPDI(samples, prob=.9)
#      |0.9      0.9|
# 0.5005005 0.7107107

## 3M3*
w <- rbinom(1e4, size=15, prob=samples)
mean(w == 8)
# [1] 0.1588

## 3M4*
w <- rbinom(1e4, size=15, prob=samples)
mean(w == 6)
# [1] 0.233

# 3M6
# This seems really suspect. But all the solutions I've been finding are
# using the .7 true probability to get the likelihood.
#
# I found a solution that did a complicated (to me lol) R thing with maps and
# declarative coding using tidyverse stuff
# (https://sr2-solutions.wjakethompson.com/bayesian-inference.html). I didn't
# want to blindly copy-paste that, or go that deep into R yet. Another solution
# did guess and check with a function.
# This is my linear-search solution. It agrees with the fancy R one:

assumed_water_percentage <- .7
prior <- rep(1, 1000)
size <- 1
p_grid <- seq(from=0, to=1, length.out=1000)
p_99_interval <- 1
while (p_99_interval > .05) {
	if (size > 10000) {
		break;
	}

	size <- size + 1
	likelihood <- dbinom(floor(size * assumed_water_percentage), size, p_grid)
	posterior <- likelihood * prior
	posterior <- posterior / sum(posterior)
	samples <- sample(p_grid, 1e4, prob=posterior, replace=TRUE)
	interval <- PI(samples, prob=.99)
	p_99_interval <- interval[2] - interval[1]
}

size
# 2169
# I still don't understand why it's reasonable to choose .7 as the binomial
# probability for the simulation?
#
# What is this problem trying to teach? Strategies for simulation?

# 3H1
# Birth probability, we will model as bionmial.
p_grid <- seq(from=0, to=1, length.out=1000)
num_births <- length(birth1) + length(birth2)
num_boys <- (sum(birth1) + sum(birth2))

prior <- rep(1, length(p_grid))
# Binomial distribution on the total number of boys observed out of the number
# of births.
likelihood <- dbinom(num_boys, size=num_births, prob=p_grid)
posterior <- likelihood * prior
posterior <- posterior / sum(posterior)

# Value for `p` probability of male birth, with maximal posterior density.
p_grid[which.max(posterior)]
#[1] 0.5545546

# 3H2
samples <- sample(p_grid, 1e4, prob=posterior, replace=TRUE)

HPDI(prob= .5, samples)
HPDI(prob= .89, samples)
HPDI(prob= .97, samples)
#      |0.5      0.5|
# 0.5305305 0.5775776

#     |0.89     0.89|
# 0.4994995 0.6106106

#     |0.97     0.97|
# 0.4794795 0.6296296

# 3H3
simulated <- rbinom(1e4, 200, prob=samples)

simplhist(simulated, xlab="binomial trials, randomly performed, with probabilities as weighted samples from the posterior distribution")
# Yup, looks good

# 3H4
# Do the same binomial trial, but only one birth, since we're looking at first
# borns.
simulated <- rbinom(1e4, 200, prob=samples)
dens(simulated)

# Looks like the model is skewed male. Mean birth value is .554 on the model,
# vs .51 in birth1. Birth2 is at .6, inidicating that the second birth skews
# male.
# 3H5
# Second births that followed female first borns
# Recall, male = 1, female = 0, so we can identify sequence female -> male by
# counting 1s in the subtraction.
sequence <- birth2 - birth1
female_after_male <- sum(sequence == 1)

# We want to check the independence of the first/second births.

# Ok damn. I wasn't reading literally.
# Get the number of firstborn girls
female_first_borns <- sum(birth1 == 0)

# Still using our sampled posterior for the random binomial trial.

# So what this says: From the count of female first borns, simulate male birth
# binomial trials. I.e. consider each second birth an event in a binomial trial
# of size female_first_borns.
male_second_birth_simulations <- rbinom(1e4, female_first_borns, prob=samples)
#
median(male_second_birth_simulations)
# 27
chainmode(male_second_birth_simulations)
# [1] 27.1417

# Actual
sum((birth2 - birth1) == 1)
# 39

So our model is underestimating male births after female births.


#' @export
r_squared <- function(X, y){
    y.bar <- mean(y)
    e.hat <- residual(X, y)

    1 - sum(e.hat^2)/sum((y-y.bar)^2)
}

#' @export
adjusted_r_squared <- function(X, y){
    y.bar <- mean(y)
    e.hat <- residual(X, y)
    n <- dim(X)[1]
    k <- dim(X)[2]

    1 - (n-1)*sum(e.hat^2)/((n-k)*sum((y-y.bar)^2))
}

#' @export
r.tilde_squared <- function(X, y){
    y.bar <- mean(y)
    e.tilde <- prediction_error(X, y)

    1 - sum(e.tilde^2)/sum((y-y.bar)^2)
}


#задание 2
print ("task 2")
A <- matrix (c(1,5,13,14,-12,-4,11,-13,9,3,-8,-1,-5,7,0,-11,0,-6,3,13,12,0,4,2,8,6,12,-11,4,10,13,-1,5,0,5,4),6,6)
A
#определитель
det(A) # Определитель A

#задание 4
print ("task 4")
A <- matrix (c(7,-8,2,-5,1,7,-5,-7,3,-7,8,-4,9,5,0,-12,8,8,-10,5,-6,-2,-10,-7,0,1,5,5,12,-1,3,10,5,8,-5,-5),6,6)
A
B <- matrix (c(3,4,-7,-2,-9,-9,-1,-3,2,0,8,5,-5,9,5,0,-4,-2,8,7,0,3,-2,0,-8,-3,0,8,1,8,-2,-3,1,0,-4,-2),6,6)
B
x <- solve(B,A)
print ("x равен")
x

#задание 5
print ("5 task")
a <- c(3,3,-2,1,2,3,-4,0,-1,2,3,3)
b <- c(-2,3,3,1,1,1,0,-1,2,4,-4,2)
p <- c(4,2,2,2,5,1,3,3,0,-3,-2,-1)

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

#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 = "max")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(1,1)) # Задаем целевую функцию:
add.constraint(M, c(2,1), "<=", 20) # Задаем ограничение:
add.constraint(M, c(0.7, 2.1), ">=",30) #

rownames(M) <- c("A", "B") # Называем ограничения в модели М
M # Выводим модель M на экран
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M) # Достигнутый min
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# Значение целевой функции на оптимальном решении


confidence_interval <- function(vector, interval) {
  # Standard deviation of sample
  vec_sd <- sd(vector)
  # Sample size
  n <- length(vector)
  # Mean of sample
  vec_mean <- mean(vector)
  # Error according to t distribution
  error <- qt((interval + 1)/2, df = n - 1) * vec_sd / sqrt(n)
  # Confidence interval as a vector
  ans <- c("lower" = vec_mean - error, "upper" = vec_mean + error)
  return(ans)
}
vector <- c( 29, 30, 53, 75, 89, 34, 21, 12, 58, 84, 92, 117, 115, 119, 109, 115, 134, 253, 289, 287 )
confidence_interval(vector, 0.95)


## 2. Plotting the Residuals ##

library(readr)
williamsburg_north <- suppressMessages(read_csv("williamsburg_north.csv"))
library(dqanswerchecking)
condos_lm_fit <- lm(sale_price ~ gross_square_feet, data = williamsburg_north)

library(ggplot2)
residuals_df <- data.frame(condos_lm_fit$residuals)

ggplot(data = residuals_df, aes(x = condos_lm_fit.residuals)) +
  geom_histogram()

## 4. The t-statistic ##

t_statistic <- (1926.6 - 0) / 169.5

## 5. The p-value ##

p_value <- coef(summary(condos_lm_fit))[, 4][[2]]
reject_null_hypothesis <- TRUE

## 6. Confidence Intervals ##

slope_CI_lower <- condos_lm_fit$coefficients[[2]] - 2 *
  coef(summary(condos_lm_fit))[, 2][[2]]

slope_CI_upper <- condos_lm_fit$coefficients[[2]] + 2 *
  coef(summary(condos_lm_fit))[, 2][[2]]

slope_CI <- confint(condos_lm_fit)[2,]

## 7. Residual Standard Error ##

library(dplyr)
# Add residuals and squared-residuals
williamsburg_north <- williamsburg_north %>%
  mutate(residuals = resid(condos_lm_fit)) %>%
  mutate(resid_squared = residuals^2)
# Compute the residual sum of squares (RSS)
RSS <- williamsburg_north %>%
  summarise(RSS = sum(resid_squared)) %>%
  pull()
# Extract RSS from model output
RSS_from_lm <- deviance(condos_lm_fit)
# Optional: check RSS equality
near(RSS, deviance(condos_lm_fit))
# Manual RSE
RSE <- sqrt(RSS / (nrow(williamsburg_north) - 2))
# Alternate method for RSE
RSE <- sqrt(1 / (nrow(williamsburg_north) - 2) * RSS)
lm_fit_sigma <- sigma(condos_lm_fit)
are_equal <- near(RSE, lm_fit_sigma)

## 8. The R-squared Statistic ##

# Add residuals and squared-residuals
williamsburg_north <- williamsburg_north %>%
  mutate(residuals = resid(condos_lm_fit)) %>%
  mutate(resid_squared = residuals^2)
# Compute the residual sum of squares (RSS)
RSS <- williamsburg_north %>%
  summarise(RSS = sum(resid_squared)) %>%
  pull()
TSS <- sum((williamsburg_north$sale_price -
              mean(williamsburg_north$sale_price))^2)

r_squared <- 1 - RSS/TSS

lm_r_squared <- summary(condos_lm_fit)$r.squared

are_equal <- near(r_squared, lm_r_squared)

adj_r_squared <- summary(condos_lm_fit)$adj.r.squared

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/1. Linear Regression Modeling in R/4. Assessing the Accuracy of the Model.r


# Polynomial Regression

# Importing the dataset
dataset = read.csv('Position_Salaries.csv')
dataset = dataset[2:3] # Select the second column "Level" and the third column "Salary" only

# Splitting the data set into the Training set and Test set
#library(caTools)
#set.seed(123)
#split = sample.split(dataset$Profit, SplitRatio = 0.8)
#training_set = subset(dataset, split == TRUE)
#test_set = subset(dataset, split == FALSE)

# Feature Scaling
# training_set = scale(training_set)
# test_set = scale(test_set)

# Fitting Linear Regression to the dataset
lin_reg = lm(formula = Salary ~ .,
             data = dataset)
summary(lin_reg)

# Fitting Polynomial Regression to the dataset
dataset$Level2 = dataset$Level^2 # Create a new column in which values are the squared "Level" value
dataset$Level3 = dataset$Level^3
dataset$Level4 = dataset$Level^4
poly_reg = lm(formula = Salary ~.,
              data = dataset)
summary(poly_reg)

# Visualizing the Linear Regression results
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             color = 'red') +
  geom_line(aes(x = dataset$Level, y = predict(lin_reg, newdata = dataset)),
            color = 'blue') +
  ggtitle('Truth or Bluff (Linear Regression)') +
  xlab('Level') +
  ylab('Salary')

# Visualizing the Polynomial Regression results
ggplot() +
  geom_point(aes(x = dataset$Level, y = dataset$Salary),
             color = 'red') +
  geom_line(aes(x = dataset$Level, y = predict(poly_reg, newdata = dataset)),
            color = 'blue') +
  ggtitle('Truth or Bluff (Polynomial Rgeression)') +
  xlab('Level') +
  ylab('Salary')

# Predicting a new result with Linear Regression
y_pred = predict(lin_reg, data.frame(Level = 6.5)) # make a simple prediction on value on 6.5

# Predicting a new result with Polynomial Regression
y_pred = predict(poly_reg, data.frame(Level = 6.5,
                                      Level2 = 6.5^2,
                                      Level3 = 6.5^3,
                                      Level4 = 6.5^4)) # make sure the 6.5 value showed in four levels


library(plotly)
library(orca)

#___________________________________________LINE_CHART___________________________________________#

createPlot <- function(fname, title, xlab, ylab, f, a) {
  # calculate points
  xs <- lapply(c(0:100), function(x) x/100)
  ys <- lapply(xs, function(y) f(y,a))
  data <- data.frame(xs, ys)

  # draw line plot
  fig <- plot_ly(data, x = ~xs, y = ~ys, type = 'scatter', mode = 'lines')
  fig <- fig %>% layout(
    title = title,
      xaxis = list(title = xlab, range=c(0,1)),
      yaxis = list(title = ylab, range=c(0,1))
    )

  # use orca to save to file
  orca(fig, file = fname)
}

#_______________________________________________NDF______________________________________________#

# normal distribution function
d <- function(nDoth, alpha) {
  (alpha^2) / (pi * (nDoth^2 * (alpha^2 - 1) + 1)^2)
}

# print plots for different alpha
createPlot(paste("D00.png"), "Normal Distribution Function (alpha=0.0)", "n * h", "D(n, h, 0.0)", d, 0.0)
createPlot(paste("D02.png"), "Normal Distribution Function (alpha=0.2)", "n * h", "D(n, h, 0.2)", d, 0.2)
createPlot(paste("D04.png"), "Normal Distribution Function (alpha=0.4)", "n * h", "D(n, h, 0.4)", d, 0.4)
createPlot(paste("D06.png"), "Normal Distribution Function (alpha=0.6)", "n * h", "D(n, h, 0.6)", d, 0.6)
createPlot(paste("D08.png"), "Normal Distribution Function (alpha=0.8)", "n * h", "D(n, h, 0.8)", d, 0.8)
createPlot(paste("D10.png"), "Normal Distribution Function (alpha=1.0)", "n * h", "D(n, h, 1.0)", d, 1.0)

#_____________________________________________FRESNEL____________________________________________#

# fresnel function
f <- function(hDotv, fo) {
  return(fo + (1.0 - fo) * (1 - hDotv)^5)
}

createPlot(paste("F00.png"), "Fresnel Function (F0=0.0)", "h * v", "D(n, h, 0.0)", f, 0.0)
createPlot(paste("F02.png"), "Fresnel Function (F0=0.2)", "h * v", "D(n, h, 0.2)", f, 0.2)
createPlot(paste("F04.png"), "Fresnel Function (F0=0.4)", "h * v", "D(n, h, 0.4)", f, 0.4)
createPlot(paste("F06.png"), "Fresnel Function (F0=0.6)", "h * v", "D(n, h, 0.6)", f, 0.6)
createPlot(paste("F08.png"), "Fresnel Function (F0=0.8)", "h * v", "D(n, h, 0.8)", f, 0.8)
createPlot(paste("F10.png"), "Fresnel Function (F0=1.0)", "h * v", "D(n, h, 1.0)", f, 1.0)

#__________________________________________SURFACE_PLOT__________________________________________#

plotSurfaceContour <- function(fname, title, xlab, ylab, zlab, f, k) {
  # setup helper functions
  normalize <- function(x)    { return(x/100.0)  }
  lambda    <- function(x, y) { return(f(x,y,k)) }

  # setup arrays for x,y,z
  xs <- sapply(c(0:100), normalize)
  ys <- sapply(c(0:100), normalize)
  zs <- outer(xs, ys, lambda)

  # define the surface plot with contours on the x-y plane
  fig <- plot_ly(
    type = 'surface',
    showscale = FALSE,
    contours = list(z = list(show=TRUE, usecolormap=TRUE, project=list(z=TRUE))),
    x = ~xs, y = ~ys, z = ~zs
  )
  fig <- fig %>% layout(
    title = title,
    showlegend=FALSE,
    scene = list(
      camera = list(
        eye=list(x=1.6,y=-1.6,z=0.5)
      ),
      xaxis = list(title = xlab, range=c(0,1)),
      yaxis = list(title = ylab, range=c(0,1)),
      zaxis = list(title = zlab, range=c(0,1.2))
    ))

  # use orca to save to file
  orca(fig, file = fname)
}

#________________________________________GEOMETRY_FUNCTION_______________________________________#

# geometry function
geomSmith <- function(a, k)      { return(a / (a * (1 - k) + k))               }
g         <- function(a1, a2, k) { return(geomSmith(a1, k) * geomSmith(a2, k)) }

# print the different functions
plotSurfaceContour("G00.png","Geometry Function (k=0.0)", "n * v", "n * l", "G(n,v,l)", g, 0.0)
plotSurfaceContour("G02.png","Geometry Function (k=0.2)", "n * v", "n * l", "G(n,v,l)", g, 0.2)
plotSurfaceContour("G04.png","Geometry Function (k=0.4)", "n * v", "n * l", "G(n,v,l)", g, 0.4)
plotSurfaceContour("G06.png","Geometry Function (k=0.6)", "n * v", "n * l", "G(n,v,l)", g, 0.6)
plotSurfaceContour("G08.png","Geometry Function (k=0.8)", "n * v", "n * l", "G(n,v,l)", g, 0.8)
plotSurfaceContour("G10.png","Geometry Function (k=1.0)", "n * v", "n * l", "G(n,v,l)", g, 1.0)


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

w1 <- function(k, dist) {
  return (0.952381 ^ k)
}

kwNN <- function(dataset, points, k, dist = euclidean, weight = w1) {
  answer <- array(dim = c(length(points[,1])))
  classes = unique(iris$Species)

  for (i in 1:length(points[,1])) {
    cat("\rPoint", i, "of", length(points[,1]))
    distance <- array(dim = c(length(dataset[,1])))
    for (j in 1:length(dataset[,1])) {
      distance[j] = dist(points[i, ], dataset[j, 3:4])
    }
    sortedDataset <- dataset[order(distance),]
    distance <- sort(distance)

    scores <- rep(x = 0, times = length(classes))
    names(scores) = classes
    for (j in 1:k) {
      scores[sortedDataset$Species[j]] = scores[sortedDataset$Species[j]] + weight(j, distance[j])
    }

    answer[i] = names(which.max(scores))[1]
  }

  return (answer)
}

par(mfrow=c(1,1), pty="s")

xs <- seq(from = 0.5, to = 7.5, by = 0.2)
ys <- seq(from = -2, to = 5, by = 0.2)

z <- array(dim = c(length(xs) * length(ys), 2))

index <- 1
for (i in xs) {
  for (j in ys) {
    z[index,] <- c(i, j)
    index <- index + 1
  }
}

result <- kwNN(iris, z, 30)

colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green")
plot(iris[, 3:4], bg = colors[paste(iris$Species)], pch=23, asp=1)
points(z[,1], z[,2], col = colors[result], pch = 21)

1 - Nearest neighbors algorithm/kwnn-map.r


A <- matrix(c(-8,1,-2,-20,2,-6,-1,-38,-3,-1,7,-34), 3, 4, byrow = T)
GaussJordan <- function(A) {
  n <- nrow(A)
  m <- ncol(A)
  for(i in 1:n) {
    A[i,] <- A[i, ]/A[i,i]
    for(j in 1:i-1){
      A[j,i:m] <- A[j,i:m] - (A[j,i] * A[i, i:m])
    }
    if (i==n) {
      break
    }
    for(j in i+1:(n-i)){
      A[j,i:m] <- A[j,i:m] - (A[j,i] * A[i, i:m])
    }
  }
  return(A)
}

GaussBackward <- function(A) {
  n <- nrow(A)
  m <- ncol(A)
  print(A)
  for(i in 1:n) {
    x <- A[i,m]
    print(x)
  }
}

##GaussBackward(GaussJordan(A))


deathApprox <- function(m, sd, a) {a*pnorm(1:length(data), mean = m, sd = sd)}
fitDn <- nlsLM(data~deathApprox(m, sd, a), start=list(m=10,sd=2,a=100))

print(summary(fitDn))

l = as.list(coef(fitDn))

peak = l$m
width = l$sd
amplitude = l$a
amplitudeStdErr = summary(fitDn)$coefficients[3,2]
print('Amplitude')
print(amplitude)
print('width')
print(width)
print('peak')
print(peak)
print(peak - length(data))
print(as.Date(startDate) + peak)
print('amplitudeStdErr')
print(amplitudeStdErr)

dataDates = 1:length(data)
dataPerDates = cbind(dataDates, data)
dfData = as.data.frame(dataPerDates)

simuDates = 1:60
simu = pnorm(1:60, mean = peak, sd = width) * amplitude
simuMax = simu*(1 + amplitudeStdErr/amplitude)
simuMin = simu*(1 - amplitudeStdErr/amplitude)
dSimu = dnorm(1:60, mean = peak, sd = width) * amplitude * 10
dSimuMax = dSimu*(1 + amplitudeStdErr/amplitude)
dSimuMin = dSimu*(1 - amplitudeStdErr/amplitude)
simuPerDates = cbind(simuDates, simu, simuMin, simuMax, dSimu, dSimuMin, dSimuMax)
dfSimu = as.data.frame(simuPerDates)

m <- merge(dfSimu, dfData, all.x=T, by=c(1))
m$simuDates <- as.Date(m$simuDates, origin = startDate)

#g <- ggplot(m, aes(x=simuDates))+geom_line(aes(y=simu))+geom_line(aes(y=simuMin, color = 'red'))+geom_line(aes(y=simuMax, color = 'blue'))
g <- ggplot(m, aes(x=simuDates))+geom_point(aes(y=data, color='Real Data'), col="steelblue", size=2)+
  geom_line(aes(y=simu))+
  geom_line(aes(y=simuMin, color = 'Simu. Min.'))+
  geom_line(aes(y=simuMax, color = 'Simu. Max.'))+
  scale_x_date(date_minor_breaks = "1 day", breaks = "7 day",
               labels = scales::date_format("%m-%d"),
               sec.axis = sec_axis(trans = ~ .,
               labels = scales::date_format("%m-%d")))+
               geom_vline(xintercept = as.Date(startDate)+peak, colour = "darkGrey") +
  geom_text(aes(x=as.Date(startDate)+peak, label="\nDecrease", y=1000), colour="blue", angle=90, text=element_text(size=10)) +
  geom_text(aes(x=as.Date(startDate)+peak, label="Increase\n", y=1000), colour="red", angle=90, text=element_text(size=10))

print(g)


#задание 3
print ("task 3")
A <- matrix (c(9,-1,3,5,4,-9,18,-3,8,-2,-3,8,1,-8,-12,1,-9,7,-13,7,-8,-9,-9,-4,-7,-2,5,-2,20,-2,9,2,-4,-6,-1,-6),6,6)
A
#определитель
det(A) # Определитель A

#задание 5
print ("5 task")
a <- c(-1,2,-3,1,-2,3,0,4,-1,1,2,2)
b <- c(1,4,5,3,2,2,-1,-3,0,1,3,3)
p <- c(2,0,3,1,-2,4,4,0,2,-5,1,2)

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

#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(1,5)) # Задаем целевую функцию:
add.constraint(M, c(-2,4), ">=", -4) # Задаем ограничение:
add.constraint(M, c(-2, -3), "<=",-4) #
add.constraint(M, c(-2, 1), "<=",2) #

rownames(M) <- c("A", "B","C") # Называем ограничения в модели М
M # Выводим модель M на экран
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M) # Достигнутый min
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# Значение целевой функции на оптимальном решении


## simple interactive edge finding using locator()

pupil.pars <- function(im=NULL, obstructed=FALSE) {
	if (!is.null(im))
		image(1:nrow(im), 1:ncol(im), im, col=grey256, asp=1, xlab="", ylab="", useRaster=TRUE)
	cat("click on edge of pupil; right click to exit\n")
	flush.console()
	edge <- locator(type="p", col="green")
	x <- edge$x
	y <- edge$y
	el <- lm(x^2+y^2 ~ x + y + I(y^2))
	asp2 <- 1 - coef(el)[4]
	xc <- coef(el)[2]/2
	yc <- coef(el)[3]/(2*asp2)
	rx <- sqrt(coef(el)[1] + xc^2 + yc^2*asp2)
	ry <- rx / sqrt(asp2)
	if ((abs(rx-ry)/rx < 0.05) || (summary(el)$coefficients[4,4]>0.01)) {
		el <- update(el, ~ . - I(y^2))
		xc <- coef(el)[2]/2
		yc <- coef(el)[3]/2
		rx <- sqrt(coef(el)[1] + xc^2 + yc^2)
		ry <- rx
	}
	obstruct <- 0
	if (obstructed) {
		cat("click on edge of obstruction; right click to exit\n")
		flush.console()
		edge <- locator(type="p", col="green")
		is (!is.null(edge))
			obstruct <- sqrt(mean((edge$x-xc)^2+(edge$y-yc)^2*(rx/ry)^2))/rx
	}
	x.e <- seq(-rx,rx, length=101)
	y.e <- ry * sqrt(1 - (x.e/rx)^2)
	points(x.e+xc, y.e + yc, type='l', lty=1,col='green')
	y.e <- -y.e
	points(x.e+xc, y.e + yc, type='l', lty=1, col='green')
	if (obstruct > 0) {
		x.e <- obstruct * x.e
		y.e <- obstruct * y.e
		points(x.e+xc, y.e + yc, type='l', lty=1,col='green')
		y.e <- -y.e
		points(x.e+xc, y.e + yc, type='l', lty=1, col='green')
	}

	list(xc=xc, yc=yc, rx=rx, ry=ry, obstruct=obstruct)

}

## partial implementation of canny algorithm for edge detection
##
## arguments:
## im - the image to process
## fw - smoothing parameter for gaussian blur (pixels)
## qt - threshold for accepting a point as a candidate edge point.
## excl - number of pixels around edge to exclude. must be >= 1.
## plots - plot some intermediate results?
## details - return some extra data for testing purposes.

## there are many online references. Search "canny edge detection" or "canny algorithm".

circle.pars <- function(im, fw=2, qt=0.995, excl=5,
                        plots=TRUE, details=FALSE) {
  nr <- nrow(im)
  nc <- ncol(im)
  if (fw > 0) {
    im <- gblur(im, fw)
  }
  if (excl < 1) {
    excl <- 1
  }
  kern.sobel <- rbind(c(-1,-2,-1),c(0,0,0),c(1,2,1))
  gx <- convolve2d(im, kern.sobel)
  gy <- convolve2d(im, t(kern.sobel))
  modg <- sqrt(gx^2+gy^2)
  modg <- modg/max(modg)
  dirg <- atan2(gy, gx)

  # round off directions to 45 degrees

  dir <- dirg
  dir[abs(dirg) < 7*pi/8] <- (round(dirg[abs(dirg) < 7*pi/8]*4/pi))
  dir[abs(dirg) >= 7*pi/8] <- 0
  dir[dir < 0] <- 4+dir[dir<0]

  # find local maxima

  maxima <- NULL

  for (i in 0:3) {
    ptsi <- which(dir==i, arr.ind=TRUE)
    ed <- which(ptsi[,1] <= excl)
    ed <- c(ed, which(ptsi[,1] >= nr-excl+1))
    ed <- c(ed, which(ptsi[,2] <= excl))
    ed <- c(ed, which(ptsi[,2] >= nc-excl+1))
    if (length(ed) > 0) {
      ptsi <- ptsi[-ed,]
    }
    nb <- switch(i+1, c(1,0), c(1,1), c(0,1), c(1, -1))
    ptsp <- t(t(ptsi)+nb)
    ptsm <- t(t(ptsi)-nb)
    lm <- which((modg[ptsi] > modg[ptsp]) & (modg[ptsi] > modg[ptsm]))
    maxima <- rbind(maxima, ptsi[lm,])
  }

  # the thinned edges consist of the local maxima in the direction of gradient

  thin <- matrix(0, nr, nc)
  thin[maxima] <- modg[maxima]
  if (plots) {
    image(1:nr, 1:nc, thin, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE)
  }

  # the rest differs from published algorithm description. I'm just picking
  # edge candidates from top qt %-ile, and feeding them to
  # nlrob from package robustbase if available or
  # lqs -- "robust" least squares routine. This is basically what I did
  # before.

  ec <- which(modg[maxima] >= quantile(modg[maxima], probs=qt))
  maxima <- maxima[ec,]
  x <- maxima[,1]
  y <- maxima[,2]
  if (require(robustbase)) {
    df <- data.frame(x=x, y=y)
    ecm <- nlrob(0 ~ r^2 - (x-xc)^2 - (y-yc)^2, data=df,
                 start=list(r=min(nr,nc)/2, xc=nr/2, yc=nc/2))
    xc <- coef(ecm)['xc']
    yc <- coef(ecm)['yc']
    rxy <- coef(ecm)['r']
  } else {
    require(MASS)
    r2 <- x^2 + y^2
    ecm <- lqs(r2~x+y)
    xc <- coef(ecm)[2]/2
    yc <- coef(ecm)[3]/2
    rxy <- sqrt(coef(ecm)[1]+xc^2+yc^2)
  }
#   if (refine > 0) {
#     xr <- (1:nr)-xc
#     yr <- (1:nc)-yc
#     rhod <- round(outer(xr, yr, function(x,y) sqrt(x^2+y^2)))
#     edgec <- which(abs(rhod-rxy) <= refine, arr.ind=TRUE)
#     ec <- which(thin[edgec] > 0)
#     edgec <- edgec[ec,]
#     x <- edgec[,1]
#     y <- edgec[,2]
#     ecm <- nls(0 ~ r^2-(x-xc)^2-(y-yc)^2, start=list(r=rxy, xc=xc, yc=yc),
#                weights=thin[edgec]^2)
#     xc <- coef(ecm)['xc']
#     yc <- coef(ecm)['yc']
#     rxy <- coef(ecm)['r']
#   }

  if (plots) {
    points(xc, yc, pch=20, col="red")
    points(x,y, pch=20, col="green")
    symbols(xc, yc, circles=rxy, inches=FALSE, add=TRUE, fg="red")
  }
  if (details) {
    finaledge <- cbind(x,y)
    list(cp=list(xc=xc, yc=yc, rx=rxy, ry=rxy, obstruct=0),
         gx=gx, gy=gy, modg=modg, dirg=dirg,
         thin=thin, maxima=maxima, finaledge=finaledge, dir_edge=dirg[finaledge],
         lsfit=ecm)
  } else {
    list(xc=xc, yc=yc, rx=rxy, ry=rxy, obstruct=0)
  }
}


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

rm(list = ls())

y <- c(40, 24, 16, 14, 6)
n <- sum(y)

# a)
(e1 <- c(dpois(0:3, lambda = 1), 1 - ppois(3, lambda = 1)) * n)
(Q1 <- sum((y - e1) ^ 2 / e1))
(pvalue1 <- 1 - pchisq(Q1, df = length(y) -1))

## b)

(e2 <- c(dpois(0:2, lambda = 1), 1 - ppois(2, lambda = 1)) * n)
(y2 <- c(y[1:(length(y) - 2)], y[length(y) - 1] +  y[length(y)]))
(Q2 <- sum((y2 - e2) ^ 2 / e2))
(pvalue1 <- 1 - pchisq(Q2, df = length(y2) -1))

## c)

(e3 <- c(dpois(0:1, lambda = 1), 1 - ppois(1, lambda = 1)) * n)
(y3 <- c(y[1:(length(y) - 3)], sum(y[(length(y) - 2):length(y)])))
(Q3 <- sum((y3 - e3) ^ 2 / e3))
(pvalue3 <- 1 - pchisq(Q3, df = length(y3) - 1))

sapply(1:15, function(i) {
  y <- c(dnbinom(0:i, size = 2, prob = 2/3), 1 - pnbinom(i, size = 2, prob = 2 / 3))
  e <- c(dpois(0:i, lambda = 1), 1 - ppois(i, lambda = 1))
  Q <- 100 * sum((y - e) ^ 2 / e)

  power <- 1 - pchisq(qchisq(1 - 0.05, df = i - 1), df = i - 1, ncp = Q)
  return(power)
})

i <- 4
y <- c(dnbinom(0:i, size = 2, prob = 2/3), 1 - pnbinom(i, size = 2, prob = 2 / 3))
e <- c(dpois(0:i, lambda = 1), 1 - ppois(i, lambda = 1))

fn <- function(n) {
  Q <- n * sum((y - e) ^ 2 / e)
  1 - pchisq(qchisq(1 - 0.05, df = i - 1), df = i - 1, ncp = Q)
}

uniroot(function(n) {0.9 - fn(n)}, c(1, 300))


#################################
# Example of Rejection Sampling
#################################

library(ggplot2)

# Define nasty function
f <- function(x){ x^2/exp(x)}
x <- seq(0,10,0.01)

xmin <- 0
xmax <- 10

C <- 15 # garantees that envelope is always higher than f
# Sample from envelop distribution
renvelope <- function(n){runif(n,xmin,xmax)}
denvelope <- function(x){C*dunif(x,xmin, xmax)}

df <- data.frame(x=x, f=f(x), q=denvelope(x))
gg <- ggplot(df, aes(x=x)) +
      geom_line(aes(y=f, color="real")) +
      geom_line(aes(y=q, color="envelop")) +
      theme(legend.title=element_blank()) +
      ggtitle("real and envelop distribution")
print(gg)

nsamples <- 10000

# Sample from envelop distribution
samples <- renvelope(nsamples)

# Sample from uniform distribution
u <- runif(nsamples)

accept <- u < f(samples)/denvelope(samples)
accept <- as.numeric(accept)

df = data.frame(sample = samples, accept = factor(accept, levels= c(1,0)))

gg<- ggplot(df, aes(x=df$sample)) +
     geom_histogram(aes(fill = accept), binwidth=0.1) +
     ggtitle("Samples")

print(gg)

cat("Acceptance ratio:", sum(accept)/length(accept))


# Chapter 4 Lab: Logistic Regression, LDA, QDA, and KNN

# The Stock Market Data

library(ISLR)
names(Smarket)
dim(Smarket)
summary(Smarket)
pairs(Smarket)
cor(Smarket)
cor(Smarket[,-9])
attach(Smarket)
plot(Volume)

# Logistic Regression

glm.fits=glm(Direction~Lag1+Lag2+Lag3+Lag4+Lag5+Volume,data=Smarket,family=binomial)
summary(glm.fits)
coef(glm.fits)
summary(glm.fits)$coef
summary(glm.fits)$coef[,4]
glm.probs=predict(glm.fits,type="response")
glm.probs[1:10]
contrasts(Direction)
glm.pred=rep("Down",1250)
glm.pred[glm.probs>.5]="Up"
table(glm.pred,Direction)
(507+145)/1250
mean(glm.pred==Direction)
train=(Year<2005)
Smarket.2005=Smarket[!train,]
dim(Smarket.2005)
Direction.2005=Direction[!train]
glm.fits=glm(Direction~Lag1+Lag2+Lag3+Lag4+Lag5+Volume,data=Smarket,family=binomial,subset=train)
glm.probs=predict(glm.fits,Smarket.2005,type="response")
glm.pred=rep("Down",252)
glm.pred[glm.probs>.5]="Up"
table(glm.pred,Direction.2005)
mean(glm.pred==Direction.2005)
mean(glm.pred!=Direction.2005)
glm.fits=glm(Direction~Lag1+Lag2,data=Smarket,family=binomial,subset=train)
glm.probs=predict(glm.fits,Smarket.2005,type="response")
glm.pred=rep("Down",252)
glm.pred[glm.probs>.5]="Up"
table(glm.pred,Direction.2005)
mean(glm.pred==Direction.2005)
106/(106+76)
predict(glm.fits,newdata=data.frame(Lag1=c(1.2,1.5),Lag2=c(1.1,-0.8)),type="response")

# Linear Discriminant Analysis

library(MASS)
lda.fit=lda(Direction~Lag1+Lag2,data=Smarket,subset=train)
lda.fit
plot(lda.fit)
lda.pred=predict(lda.fit, Smarket.2005)
names(lda.pred)
lda.class=lda.pred$class
table(lda.class,Direction.2005)
mean(lda.class==Direction.2005)
sum(lda.pred$posterior[,1]>=.5)
sum(lda.pred$posterior[,1]<.5)
lda.pred$posterior[1:20,1]
lda.class[1:20]
sum(lda.pred$posterior[,1]>.9)

# Quadratic Discriminant Analysis

qda.fit=qda(Direction~Lag1+Lag2,data=Smarket,subset=train)
qda.fit
qda.class=predict(qda.fit,Smarket.2005)$class
table(qda.class,Direction.2005)
mean(qda.class==Direction.2005)

# K-Nearest Neighbors

library(class)
train.X=cbind(Lag1,Lag2)[train,]
test.X=cbind(Lag1,Lag2)[!train,]
train.Direction=Direction[train]
set.seed(1)
knn.pred=knn(train.X,test.X,train.Direction,k=1)
table(knn.pred,Direction.2005)
(83+43)/252
knn.pred=knn(train.X,test.X,train.Direction,k=3)
table(knn.pred,Direction.2005)
mean(knn.pred==Direction.2005)

# An Application to Caravan Insurance Data

dim(Caravan)
attach(Caravan)
summary(Purchase)
348/5822
standardized.X=scale(Caravan[,-86])
var(Caravan[,1])
var(Caravan[,2])
var(standardized.X[,1])
var(standardized.X[,2])
test=1:1000
train.X=standardized.X[-test,]
test.X=standardized.X[test,]
train.Y=Purchase[-test]
test.Y=Purchase[test]
set.seed(1)
knn.pred=knn(train.X,test.X,train.Y,k=1)
mean(test.Y!=knn.pred)
mean(test.Y!="No")
table(knn.pred,test.Y)
9/(68+9)
knn.pred=knn(train.X,test.X,train.Y,k=3)
table(knn.pred,test.Y)
5/26
knn.pred=knn(train.X,test.X,train.Y,k=5)
table(knn.pred,test.Y)
4/15
glm.fits=glm(Purchase~.,data=Caravan,family=binomial,subset=-test)
glm.probs=predict(glm.fits,Caravan[test,],type="response")
glm.pred=rep("No",1000)
glm.pred[glm.probs>.5]="Yes"
table(glm.pred,test.Y)
glm.pred=rep("No",1000)
glm.pred[glm.probs>.25]="Yes"
table(glm.pred,test.Y)
11/(22+11)


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

rm(list = ls())

a <- c(6.0, 5.8, 6.5, 6.3)

n.a <- length(a)
# 4

b <- c(7.3, 6.6, 7.1)

n.b <- length(b)
# 3

A <- matrix(rep(0, n.a * n.b), n.a, n.b)
for(i in 1:n.a) {
  for(j in 1:n.b) {
    A[i, j] <- a[i] - b[j]
  }
}
median(A)
# -0.8

alpha <- 0.1

## Resampling method (not equal results)
fn <- function(a, b, n.a, n.b) {
  a.resampled <- sample(a, n.a, replace = TRUE)
  b.resampled <- sample(b, n.b, replace = TRUE)
  A <- matrix(rep(0, n.a * n.b), n.a, n.b)
  for(i in 1:n.a) {
    for(j in 1:n.b) {
      A[i, j] <- a.resampled[i] - b.resampled[j]
    }
  }
  return(median(A))
}
quantile(replicate(1000, fn(a, b, n.a, n.b)), c(alpha / 2, 1 - alpha / 2), names = FALSE)
# -1.3, -0.45

## Exact Method
sort(A)[c(qwilcox(alpha / 2, n.a, n.b), qwilcox(1 - alpha / 2, n.a, n.b) + 1)]
# -1.5 -0.1

## Function
wilcox.test(a, b, alternative = "two.sided", conf.int = TRUE, conf.level = 0.9)
# Wilcoxon rank sum test
#
# data:  a and b
# W = 0, p-value = 0.05714
# alternative hypothesis: true location shift is not equal to 0
# 90 percent confidence interval:
#  -1.5 -0.1
# sample estimates:
# difference in location
#                   -0.8


# Parameters
mean = 100 * 1000 # 100KB mean
shape = 1.05 # 1.05 shape

# Calculate scale
scale = (mean * (shape - 1)) / shape

# Pareto distribution function
pareto_cdf <- function(x) {
  1 - (scale / x)^shape
}

# Calculate data points for the plot
x = c(
  seq(1e-8, 1e-7, 1e-10),
  seq(1e-7, 1e-6, 1e-9),
  seq(1e-6, 1e-5, 1e-8),
  seq(1e-5, 1e-4, 1e-7),
  seq(1e-4, 1e-3, 1e-6),
  seq(1e-3, 1e-2, 1e-5),
  seq(1e-2, 1e-1, 1e-4),
  seq(1e-1, 1e0, 1e-3),
  seq(1e0, 1e1, 1e-2),
  seq(1e1, 1e2, 1e-1),
  seq(1e2, 1e3, 1e0),
  seq(1e3, 1e4, 1e1),
  seq(1e4, 1e5, 1e2),
  seq(1e5, 1e6, 1e3),
  seq(1e6, 1e7, 1e4),
  seq(1e7, 1e8, 1e5),
  seq(1e8, 1e9, 1e6),
  seq(1e9, 1e10, 1e7),
  seq(1e10, 1e11, 1e8)
)
y = pareto_cdf(x)

# Plot without axis or functions
plot(x, y,
     log="x",
     xlim=c(4761.9, 10e8),
     ylim=c(0, 1),
     type="l"
)

# Create data frame, filter out under zero (x > x_m)
df = data.frame(x, y)
df = df[df$y >= 0,]

# Write to result file
write.table(df, "fs_pareto_s_1.05_mu_100KB_cdf.txt", sep="\t", col.names = FALSE, row.names = FALSE)


library(data.table)
library(ggplot2)
library(here)
library(boot) # alternate to verify long-hand calcs

data.dir <- paste0(here::here(), "/datasets/")

# gamma example

my.sample <- rgamma(16, 1, 1/2)
N <- 10e5

my.boot <- numeric(N)

for(i in 1:N)
{
  x <- sample(x = my.sample, size = length(my.sample), replace = T)
  my.boot[i] <- mean(x)
}

ggplot(data.table(value = my.sample), aes(value, fill = ..count..)) +
  geom_histogram(bins = 8)

ggplot(data.table(value = my.boot), aes(value, fill = ..count..)) +
  geom_histogram(bins = 30)

mean(my.boot)
sd(my.boot)

### Bangladesh

Bangladesh <- data.table(read.csv(paste0(data.dir, "Bangladesh.csv"),
                                  header = T))

Arsenic <- Bangladesh$Arsenic

mean(Arsenic) #  sample mean

ggplot(data.table(value = Arsenic)) +
  geom_histogram(aes(value, fill = ..count..), bins = 30) +
  scale_x_continuous(labels = comma) +
  labs(title = "Arsenic")

ggplot(data.table(value = Arsenic), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Arsenic")

n <- length(Arsenic)
N <- 10e3

arsenic.mean <- numeric(N)

for(i in 1:N)
{
  x <- sample(Arsenic, n, replace = T)
  arsenic.mean[i] <- mean(x)
}

ggplot(data.table(value = arsenic.mean)) +
  geom_histogram(aes(value, fill = ..count..), bins = 30) +
  geom_vline(xintercept = mean(arsenic.mean), col = "darkorange", alpha = .6, lwd = 2) +
  scale_y_continuous(labels = comma) +
  labs(title = "Arsenic Bootstrap Distribution of Means")

ggplot(data.table(value = arsenic.mean), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Arsenic")

mean(arsenic.mean) # Bootstrap mean
mean(arsenic.mean) - mean(Arsenic) # bias
sd(arsenic.mean) # bootstrap SE

# this is not accurate: CLT cannot be used here
lq <- mean(arsenic.mean) - 1.96 * sd(arsenic.mean)
uq <- mean(arsenic.mean) + 1.96 * sd(arsenic.mean)

sum(arsenic.mean < lq) / N
sum(arsenic.mean > uq) / N

alpha <- .05
quantile(arsenic.mean, c(alpha/2, 1 - alpha/2)) # confidence intervals

boot.fn <- function(data, index) {
  mean(data[index])
}

arsenic.boot <- boot(Arsenic, boot.fn, R = N)

### NC birth weights

NCBirths <- data.table(read.csv(paste0(data.dir, "NCBirths2004.csv"),
                                header = T))

weights <- NCBirths$Weight

boot.fn <- function(data, index) {
  mean(data[index])
}

bw.boot <- boot(weights, boot.fn, R = 1000)

# long-hand

N <- 1e5
bw.mean <- numeric(N)

for(i in 1:N)
{
  x <- sample(weights, size = length(weights), replace = T)
  bw.mean[i] <- mean(x)
}

alpha <- 0.05
conf <- quantile(bw.mean, c(Lower = alpha/2, Upper = 1 - alpha/2))

# NC Birth weights, bootstrapped

ggplot(data.table(values = bw.mean), aes(values)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = mean(weights), col = "darkorange", alpha = .4, lwd = 1) +
  geom_vline(xintercept = conf[1], col = "cornflowerblue") +
  geom_vline(xintercept = conf[2], col = "cornflowerblue") +
  geom_rug(col = "darkred") +
  scale_x_continuous(labels = scales::comma) +
  scale_y_continuous(labels = scales::comma)

### testosterone study

Skateboard <- data.table(read.csv(paste0(data.dir, "Skateboard.csv"),
                                  header = T))

testF <- Skateboard[Experimenter == "Female"]$Testosterone
testM <- Skateboard[Experimenter == "Male"]$Testosterone

nf <- length(testF)
nm <- length(testM)

N <- 10e4
TestMean <- numeric(N)

for(i in 1:N)
{
  sampleF <- sample(testF, nf, replace = T)
  sampleM <- sample(testM, nm, replace = T)

  TestMean[i] <- mean(sampleF) - mean(sampleM)
}

ggplot(data.table(result = TestMean), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = mean(testF) - mean(testM), col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  labs(title = "Bootstrap distribution of difference in means")

ggplot(data.table(value = TestMean), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Testosterone")

# bootstrap statistics

mean(testF) - mean(testM)
mean(TestMean)

sd(TestMean)

quantile(TestMean, c(0.025, .975)) # confidence intervals

mean(TestMean) - ( mean(testF - mean(testM)) ) # bias

observed <- mean(testF) - mean(testM)

result <- numeric(N)

for(i in 1:N)
{
  index <- sample(nf + nm, nf, replace = F)
  result[i] <- mean(Skateboard[index]$Testosterone) - mean(Skateboard[-index]$Testosterone)
}

p <- (sum(result >= observed) + 1) / (N + 1)

ggplot(data.table(result), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = observed, col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  labs(title = "Permutation Test: Difference in means")

ggplot(data.table(value = result), aes(sample = value)) +
  stat_qq() +
  stat_qq_line() +
  labs(title = "Testosterone Permutation Test")

### Verizon data

# Is the average repair time lower for ILEC lower than CLEC customers?

Verizon <- data.table(read.csv(paste0(data.dir, "Verizon.csv"),
                               header = T))

Time.ILEC <- Verizon[Group == "ILEC"]$Time
Time.CLEC <- Verizon[Group == "CLEC"]$Time

observed <- mean(Time.ILEC) - mean(Time.CLEC)

ggplot(data.table(values = Time.ILEC), aes(values)) +
  geom_histogram(aes(y = ..density.., fill = ..count..), bins = 30) +
  geom_density(aes(y = ..density..), col = "darkorange")

ggplot(data.table(values = Time.CLEC), aes(values)) +
  geom_histogram(aes(y = ..density.., fill = ..count..), bins = 30) +
  geom_density(aes(y = ..density..), col = "darkorange")

# bootstrap difference in means

set.seed(123)

N <- 10e4
results <- numeric(N)

N.ILEC <- length(Time.ILEC)
N.CLEC <- length(Time.CLEC)

for(i in 1:N)
{
  ilec <- sample(Time.ILEC, N.ILEC, replace = T)
  clec <- sample(Time.CLEC, N.CLEC, replace = T)

  results[i] <- mean(ilec) - mean(clec)
}

alpha <- 0.05
observed - mean(results) # Bias

sd(results)

quantile(results, c(Lower = alpha/2, Upper = 1 - alpha/2))

aov(Time ~ Group, data = Verizon)

# ratio of means test

observed <- mean(Time.ILEC) / mean(Time.CLEC)

N <- 10e3
time.ratio.mean <- numeric(N)
for(i in 1:N)
{
  ILEC.sample <- sample(Time.ILEC, length(Time.ILEC), replace = T)
  CLEC.sample <- sample(Time.CLEC, length(Time.CLEC), replace = T)

  time.ratio.mean[i] <- mean(ILEC.sample) / mean(CLEC.sample)
}

ggplot(data.table(result), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = observed, col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  labs(title = "Permutation Test: Difference in means")

result <- numeric(N)

for(i in 1:N)
{
  index <- sample(nrow(Verizon), length(Time.CLEC), replace = F)
  result[i] <- mean(Verizon[index]$Time) / mean(Verizon[-index]$Time)
}

observed - mean(time.ratio.mean) # bias
sd(time.ratio.mean) # standard error

quantile(time.ratio.mean, c(0.025, .975))

time.ratio.bias <- mean(time.ratio.mean) - mean(Time.ILEC)/mean(Time.CLEC) # Bias

time.ratio.bias / sd(time.ratio.mean)

# Significance
p <- (sum(result >= observed) + 1) / ( N + 1)

ggplot(data.table(result), aes(result)) +
  geom_histogram(aes(fill = ..count..), bins = 30) +
  geom_vline(xintercept = observed, col = "darkorange", lty = 2, lwd = 1.5, alpha = .4) +
  scale_y_continuous(labels = comma) +
  labs(title = "Permutation Test: Difference in means")


load.packages('quantmod')
load.packages('PerformanceAnalytics')
load.packages('ggplot2')
load.packages('forecast')
load.packages('tseries')
load.packages('FitAR')

data <- new.env()

getSymbols('JPM', src = 'yahoo', env = data, auto.assign = T)

JPM = JPM["2018-02-01/2018-12-30"]
JPM = JPM[, "JPM.Adjusted"]

plot(JPM)

# Calculating the average stock price of JPM
jpm_avg <- sum(JPM)/length(JPM)
jpm_avg

# Calculating the standard deviation of the JPM stock price
jpm_std <- StdDev(JPM)
jpm_std

# Calculating the daily JPM stock return
jpm_log_ret <- diff(log(JPM))
jpm_log_ret

# ---------------- #

getSymbols("^GSPC", src = 'yahoo', env = data, auto.assign = T)

GSPC <- GSPC["2018-02-01/2018-12-30"]
GSPC <- GSPC[, "GSPC.Adjusted"]

two_reg_data <- cbind(JPM, GSPC)

scatter.smooth(x=two_reg_data$JPM.Adjusted, y=two_reg_data$GSPC.Adjusted, main="JPM ~ GSPC", xlab= "JPM Closing Price", ylab= "S&P500 Closing Price")  # scatterplot

# Producing a linear model with S&P500 close prices as the explanatory variable.
linearModel <- lm(JPM.Adjusted ~ GSPC.Adjusted, data = two_reg_data)
summary(linearModel)

# Reading in the CSUSHPINSA monthly data
csushpinsa <- read.csv("https://fred.stlouisfed.org/graph/fredgraph.csv?bgcolor=%23e1e9f0&chart_type=line&drp=0&fo=open%20sans&graph_bgcolor=%23ffffff&height=450&mode=fred&recession_bars=on&txtcolor=%23444444&ts=12&tts=12&width=1168&nt=0&thu=0&trc=0&show_legend=yes&show_axis_titles=yes&show_tooltip=yes&id=CSUSHPINSA&scale=left&cosd=1987-01-01&coed=2019-03-01&line_color=%234572a7&link_values=false&line_style=solid&mark_type=none&mw=3&lw=2&ost=-99999&oet=99999&mma=0&fml=a&fq=Monthly&fam=avg&fgst=lin&fgsnd=2009-06-01&line_index=1&transformation=lin&vintage_date=2019-06-17&revision_date=2019-06-17&nd=1987-01-01")
csushpinsa = csushpinsa$CSUSHPINSA

# Confirm that we now have a simple list of doubles for values
typeof(csushpinsa)

csushpinsa = ts(csushpinsa, start = c(1987,1), frequency = 12)

csushpinsa

# Augmented Dickey-Fuller Test
df <- adf.test(csushpinsa)
df # The p-value of 0.4609 here means that we accept the null hypothesis of non-stationarity

# Using Box-Jenkins to explore the parameters for an ARIMA model
T = length(csushpinsa)

csush0 = csushpinsa[-1]
csush1 = csushpinsa[-T]

lag_csush = cbind(csush0, csush1)

plot(lag_csush, main = "T[x] vs T[x-1] for Case Shiller Index Values")

cor(csush0, csush1)

acf(csushpinsa, lag.max = 20, plot = TRUE) # Linear decay => non-stationary

pacf(csushpinsa, lag.max = 20, plot = TRUE)

d_csush = diff(csushpinsa)
d_csush

plot(d_csush) # More stationary than the original data

acf(d_csush, lag.max = 20, plot = TRUE) # Far quicker decay than the original data
pacf_dcsush <- pacf(d_csush, lag.max = 20, plot = TRUE) # Cuts off after lag 1.

# Using auto-fit to detect best model to use via AIC and MLE minimisation
auto.arima(csushpinsa, trace = TRUE)

# The above suggests ARIMA(3,1,2) with drift. No lower AIC can be found.
model <- arima(csushpinsa, order = c(3, 1, 2))
model

# Determine the confidence intervals for the parameters of the ARIMA(3,1,2) model.
confint(model, level = 0.995)

# Calculate the residuals from the model - checking for goodness-of-fit.
model_resid = resid(model)
model_resid

# Residuals seem relatively stationary.
plot(csushpinsa, model_resid, ylab="Residuals", xlab="Observations")
abline(0,0)

# Residual differentials look a lot like white noise, gaining intensity later on.
resid_diff = diff(model_resid)
plot(resid_diff)

# Residual differentials appear to mostly fall along a normal distribution.
qqnorm(resid_diff)

plot(acf(model_resid), main = "Autocorrelation of ARIMA(3,1,2) Residuals")
plot(pacf(model_resid), main = "Partial autocorrelation of ARIMA(3,1,2) Residuals")

boxresult = LjungBoxTest(model_resid,k=2,lag.max =5,StartLag=1)
plot(boxresult[,3],main= "Ljung-Box Q Test", ylab= "P-values", xlab= "Lag") # All well above 0.05, indicating non-significance.

# Having checked that the residuals appear to be normally distributed, we go on to produce a forecast using the model.
predict(model,n.ahead = 12)
plot(forecast(model,h=12, level=c(99.5)))

# The prediction for April 2019 (one month after the latest data) has:
# Forecast  208.0465, Lo99.5  207.1655, Hi99.5  208.9276.

# Potential exogenous variables to improve forecasting ability: mortgage rate, personal income, delinquency rate on mortgages, home ownership rate.


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

#tendencia linear hold
autoplot(austres)
mdl1 = holt(austres, h=16)
autoplot(mdl1)
mdl1$model

mdl2 = holt(austres,alpha = 0.2,   h=16)
autoplot(mdl2)

#compara as duas previs?es
plot(mdl1)
lines(mdl2$mean, col="red")

#tendencia amortecida
mdl3 = holt(austres,damped = T, phi = 0.9,  h=16)
autoplot(mdl3)

#mudamos phi
mdl4 = holt(austres,damped = T, phi = 0.8,  h=16)
autoplot(mdl4)

#comparar os modelos
plot(mdl3)
lines(mdl4$mean, col="red")

#compara as duas previsoes
print(mdl3$mean)
print(mdl4$mean)

#holt winter - sazonal
#aditivo
mdl5 = hw(JohnsonJohnson,seasonal = "additive", h=16)
autoplot(mdl5)

#multiplicativo
mdl6 = hw(JohnsonJohnson,seasonal = "multiplicative", h=16)
autoplot(mdl6)

#comparar os modelos
plot(mdl5)
lines(mdl6$mean, col="red")

#comparando textual
print(mdl5$mean)
print(mdl6$mean)

#multiplicativo amortecido
mdl7 = hw(JohnsonJohnson,seasonal = "multiplicative", damped = T, phi = 0.9,h=16)
autoplot(mdl7)

#ets
mdl8 = ets(JohnsonJohnson)
print(mdl8)

autoplot(mdl8$residuals)
autoplot(mdl8$fitted)

prev = forecast(mdl8, h=16,levels=c(85,90))
print(prev$mean)
autoplot(prev)

autoplot(decompose(JohnsonJohnson))

mdl9 = ets(JohnsonJohnson, model = "ZAA", damped = T)
print(mdl9)

mdl10 = ets(JohnsonJohnson, model = "ZZZ", damped = T)
print(mdl10)

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/7.2.R Suavizacao Exponencial.r


# Source: https://www.kaggle.com/juejuewang/handle-missing-values-in-time-series-for-beginners
# Author: Nishant Singh - https://www.datacamp.com/profile/NishantKumarSingh

library(imputeTS)

View(tsAirgap)

plot(tsAirgap, main="AirPassenger data with missing values")

statsNA(tsAirgap)

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

# General imputation methods

par(mfrow=c(2,2))
# Mean Imputation
plot(na_mean(tsAirgap, option = "mean") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Mean")
mean((na_mean(tsAirgap, option = "mean") - AirPassengers)^2)

# Median Imputation
plot(na_mean(tsAirgap, option = "median") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Median")
mean((na_mean(tsAirgap, option = "median") - AirPassengers)^2)

# Mode Imputation
plot(na_mean(tsAirgap, option = "mode") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Mode")
mean((na_mean(tsAirgap, option = "mode") - AirPassengers)^2)

# Random Imputation
plot(na_random(tsAirgap) - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Random")
mean((na_random(tsAirgap) - AirPassengers)^2)

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

#TS specific imputation methods

par(mfrow=c(2,2))
# Last Observartion Carried Forward
plot(na_locf(tsAirgap, option = "locf") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "LOCF")
m1 <- mean((na_locf(tsAirgap, option = "locf") - AirPassengers)^2)

# Next Observartion Carried Backward
plot(na_locf(tsAirgap, option = "nocb") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "NOCB")
m2 <- mean((na_locf(tsAirgap, option = "nocb") - AirPassengers)^2)

# Linear Interpolation
plot(na_interpolation(tsAirgap, option = "linear") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Linear")
m3 <- mean((na_interpolation(tsAirgap, option = "linear") - AirPassengers)^2)

# Spline Interpolation
plot(na_interpolation(tsAirgap, option = "spline") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Spline")

m4 <- mean((na_interpolation(tsAirgap, option = "spline") - AirPassengers)^2)

data.frame(methods=c('LOCF', 'NACB', 'Linear', 'Spline'), MSE=c(m1, m2, m3, m4))

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

#Combined imputation approach

par(mfrow=c(2,2))
# Seasonal Adjustment then Random
plot(na_seadec(tsAirgap, algorithm = "random") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> Random")
ma1 <- mean((na_seadec(tsAirgap, algorithm = "random") - AirPassengers)^2)

# Seasonal Adjustment then Mean
plot(na_seadec(tsAirgap, algorithm = "mean") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> Mean")
ma2 <- mean((na_seadec(tsAirgap, algorithm = "mean") - AirPassengers)^2)

# Seasonal Adjustment then LOCF
plot(na_seadec(tsAirgap, algorithm = "locf") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> LOCF")
ma3 <- mean((na_seadec(tsAirgap, algorithm = "locf") - AirPassengers)^2)

# Seasonal Adjustment then Linear Interpolation
plot(na_seadec(tsAirgap, algorithm = "interpolation") - AirPassengers, ylim = c(-mean(AirPassengers), mean(AirPassengers)), ylab = "Difference", main = "Seas-Adj -> Linear")

ma4 <- mean((na_seadec(tsAirgap, algorithm = "interpolation") - AirPassengers)^2)

data.frame(methods=c("Seas-Adj+Random", "Seas-Adj+Mean", "Seas-Adj+LOCF","Seas-Adj+Linear"),
           MSE=c(ma1, ma2, ma3, ma4))


##MLE of Poission#####
pois.mle=function(x){
  n=length(x)
  S.x= sum(x)
  lambda=S.x/n
  lambda
}
#x=rpois(1000,5) # To check
#pois.mle(x)
#########MLE of Negative Binomial, Initial parameters is required###
nb.mle=function(x,z){
  N=length(x)
  r<- z[1]
  p<- z[2]
  xsum=sum(x)
  neg.log.lik=function(y) {
    r=y[1];
    p=y[2];
    if((p<=0)||(p>1)||(r<0)) ans=-Inf else {
    ans= N*r*log(1-p)- N*lgamma(r) +xsum*log(p) + sum(lgamma(x+r))-sum(lgamma(x+1));
    }
    -ans;
  }
  gp<- function(g) {
    r=g[1];
    p=g[2];
    dr<- N*log(1-p)-N*digamma(r)+sum(digamma(x+r));
    dp<- (xsum/p)-(N*r/(1-p));
    -c(dr,dp)
  }

  estimate=optim(par=c(r,p),fn=neg.log.lik, gr=gp, method = "L-BFGS-B", lower = c(1, 1e-8), upper = c(1e9,1-1e-8))
  ans=estimate$par
  list(r=ans[1], p=1-ans[2])
}
#x=rnbinom(1000, 7, 0.3)
#nb.mle(x,c(5, 0.5))

######## MLE of Beta Binomial####
bb.mle=function(x, b0){
  n=b0[1]; a=b0[2]; b=b0[3]
  N=length(x)
  neg.log.lik=function(y) {
    n=y[1];
    a=y[2];
    b=y[3];
    if((n<max(x))||(a<=0)||(b<=0)) ans=-Inf else {
      ans= N*lgamma(n+1)+N*lgamma(a+b)-N*lgamma(a)-N*lgamma(b)-N*lgamma(a+n+b)+sum(lgamma(x+a))+sum(lgamma(n-x+b))-sum(lgamma(x+1))-sum(lgamma(n-x+1));
    };
    -ans;
  }
  gp<- function(z) {
    n=z[1];
    a=z[2];
    b=z[3];
    dn<- N*digamma(n+1)-N*digamma(a+n+b)+sum(digamma(n-x+b))-sum(digamma(n-x+1));
    da<- N*digamma(a+b)-N*digamma(a)-N*digamma(a+n+b)+sum(digamma(x+a));
    db= N*digamma(a+b)-N*digamma(b)-N*digamma(a+n+b)+sum(digamma(n-x+b));
    -c(dn,da,db)
  }
  estimate=optim(par=c(n,a,b),fn=neg.log.lik, gr=gp, method = "BFGS")
  ans=estimate$par
  list(n=ans[1], a=ans[2], b=ans[3])
}
#x=rbbinom(100,10,1,2)
#bb.mle(x,c(max(x)+1, 2,5))

######## MLE of Beta Negative Binomial####
bnb.mle=function(x, b0){  #initial value is required
  r=b0[1]; a=b0[2]; b=b0[3]
  N=length(x)
  neg.log.lik=function(y) {
    r=y[1];
    a=y[2];
    b=y[3];
    if((r<=0)||(a<=0)||(b<=0)) ans=-Inf else {
      ans= N*lgamma(a+r)+N*lgamma(a+b)-N*lgamma(r)-N*lgamma(a)-N*lgamma(b)+sum(lgamma(x+r))+sum(lgamma(x+b))-sum(lgamma(x+1))-sum(lgamma(a+r+b+x));
    };
    -ans;
  }
  gp<- function(z) {
    r=z[1];
    a=z[2];
    b=z[3];
    dr<- N*digamma(a+r)-N*digamma(r)+sum(digamma(r+x))-sum(digamma(a+r+b+x));
    da<- N*digamma(a+r)+N*digamma(a+b)-N*digamma(a)-sum(digamma(a+r+b+x));
    db= N*digamma(a+b)-N*digamma(b)+sum(digamma(b+x))-sum(digamma(a+r+b+x));
    -c(dr,da,db)
  }
  estimate=optim(par=c(r,a,b),fn=neg.log.lik, gr=gp, method = "BFGS")
  ans=estimate$par
  list(r=ans[1], a=ans[2], b=ans[3])
}
## Remark: This code require large sample size. i.e, N.100000
#x=rbnbinom(1000, 2,1,5)
#bnb.mle(x,c(4,2,5))

# x=rbnbinom(100000, 2,1,5)
# bnb.mle(x,c(4,2,5))


## Author: Sergio García Prado

rm(list = ls())

y <- c(160, 140, 40,
        40,  60, 60)
r <- 2
c <- 3

n <- sum(y)
k <- length(y)

LogLikelihood <- function(p, y, k) {
  sum(y[1:(k - 1)] * log(p)) + y[k] * log(1 - sum(p))
}

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

opt <- optim(rep(1 / k, k - 1), NegativeLogLikelihood, y = y, k = k, hessian = TRUE)

(p.hat <- opt$par)
# 0.319974922618424 0.28001526572757 0.0800107004045124 0.0800170070336192 0.120016550720802

(p.hat.var <- solve(opt$hessian))
# 4.351396e-04	-1.792007e-04	-5.119362e-05	-5.120170e-05	-7.680441e-05
# -1.792007e-04	4.032054e-04	-4.480606e-05	-4.481313e-05	-6.722132e-05
# -5.119362e-05	-4.480606e-05	1.471927e-04	-1.280210e-05	-1.920362e-05
# -5.120170e-05	-4.481313e-05	-1.280210e-05	1.472139e-04	-1.920665e-05
# -7.680441e-05	-6.722132e-05	-1.920362e-05	-1.920665e-05	2.112222e-04

LogLikelihoodH0 <- function(theta, ...) {
  r1 <- theta[1]
  c1 <- theta[2]
  c2 <- theta[3]

  LogLikelihood(c(r1 * c1, (1 - r1) * c1, r1 * c2, (1 - r1) * c2, r1 * (1 - c1 - c2)), ...)
}

NegativeLogLikelihoodH0 <- function(...) {
  - LogLikelihoodH0(...)
}
opt.hzero <- optim(rep(1 / (r + c - 2), (r + c - 2)), NegativeLogLikelihoodH0, y = y, k = k)

(LRT <- 2 * (LogLikelihood(p.hat, y, k) - LogLikelihoodH0(opt.hzero$par, y, k)))
# 0.534117133722475

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


# Load dataset
dataset1 <- read.csv("dataset1.csv", row.names=1, quote="")
# Print summary of dataset
summary(dataset1)

# Perform ANOVA analysis
anova_results <- aov(time ~ menu, data=dataset1)
print("Summary of Anova Analysis:")
# Print summary of ANOVA
summary(anova_results)
# Get the p_value of the test
p_value <- summary(anova_results)[[1]]$Pr[[1]]
print(p_value)

if (p_value < 0.05) {  # If p_value < 0.05: reject the null hypothesis
  print("p_value is less than 0.05. Hence the results are not by chance variation and the null hypothesis is rejected. There is significant effect of independent variable menu type on dependent variable access time.")
} else {  # Else accept the null hypothesis
  print("p_value is greater than or equal to 0.05. Hence the results could be by chance variation and we cannot reject the null hypothesis. There is no significant effect of independent variable menu type on dependent variable access time.")
}

# Perform pairwise t-test
pairwise.t.test(dataset1$time, dataset1$menu, p.adjust.method = 'bonferroni')
print("As per the results of the pairwise-t-test, only controlmenu-toolpalette pair has a p_value (0.034) < 0.05. All other pairs have a p_value >= 0.05. This means that there is statistically significant difference in access times between controlmenu and toolpalette but no significant difference in access times between other pairs of menus. To find out which is better between controlmenu and toolpalette, we can have a look at their means:")

# Calculate means within groups
aggregate(dataset1[, "time"], list(dataset1$menu), mean)
print("The mean access time for controlmenu (2.388) is significantly less than the mean access time of toolpalette (2.775). Thus, controlmenu is better than toolpalette in terms of access time.")

# One tailed t-test between controlmenu and toolpalette
controlmenu <- subset(dataset1, menu == "controlmenu")
toolpalette <- subset(dataset1, menu == "toolpalette")
t_test_result <- t.test(controlmenu$time, toolpalette$time, alternative = "less")
p_value <- t_test_result$p.value
print(paste("p_value controlmenu-toolpalette: ", p_value))
if (p_value < 0.05) {
  print("Since p_value < 0.05 we can reject the null hypothesis of the one tailed t-test and conclude that controlmenu has better access times than toolpalette.")
} else {
  print("Since p_value < 0.05 we can reject the null hypothesis of the one tailed t-test and conclude that controlmenu has better access times than toolpalette.")
}

# Visualizations
boxplot(time~menu,
        data=dataset1,
        main="Different boxplots for each menu",
        xlab="Menu",
        ylab="Time",
        frame = FALSE,
        col = c("#DDEDAA", "#F4AC45", "#FFCAB1", "#92BFB1"),
        border="black"
)

# between-within plot
B <- anova(lm(time ~ menu, data = dataset1))$"Mean Sq"
names(B) <- c("between", "within")
barplot(B, main = "Between vs. within", xlab = "Group (Menu)", ylab = "Sum of Squares (Time)", col = c("#DDEDAA", "#F4AC45"))

# f distribution plots
n <- sum(dataset1[, "menu"] == "controlmenu")[[1]]
means <- aggregate(dataset1[, "time"], list(dataset1$menu), mean)[, 2]
cntr <- means - mean(means)
lambda <- n*sum(cntr^2)
f <- function(x) df(x, df1 = 2, df2 = 4*(n - 1))
g <- function(x) df(x, df1 = 2, df2 = 4*(n - 1), ncp = lambda)
uplim <- qf(0.975, df1 = 2, df2 = 4*(n - 1), ncp = lambda)
curve(f, from = 0, to = uplim, lwd = 3, main = "F distributions plot",
      xlab = "F-ratio", ylab = "density")
curve(g, from = 0, to = uplim, lwd = 3, col = "red", add = TRUE)
fstat <- summary(lm(time ~ menu, data = dataset1))$fstatistic[1]
abline(v = fstat, lty = 2, col = "green", lwd = 3)
fcrit <- 2.866
abline(v = fcrit, lty = 2, col = "red", lwd = 3)
par(mfrow = c(1,1))


#'@title Get the outliers for a given time series
#'
#'@description The outliers are computed using different methods based on the \code{outlierType} parameter
#'
#'@usage  tsData.out <- getOutliers(tsData)
#'
#'@param tsData  A time series object.
#'@param outlierType  A string that determines the way to compute the outliers.  outlierType = c("iqr","stl","firstdiff").  Default is "iqr".
#'@details
#'	iqr: Find outliers using the interquartile range of the given time series (boxplot method).
#'  stl: Use stl weights.
#'  firstdiff: Use the points three standard deviations from the mean of the time series of first diffs.
#'
#'@return A vector of indices which represents the location of the outliers within the time series
#'
#'@export

getOutliers <- function(tsData, outlierType = "iqr")
{

	tsObj <- tsData

	if (outlierType == "iqr") {
		tsObj.outliers <-  which(tsObj > quantile(tsObj,probs=.75) + 3*IQR(tsObj))
	} else if (outlierType == "stl") {
		tsObj          <- tsData
		tsObj.stl      <- stats::stl(tsObj,s.window="periodic",robust=T)
		tsObj.outliers <- which(tsObj.stl$weights < 1e-8)
	} else if (outlierType == "firstdiff") {
		tsObj.diff    <- diff(tsObj)
		tsObj.diff.mu <- mean(tsObj.diff)
		tsObj.diff.sd <- sd(tsObj.diff)
		tsObj.outliers <- which(tsObj.diff > tsObj.diff.mu + 3*tsObj.diff.sd)
		tsObj.outliers <- c(tsObj.outliers,which(tsObj.diff < tsObj.diff.mu - 3*tsObj.diff.sd))
	} else {
		stop("Invalid outlier type specified. Valid values are \"iqr\" and \"stl\"")
	}

	return (tsObj.outliers)
}


# Numerical_Integration.r
# Date: 28.06.2019. Created by Joshua Simon.

# Create some functions you want to integrate

f <- function(x) {
    return(sin(x))
}

com_simpson <- function(f, a, b, n) {
    # Composite Simpson's rule
    # Integration of function f over interval [a,b] where n is
	# the number of subintervals. Accuracy only depends on the
	# number of subintervals.

    sum <- 0

    # Step length h
    h <- (b - a) / n

    # Calculate integral value with composite simpson's rule
    for (k in 1:n) {
        x_k <- a + k * h
		x_k1 <- a + (k-1) * h

		simpson <- h/6 * ( f(x_k1) + 4* f((x_k1 + x_k)/2) + f(x_k) )

        sum <- sum + simpson
    }

    return(sum)
}

integral <- com_simpson(f, 0.0, 2.0 * 3.141592654, 100000)

message(integral)


# Example : 4.2B   Chapter : 4.2     Page No: 213
# Find best Possible solution

solution<-function(A,b){
  ATA<-t(A)%*%A
  ATb<-t(A)%*%b
  x<-solve(ATA,ATb)
  return(x)
}

A<-matrix(c(1,1,1),ncol=1)
b<-matrix(c(70,80,120),ncol=1)
x<-solution(A,b)
print("The best possible solution is ")
print(x)


#Series temporais e analises preditivas - Fernando Amaral
library(forecast)
library(ggplot2)

#lambda = 0, logaritmica
t1 = BoxCox(AirPassengers,lambda =0 )
autoplot(t1)

#lambda = 0.34
t2 = BoxCox(AirPassengers,lambda =.1 )
autoplot(t2)

#gera labda automático
lbd = BoxCox.lambda(AirPassengers)
print(lbd)
t3 = BoxCox(AirPassengers,lambda =lbd )
autoplot(t3)

#diferenciacao
t4 = diff(AirPassengers)
autoplot(t4)

#logaritmica
t5 = log10(AirPassengers)
autoplot(t5)

split.screen( figs = c( 2, 2 ) )
screen(1)
plot(t1)
screen(2)
plot(t2)
screen(3)
plot(t3)
screen(4)
plot(t5)
close.screen( all = TRUE )

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/5.5.Transformacoes.r


## Author: Sergio García Prado
## Title: Exercises with Solutions 6

rm(list = ls())

P <- matrix(c(  0, 1/3, 2/3,
              1/3,   0, 2/3,
                1,   0,   0),
            3, 3, byrow = TRUE)

lambdas <- 1 / c(8, 3, 6)

(Q <- P * lambdas + diag(-lambdas))
# -0.1250000	 0.04166667  0.08333333
#  0.1111111	-0.33333333	 0.22222222
#  0.1666667	 0.00000000	-0.16666667

(A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q))))
# -0.1250000	 0.04166667	1
#  0.1111111	-0.33333333	1
#  0.1666667	 0.00000000	1

(stationary <- solve(A)[nrow(A), ])
# 0.558139534883721 0.0697674418604651 0.372093023255814

(non.playing.ratio <- stationary[3])
# 0.372093023255814

(mean.pay <- sum(stationary * c(40, 30, 20)))
# 31.8604651162791