test.ae <- function()
{
    checkEqualsNumeric(ae(3.4, 3.4), 0)
    checkEqualsNumeric(ae(3.4, 4.4), 1.0)
    checkEqualsNumeric(ae(9, 11), 2)
}

test.ce <- function()
{
    checkEqualsNumeric(ce(c(1,1,1,0,0,0),c(1,1,1,0,0,0)), 0.0)
    checkEqualsNumeric(ce(c(1,1,1,0,0,0),c(1,1,1,1,0,0)), 1/6)
    checkEqualsNumeric(ce(c(1,2,3,4),c(1,2,3,3)), 1/4)
    checkEqualsNumeric(ce(c("cat","dog","bird"),c("cat","dog","fish")), 1/3)
    checkEqualsNumeric(ce(c("cat","dog","bird"),c("caat","doog","biird")), 1.0)
}

test.mae <- function()
{
    checkEqualsNumeric(mae(0:10, 1:11), 1)
    checkEqualsNumeric(mae(seq(0,2,0.5), seq(0,2,0.5)), 0)
    checkEqualsNumeric(mae(1:4, c(1,2,3,5)), 0.25)
}

test.mse <- function()
{
    checkEqualsNumeric(mse(0:10, 1:11), 1.0)
    checkEqualsNumeric(mse(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(mse(1:4, c(1,2,3,6)), 1.0)
}

test.msle <- function()
{
    checkEqualsNumeric(msle(c(exp(2)-1),c(exp(1)-1)), 1)
    checkEqualsNumeric(msle(seq(0,2,0.5),seq(0,2,0.5)), 0)
    checkEqualsNumeric(msle(c(1,2,3,exp(1)-1),c(1,2,3,exp(2)-1)), 0.25)
}
test.rae <- function()
{
    checkEqualsNumeric(rae(0:10, 30:40), 11)
    checkEqualsNumeric(rae(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(rae(1:4, c(1,2,3,5)), 0.25)
}

test.rmse <- function()
{
    checkEqualsNumeric(rmse(0:10, 1:11), 1.0)
    checkEqualsNumeric(rmse(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(rmse(1:4, c(1,2,3,5)), 0.5)
}

test.rmsle <- function()
{
    checkEqualsNumeric(rmsle(c(exp(2)-1),c(exp(1)-1)), 1)
    checkEqualsNumeric(rmsle(seq(0,2,0.5),seq(0,2,0.5)), 0)
    checkEqualsNumeric(rmsle(c(1,2,3,exp(1)-1),c(1,2,3,exp(2)-1)), 0.5)
}

test.rrse <- function()
{
    checkEqualsNumeric(rrse(0:10, 2:12), sqrt(0.4))
    checkEqualsNumeric(rrse(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(rrse(1:4, c(1,2,3,5)), sqrt(0.2))
}

test.rse <- function()
{
    checkEqualsNumeric(rse(0:10, 2:12), 0.4)
    checkEqualsNumeric(rse(seq(0,2,0.5), seq(0,2,0.5)), 0.0)
    checkEqualsNumeric(rse(1:4, c(1,2,3,5)), 0.2)
}

test.se <- function()
{
    checkEqualsNumeric(se(3.4, 3.4), 0)
    checkEqualsNumeric(se(3.4, 4.4), 1.0)
    checkEqualsNumeric(se(9, 11), 4)
}

test.sle <- function()
{
    checkEqualsNumeric(sle(3.4,3.4), 0)
    checkEqualsNumeric(sle(exp(2)-1,exp(1)-1), 1)
}

test.f1 <- function()
{
  checkEqualsNumeric(f1(c(3,4,5),c(3,4)), 0.8)
  checkEqualsNumeric(f1(7,1), 0)
  checkEqualsNumeric(f1(7,c(1,1)), 0)
}


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


knitr::opts_chunk$set(echo = TRUE)
library(xtable)
library(tinytex)
library(readxl)
library(psych)
options(tinytex.verbose = TRUE)
options(OutDec = ",")

set.seed(31)
df <- read_xlsx("Trabalho2/tab_pib_2018-10-1.xlsx")
df1 <- df[-c(1:10),]
df1 <- na.omit(df1)
df_fim <- setNames(df1, c("Cidade", "Agro", "Ind",
                 "Adm",
                 "TotalSem",
                 "Total", "Impostos", "PIB",
                 "PIBCapita"))
df_fim[, c(2:9)] <- sapply(df_fim[, c(2:9)], as.numeric)

gini <- function(x, y) {
  z <- abs(x - y)
}

ex_1 <- function(df, r) {

  g <- c()
  n <- nrow(df)

  for (i in 1:r) {
    am <- sample(as.matrix(df[, 9]), n, replace = T)
    matriz <- outer(am, am, gini)
    mu <- mean(am)
    g[i] <- sum(matriz) / (2 * (n ^ 2) * mu)
  }

  cat("Estimativa pontual para o Coeficiente Gini = ", round(mean(g), 4),
      "com", r, "repetições", "\n")

  cat("Intervalo de 95% para o Coeficiente Gini:", "[",
      round(quantile(g, .025), 4), ";", round(quantile(g, .975), 4),
      "]", "com", r, "repetições", "\n")
}

ex_1(df = df_fim, r = 500)
ex_1(df = df_fim, r = 1000)
ex_1(df = df_fim, r = 3000)

corr_mat <- cor(df_fim[, c(2:6)], method = "s")
corPlot(corr_mat, cex = 1.2)
title("Mapa de Calor dos Coeficientes Correlações de Spearman")

ex_2 <- function(df, r) {

  g <- c()
  n <- nrow(df)

  for (i in 1:r) {
    index <- sample(c(1:n), n, replace = T)
    am1 <- df$TotalSem[index]
    am2 <- df$Total[index]
    g[i] <- cor(x = am1, y = am2, method = "s")
  }

  cat("Estimativa pontual para o Coeficiente de Correlação de Spearman = ",
      round(mean(g), 4), "com", r, "repetições", "\n")

  cat("Intervalo de 95% para o Coeficiente de Correlação de Spearman:", "[",
      round(quantile(g, .025), 4), ";", round(quantile(g, .975), 4),
      "]", "com", r, "repetições", "\n")
}

ex_2(df = df_fim, r = 500)
ex_2(df = df_fim, r = 1000)
ex_2(df = df_fim, r = 3000)

library("rmarkdown")
render("Trabalho2/trab2.Rmd", "pdf_document")


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


#PROBLEM NUMBER 02

q0 <- 0
q1 <- 1
fibo <- c()
while (q0 < 4000000){
     q0 <- q0 + q1
     q1 <- q0 + q1
     fibo = c(fibo, q0, q1)
 }

sum(fibo[fibo %% 2 == 0 & fibo < 4000000])


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


library("COUNT")
data("badhealth")

head(badhealth)
any(is.na(badhealth))

library("rjags")

# could fit normal linear model to log of visits

# draw back of taking the log - cannot take log of 0 (must add 0.1 to response)

# instead we can choose poisson linear model, nw taking log of mean rather than response it's self

# form of model included an interation coeficient (a person in good health gives 0, bad health will modify entire linear equation), someone who is older more likely to have bad health

mod_string = " model {
    for (i in 1:length(numvisit)) {
        numvisit[i] ~ dpois(lam[i])
        log(lam[i]) = int + b_badh*badh[i] + b_age*age[i] + b_intx*age[i]*badh[i]
    }

    int ~ dnorm(0.0, 1.0/1e6)
    b_badh ~ dnorm(0.0, 1.0/1e4)
    b_age ~ dnorm(0.0, 1.0/1e4)
    b_intx ~ dnorm(0.0, 1.0/1e4)
} "

set.seed(102)

data_jags = as.list(badhealth)

data_jags

params = c("int", "b_badh", "b_age", "b_intx")

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)

dic

# point estimates of coeficients, use posterior median as we will be taking expo (could have used mean)

# possion mean == variance. A good predictor should predict the same mean and variance in residuals

# if data is more variable than poisson likelyhood suggest (common issue with count data) we can switch to neg binomill dist

# nteration term is an adjustment for age with bad health. Therefore switches the corellation with age and health to negative

## Question Answer

dat = read.csv(file='C:/Users/shcmpq/OneDrive - BP/Desktop/callers.csv', header=TRUE)

mod_string = " model {
    	for (i in 1:length(calls)) {
		calls[i] ~ dpois( days_active[i] * lam[i] )
		log(lam[i]) = b0  + b[1]*age[i] + b[2]*isgroup2[i]
	}

    b0 ~ dnorm(0.0, 1.0/1e2)

    for(j in 1:2) {
        b[j] ~ dnorm(0.0, 1.0/1e2)
    }

} "

set.seed(102)

data_jags = as.list(dat)

params = c("b0", "b[1]", "b[2]")

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=20e3)
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)

X = as.matrix(dat[,3:4])
head(X)

pmed_coef = colMeans(mod_csim)

llam_hat = pmed_coef["b0"] + X %*% pmed_coef[c("b[2]", "b[1]")]
lam_hat = exp(llam_hat/data$days_active)


## Author: Sergio García Prado

rm(list = ls())

## a)
####

## Asymptotic distibution of (mu.hat, var.hat) as parameters mu and var of N(mu, sigma).
##
## (mu.hat, var.hat) ~ N_2( (mu, sigma) , [var / n, 0;
##                                         0, 2 * var ^ 2  / n] )
##

## b)
####

## First of all, we'll generate a random sample with mean = 4, and var = 3
mu <- 4
sigma2 <- 16
n <- 100
alpha <- 0.05

x <- rnorm(n, mean = mu, sd = sqrt(sigma2))

LogLikelihood <- function(theta, x) {
  mu <- theta[1]
  sigma2 <- theta[2]
  n <- length(x)
  l <- (- n / 2) * log(2 * pi * sigma2) - sum((x - mu)  ^ 2) / (2 * sigma2)
  return(l)
}

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

opt <- optim(runif(2), NegativeLogLikelihood, x = x, hessian = TRUE,
             lower = c(-Inf, 10e-3), upper = c(Inf, Inf), method = "L-BFGS-B")

(theta.hat <- opt$par)
# 3.61228715639211 14.6246349377987

(theta.hat.var <- solve(opt$hessian))
# 0.1462463	0.000000
# 0.0000000	4.277599

## Confidence interval for mu
(theta.hat[1] + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(theta.hat.var[1, 1]))
# 3.82193880939507 4.46554400873399

## Confidence interval for sigma2
(theta.hat[2] + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(theta.hat.var[2, 2]))
# 10.5709673127919 18.6783025628054

## c)
####

g <- function(theta) {
  mu <- theta[1]
  sigma2 <- theta[2]

  result <- mu / sqrt(sigma2)

  return(result)
}

g.derivative <- function(theta) {
  mu <- theta[1]
  sigma2 <- theta[2]

  result <- c(1 / sqrt(sigma2), - mu / (2 * sqrt(sigma2 ^ 3)))

  return(result)
}

(g.hat <- g(theta.hat))
# 0.944582184004079

(g.hat.var <- (g.derivative(theta.hat) %*% theta.hat.var %*% g.derivative(theta.hat))[1])
# 0.0144611778114386

## Confidence Interval for g transformation
(g.hat + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(g.hat.var))
# 0.708887425765002 1.18027694224316

g.zero <- 1

## d)
####

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

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

## e)
####

LogLikelihoodH0 <- function(theta, x) {
  LogLikelihood(c(theta, theta ^ 2), x)
}

NegativeLogLikelihoodH0 <- function(...) {
  - LogLikelihoodH0(...)
}

opt.h0 <- optim(runif(1), NegativeLogLikelihoodH0, x = x,
                lower = 10e-3, method = "L-BFGS-B" )

(LRT <- 2 * (LogLikelihood(theta.hat, x) - LogLikelihoodH0(opt.h0$par, x)))
# 0.211977389743652

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


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


## R script for model with all inputs
## Data: https://modeanalytics.com/benn/reports/72c16eaaeefc

tracts <- read.csv("model_inputs.csv")

##  By white population percent
full <- lm(trips ~ median_income + population + white_percent + distance_in_miles,data=tracts)
summary(full)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)        1.204e+04  2.149e+03   5.600 5.69e-08 ***
##  median_income      6.346e-02  2.006e-02   3.163  0.00176 **
##  population        -7.785e-02  1.728e-01  -0.450  0.65282
##  white_percent      4.748e+03  3.244e+03   1.464  0.14455
##  distance_in_miles -2.840e+03  3.126e+02  -9.084  < 2e-16 ***
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 7664 on 247 degrees of freedom
##  Multiple R-squared:  0.5496,	Adjusted R-squared:  0.5423
##  F-statistic: 75.35 on 4 and 247 DF,  p-value: < 2.2e-16

##  By black population percent
black_only <- lm(trips ~ median_income + population + black_percent + distance_in_miles,data=tracts)
summary(black_only)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)        1.579e+04  2.199e+03   7.180 8.17e-12 ***
##  median_income      6.815e-02  1.515e-02   4.498 1.05e-05 ***
##  population        -1.101e-01  1.716e-01  -0.641   0.5218
##  black_percent     -6.943e+03  2.858e+03  -2.429   0.0158 *
##  distance_in_miles -2.868e+03  2.987e+02  -9.601  < 2e-16 ***
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 7607 on 247 degrees of freedom
##  Multiple R-squared:  0.5563,	Adjusted R-squared:  0.5491
##  F-statistic: 77.42 on 4 and 247 DF,  p-value: < 2.2e-16

##  With nightime trips as dependent varible
after_8 <- lm(after_8_trips ~ median_income + population + white_percent + distance_in_miles,data=tracts)
summary(after_8)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)        4.991e+03  8.641e+02   5.776 2.29e-08 ***
##  median_income     -2.320e-03  8.065e-03  -0.288   0.7739
##  population        -7.622e-02  6.949e-02  -1.097   0.2738
##  white_percent      2.950e+03  1.304e+03   2.262   0.0246 *
##  distance_in_miles -9.634e+02  1.257e+02  -7.666 4.06e-13 ***
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 3081 on 247 degrees of freedom
##  Multiple R-squared:  0.3827,	Adjusted R-squared:  0.3727
##  F-statistic: 38.28 on 4 and 247 DF,  p-value: < 2.2e-16

##  With nightime trips as dependent varible, by black population ony
after_8_black_only <- lm(after_8_trips ~ median_income + population + black_percent + distance_in_miles,data=tracts)
summary(after_8_black_only)

##  Coefficients:
##                      Estimate Std. Error t value Pr(>|t|)
##  (Intercept)        7.188e+03  8.790e+02   8.177 1.53e-14 ***
##  median_income      1.510e-03  6.055e-03   0.249 0.803301
##  population        -9.184e-02  6.859e-02  -1.339 0.181815
##  black_percent     -3.937e+03  1.142e+03  -3.447 0.000667 ***
##  distance_in_miles -9.869e+02  1.194e+02  -8.266 8.56e-15 ***
##  ---
##  Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1
##
##  Residual standard error: 3041 on 247 degrees of freedom
##  Multiple R-squared:  0.3988,	Adjusted R-squared:  0.3891
##


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


## Correlation matrix with p-values. See http://goo.gl/nahmV for documentation of this function
cor.prob <- function (X, dfr = nrow(X) - 2) {
	R <- cor(X, use="pairwise.complete.obs")
	above <- row(R) < col(R)
	r2 <- R[above]^2
	Fstat <- r2 * dfr/(1 - r2)
	R[above] <- 1 - pf(Fstat, 1, dfr)
	R[row(R) == col(R)] <- NA
	R
}

## Use this to dump the cor.prob output to a 4 column matrix
## with row/column indices, correlation, and p-value.
## See StackOverflow question: http://goo.gl/fCUcQ
flattenSquareMatrix <- function(m) {
	if( (class(m) != "matrix") | (nrow(m) != ncol(m))) stop("Must be a square matrix.")
	if(!identical(rownames(m), colnames(m))) stop("Row and column names must be equal.")
	ut <- upper.tri(m)
	data.frame(i = rownames(m)[row(m)[ut]],
			   j = rownames(m)[col(m)[ut]],
			   cor=t(m)[ut],
			   p=m[ut])
}

# get some data from the mtcars built-in dataset
mydata <- mtcars[, c(1,3,4,5,6)]

# correlation matrix
cor(mydata)

# correlation matrix with p-values
cor.prob(mydata)

# "flatten" that table
flattenSquareMatrix(cor.prob(mydata))

# plot the data
library(PerformanceAnalytics)
chart.Correlation(mydata)


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

}


# Example : 1   Chapter : 9.3     Page No: 482
# Powers of some matrices can be calculated easily with max eigen value
B<-matrix(c(0.6,0.6,0.5,0.5),ncol=2)
B1<-matrix(c(0.6,0,1.1,0.5),ncol=2)
lambda<-eigen(B)$values
lambda1<-eigen(B1)$values
lmax<-lambda[1]
l1max<-lambda1[1]
print("Lambda max of B is")
print(lmax)
print("Lambda max of B1 is ")
print(l1max)
B2<-B%*%B
print("B square is")
print(B2)
B2<-lmax*B
print(B2)
print("B1 square has 0.6*0.6 and 0.5*0.5 on its diagonal")
B12<-B1%*%B1
print(B12)


##Q2 R code
#let e_t ~ id N(0,1), let n=100
#theta=0.25=1/4
Y.t=arima.sim(list(order=c(0,0,1),ma=0.25),n=100)
#compute the ACF
acf(Y.t)
#plot the time series
plot.ts(Y.t)
#theta=4
Y.t=arima.sim(list(order=c(0,0,1),ma=4),n=100)
#compute the ACF
acf(Y.t2)
#plot the time series
plot.ts(Y.t2)

##Q3 R code
N=50
xs1=rep(NA,N) #create a vector called xs1 of length N, filled with NAs
ys1=rep(NA,N) #create a vector called ys1 of length N, filled with NAs
xs1[1]=0 # set the first element of xs1 to zero.
#simulate xs1 using a loop
for (t in 2:N)
{
  xs1[t]=xs1[t-1] + rnorm(1,0,1) # random walk for xs1
}
# simulate ys1
for (t in 1:N)
{
  ys1[t]=4 + 3*t + xs1[t]
}

#compute the ACF
acf(ys1)
#compute the first 10 ACFs
acf(ys1, lag.max=10)
#plot the time series
ts.plot(ys1)


recur_factorial <- function(n) {
if(n <= 1) {
return(1)
} else {
return(n * recur_factorial(n-1))
}
}


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.


# Title: 'Vector Arithmetics'
# Desc: 'We will learn about vector arithmetic functions in R. This will assist us with solving higher-level algorithm'
# Type: Exercise
# Language: R
# skills: 1

# During previous testing we created this data frame:

temp <- c(35, 88, 42, 84, 81, 30) # dataset with stored temperatures
city <- c("Beijing", "Lagos", "Paris", "Rio de Janeiro", "San Juan", "Toronto") # dataset with stored cities
city_temps <- data.frame(name = city, temperature = temp) # dataset with cities with temperature values

# Say we are interested in specifying Celsius instead of Fahrenheit.
# The math formula that converts from Fahrenheit to Celsius is  $C = 5/9 \times (F-32)$

# Use vector arithmetic to convert temp to Celsius
# We will create a data frame called city_temps that will have the city names and temperatures stored in Celsius

# To subtract a constant `a` to each entry of a vector `x` and then multiply each by `b` to each use `(x-a)*b`

# We will assign the city names to city variable
city <- c("Beijing", "Lagos", "Paris", "Rio de Janeiro", "San Juan", "Toronto")

temp <- c(35, 88, 42, 84, 81, 30) # We will then store the temperature values in temp

# This is how you will convert the temperature into Celsius and then overwrite the original valued of temp with the Celsius values

# First we will create a data frame named city_temps

# Then we will assign city names to city

city <- c("Beijing", "Lagos", "Paris", "Rio de Janeiro", "San Juan", "Toronto")

temp <- c(35, 88, 42, 84, 81, 30) # This will store the temperature values in temp

# This connverts the temperature into Celsius and overwrites the values of temp with Celsius values
temp <- (temp - 32)*5/9

city_temps <- data.frame(name = city, temperature = temp) # This creates a data frame city_temps


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


list.files()
gDat < read.delim("gapMinderDataFiveYear.txt")
gDat <- read.delim("gapMinderDataFiveYear.txt")
View(gDat)
View(gDat)
str(gDat)
head(gDat)
tail(gDat)
names(gDat)
ncol(gDat)
summary(gDat)
plot(lifeExp ~ year, gDat)
plot(lifeExp ~gdpPercap, gDat)
plot(lifeExp ~ gdpPercap, gDat)
plot(lifeExp ~ log(gdpPercap), gDat)
head(gDat$lifeExp)
summary(gDat$lifeExp)
length(gDat$lifeExp)
hist(gDat$lifeExp)
str(gDat$continent)
table(gDat$continent)
table(gDat$continent)
barplot(table(gDat$continent))
p <- ggplot(subset(gDat, continent != "Oceania"),
aes(x = gdpPercap, y = lifeExp)) # just initializes
p <- p + scale_x_log10() # log the x axis the right way
p + geom_point() # scatterplot
p + geom_point(aes(color = continent)) # map continent to color
p + geom_point(alpha = (1/3), size = 3) + geom_smooth(lwd = 3, se = FALSE)
## geom_smooth: method="auto" and size of largest group is >=1000, so using gam with formula: y ~ s(x, bs = "cs"). Use 'method = x' to change the smoothing method.
p + geom_point(alpha = (1/3), size = 3) + facet_wrap(~ continent)
p <- ggplot(subset(gDat, continent != "Oceania"),
aes(x = gdpPercap, y = lifeExp)) # just initializes
library(ggplot2)
p <- ggplot(subset(gDat, continent != "Oceania"),aes(x = gdpPercap, y = lifeExp)) # just initializes
p <- p + scale_x_log10() # log the x axis the right way
p + geom_point() # scatterplot
p + geom_point(aes(color = continent)) # map continent to color
p + geom_point(alpha = (1/3), size = 3) + geom_smooth(lwd = 3, se = FALSE)
## geom_smooth: method="auto" and size of largest group is >=1000, so using gam with formula: y ~ s(x, bs = "cs"). Use 'method = x' to change the smoothing method.
p + geom_point(alpha = (1/3), size = 3) + facet_wrap(~ continent)

# more ggplot2p  <- ggplot(gDat, aes(x = gdpPercap, y = lifeExp))
p + geom_point()
p  <- ggplot(gDat, aes(x = log10(gdpPercap), y = lifeExp))
p + geom_point()
p + geom_point() + scale_x_log10
p + geom_point() + scale_x_log10()
p + geom_point()
p  <- ggplot(gDat, aes(x = gdpPercap, y = lifeExp))
p + geom_point() + scale_x_log10()
p  <- p + scale_x_log10()
p + geom_point(aes(color = continent))
p + geom_point(aes(color = continent, alpha = (1/3), size= 3))
p + geom_point(aes(alpha = (1/3), size= 3))
p + geom_point(aes(alpha = (1/4), size= 3))
p + geom_point(aes(alpha = (1/10), size= 3))
p + geom_point(aes(alpha = (1/100), size= 3))
p + geom_point(alpha = (1/100), size= 3)
p + geom_point(alpha = (1/3), size= 3)
p + geom_point(alpha = (1/3), size= 3) + geom_smooth()
p + geom_point(alpha = (1/3), size= 3) + geom_smooth(lwd = 3, se = FALSE)
p + geom_point(alpha = (1/3), size= 3) + geom_smooth(lwd = 3, se = FALSE, method = 'lm')
p + aes(color=continent) + geom_point(alpha = (1/3), size= 3) + geom_smooth(lwd = 3, se = FALSE, method = 'lm')
p + aes(color=continent) + geom_point(alpha = (1/3), size= 3) + geom_smooth(lwd = 3, se = FALSE)
p + aes(color=continent) + geom_point(alpha = (1/3), size= 3) + facet_wrap(~ continent)
p + aes(color=continent) + geom_point(alpha = (1/3), size= 3) + facet_wrap(~ continent) + geom_smooth(lwd = 3)
p + aes(color=continent) + geom_point(alpha = (1/3), size= 3) + facet_wrap(~ continent) + geom_smooth(lwd = 3, se=false)
p + aes(color=continent) + geom_point(alpha = (1/3), size= 3) + facet_wrap(~ continent) + geom_smooth(lwd = 3, se = FALSE)
p + geom_point(alpha = (1/3), size= 3) + facet_wrap(~ continent) + geom_smooth(lwd = 3, se = FALSE)
q  <- ggplot(gDat, aes(x=year, y=lifeExp))
q + geom_points()
q + geom_point()
q + geom_point() + facet_wrap(~ continent)
q + geom_point() + facet_wrap(~ continent) + geom_smooth(lwd = 3)
q + geom_smooth(lwd = 3) + geom_point() + facet_wrap(~ continent)
q + geom_line(aes(group = country)) + geom_point() + facet_wrap(~ continent)
ggplot(gDat, aes(x = gdpPercap, y = lifeExp)) + scale_x_log10() + geom_bin2d()
ggplot(gDat, aes(x=continent, y=lifeExp)) + geom_point()
ggplot(gDat, aes(x=continent, y=lifeExp)) + geom_point() + geom_jitter()
ggplot(gDat, aes(x=continent, y=lifeExp)) + geom_point() + geom_jitter(position = position_jitter(width = 0.1, height = 0), alpha = 1/4)
ggplot(gDat, aes(x = continent, y = lifeExp)) +
geom_jitter(position = position_jitter(width = 0.1, height = 0), alpha = 1/4)
ggplot(gDat, aes(x = continent, y = lifeExp)) + geom_boxplot()
ggplot(gDat, aes(x = continent, y = lifeExp)) +
geom_boxplot(outlier.colour = "hotpink") +
geom_jitter(position = position_jitter(width = 0.1, height = 0), alpha = 1/4)
ggplot(gDat, aes(x = continent, y = lifeExp)) +
geom_jitter(position = position_jitter(width = 0.1), alpha = 1/4) +
stat_summary(fun.y = median, colour = "red", geom = "point", size = 5)
ggplot(gDat, aes(reorder(x = continent, lifeExp), y = lifeExp)) +
geom_jitter(position = position_jitter(width = 0.1), alpha = 1/4) +
stat_summary(fun.y = median, colour = "red", geom = "point", size = 5)
ggplot(gDat, aes(x = lifeExp)) + geom_histogram()
ggplot(gDat, aes(x = lifeExp)) + geom_density()
ggplot(gDat, aes(x = lifeExp, fill = continent)) + geom_histogram()
ggplot(gDat, aes(x = lifeExp, fill = continent)) +
geom_histogram(position = "identity")
ggplot(gDat, aes(x = lifeExp, fill = continent)) +
geom_histogram(position = "identity")
ggplot(gDat, aes(x = lifeExp, color = continent)) + geom_density()
ggplot(gDat, aes(x = lifeExp, fill = continent)) + geom_density(alpha = 0.2)
ggplot(subset(gDat, continent != "Oceania"),
aes(x = lifeExp, fill = continent)) + geom_density(alpha = 0.2)
ggplot(gDat, aes(x = continent)) + geom_bar()
p <- ggplot(gDat, aes(x = reorder(continent, continent, length)))
p + geom_bar()
p + geom_bar() + coord_flip()
p + geom_bar(width = .04) + coord_flip()


#задание 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)


dataset = read.csv(("Position_salaries.csv"))
dataset = dataset[2:3]

#Fitting Polynomial Regression to the dataset Set
dataset$Level2 = dataset$Level^2
dataset$Level3 = dataset$Level^3
dataset$Level4 = dataset$Level^4
poly_reg = lm(formula = Salary ~ .,data = dataset)

#visualizing the Polynomial Regression Result
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') +
  ggtitle('R Truth or Bluff (Polynomial Regression)') +
  xlab('Level') +
  ylab('Salary')

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


## 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 : 3   Chapter : 6.1     Page No: 286
# Eigen values and eigen vectors of Reflection matrix
A<-matrix(c(0,1,1,0),ncol=2)
sol<-eigen(A)
lambda<-sol$values
print("The eigen values of the matrix are")
print(lambda)
#The  answer may slightly vary due to  rounding off values


# Brute force, see the "Permutations" page for the next.perm function
safe <- function(p) {
  n <- length(p)
  for (i in seq(1, n - 1)) {
    for (j in seq(i + 1, n)) {
      if (abs(p[j] - p[i]) == abs(j - i)) return(F)
    }
  }
  return(T)
}

queens <- function(n) {
  p <- 1:n
  k <- 0
  while (!is.null(p)) {
    if(safe(p)) {
      cat(p, "\n")
      k <- k + 1
    }
    p <- next.perm(p)
  }
  return(k)
}

queens(8)
# 1 5 8 6 3 7 2 4
# ...
# 92


# Imitate and plot Levy process built as
# N(t) = sum(k=1:t; xi_k), where xi_k ~ Po(lambda)

LevyProc <- function(arg, rate = Lambda)
{
  # process starts at 0 and receives increments that have Poisson distribution
  return(sum(rpois(n = arg, lambda = rate)))
}

## input parameters
Lambda <- 1.0
N <- 100
T <- seq(from = 0, to = 1, by = 1/n)

# construction of the Levy process for 0, 1/n, 2/n, .... k/n, .... 99/n, 1
# multiplication T by 100 needed as LevyProc takes integer <arg>
N <- sapply(X = T*100, FUN = LevyProc)

# drawing plot of the trajectory
ggplot() + geom_path(aes(x = T, y = N)) + ggtitle('Levy process trajectory') + labs(x = 't', y = 'N(t)')


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


bull_riders = read.csv('BullRiders.csv')

cor(bull_riders$CupPoints12, bull_riders$Earnings12)
plot(bull_riders$CupPoints12, bull_riders$Earnings12)
abline(lm(bull_riders$Earnings12~bull_riders$CupPoints12), col="red")

max_value = max(bull_riders_12$Earnings12)
bull_riders_12_no_outliers =  bull_riders[!(bull_riders$Earnings12 == max_value),]
cor(bull_riders_12_no_outliers$CupPoints12, bull_riders_12_no_outliers$Earnings12)
cor(bull_riders_12_no_outliers$RidePer12, bull_riders_12_no_outliers$Earnings12)

cor(bull_riders$RidePer12, bull_riders$Earnings12)
plot(bull_riders$RidePer12, bull_riders$Earnings12)
abline(lm(bull_riders$Earnings12~bull_riders$RidePer12), col="red")

cor(bull_riders$CupPoints13, bull_riders$Earnings13)
plot(bull_riders$CupPoints13, bull_riders$Earnings13)
abline(lm(bull_riders$Earnings13~bull_riders$CupPoints13), col="red")

cor(bull_riders$RidePer14, bull_riders$Earnings14)
plot(bull_riders$CupPoints14, bull_riders$Earnings14)
abline(lm(bull_riders$Earnings14~bull_riders$CupPoints14), col="red")