# ************************************************
### simon munzert
### maximum likelihood estimation
# ************************************************

source("packages.r")
source("functions.r")

### Writing functions in R -----------------------

# R is a functional programming lanugage, i.e. it provides many tools for the creation and manipulation of functions
# you can do virtually anything with functions: assign them to variables, store them in lists, pass them as arguments to other functions, ...
# very helpful in obeying the "don't repeat yourself" a.k.a. DRY principle

f <- function(x) x^2
f
f(3)

# function that returns the mean of a vector
my_mean <- function(my_vector) {
  mean <- sum(my_vector)/length(my_vector)
  mean
}
my_mean(c(1, 2, 3))
my_mean

# another function that finds the remainder after division ("modulo operation")
remainder <- function(num = 10, divisor = 4) {
  remain <- num %% divisor
  remain
}
remainder()
args(remainder)

## let's study the "functions.r" file now!

### Exercise: Functions --------------------------
# 1. program a function ultimateAnswer() that always returns the number 42!
# 2. program a function normalize() that produces normalizes a numeric vector x to mean(x) = 0 and sd(x) = 1!

### Probability distributions in R -----------

# for an overview of implemented distributions, see
?Distributions

## the Normal distribution

# rnorm() performs random draws from the distribution
y <- rnorm(1000, mean = 0, sd = 1)
plot(y)
plot(density(y))

# dnorm() gives the density of the distribution
dnorm(0, mean = 0, sd = 1)
z_scores <- seq(-3, 3, by = .1)

dvalues <- dnorm(z_scores)
plot(z_scores, dvalues, type = "l", main = "pdf of the Standard Normal", xlab = "Z score")

# pnorm() gives the distribution function
pnorm(0)
pnorm(-1)
pnorm(1.96)
pnorm(1.96, lower.tail = FALSE)

pvalues <- pnorm(z_scores)
plot(z_scores, pvalues,  type = "l", main = "cdf of the Standard Normal", xlab= "Z score", ylab="Probability Density")

## the Binomial distribution
p <- 0.5
n <- 100
size <- 5
tmp <- rbinom(n, size, p)
table(tmp)
plot(table(tmp), xlab = "Sum of 1 in N", ylab = "Occurrence in n = 100")
text(4.5, c(27, 24, 21), c(paste0("n = ", n), paste0("p = ", p), paste0("N = ", size)))

## Example 1: Coin flips ----------------------

# get 100 random draws from a binomial distribution with p = .4 --> the estimate we're actually interested in
set.seed(1234)
flips <- rbinom(n = 100, size = 1, prob = .4)
table(flips)

# define likelihood function
binom_loglik <- function(x, p) { # x: vector of results/observed 0s and 1s, p: probability of success
  llik <- sum(dbinom(x, size = 1, prob = p, log = TRUE)) # calculate log likelihood with pdf for binomial distribution
  return(-llik) # return the negative log likelihood
}

# visually identify parameter value for which negative likelihood is minimized (= likelihood is maximized)
llks <- vector()
probs <- seq(0, 1, .01)
for (i in seq_along(probs)) {
  llks[i] <- -sum(dbinom(flips, size = 1, prob = probs[i], log = TRUE))
}
plot(probs, -llks, type = "l")
abline(v = probs[which.min(llks)], col = "red", lty = 2)

# numerically optimize log-likelihood
result <- optim(par = .5, fn = binom_loglik, x = flips, method = 'Brent', lower = 0, upper = 1)
result
# par: initial values of parameter to be estimated, we assume a fair coin
# fn: function to be minimized
# lower/upper: since probability paramenter can only be within the unit interval

## Example 2: Linear model ---------------------

# prepare data, run OLS
data("wage1")
wage_ols <- lm(wage ~ educ, data = wage1)
summary(wage_ols)
y <- wage1$wage
X <- cbind(1, wage1$educ)

# define likelihood function...
# ... but how? Here are three options:
  # 1. minimizing the sum of squared residuals (not an acutal ML estimate)
  # 2. maximizing the log-likelihood for normally distributed residuals
  # 3. maximizing the log-likelihood for normally distributed DVs

# 1. Squared residuals
ols <- function(y, X, b) {
  res <- y - X %*% b # calculate residuals
  return(sum(res^2, na.rm = TRUE))
}
# this function calculates the sum of squared residuals
# OLS is defined to return coefficients that give the smallest possible
# sum of squared residuals

# 2. normally distributed residuals
normal_loglik <- function(theta, y, X) {
  b <- theta[-length(theta)] # b's
  sigma <- theta[length(theta)] # sigma
  res <- y - X %*% b # residuals
  return(-sum(dnorm(res, mean = 0, sd = sigma, log = TRUE), na.rm = TRUE))
}
# implies the following assumption on the distribution of e:
# y = f(X, b) + e with e ~ N(0, sigma)

# 3. normally distributed y
normal2_loglik <- function(theta, y, X) {
  b <- theta[-length(theta)] # b's
  sigma <- theta[length(theta)] # sigma
  yhat <- X %*% b # predicted values for y
  return(-sum(dnorm(y, mean = yhat, sd = sigma, log = TRUE), na.rm = TRUE))
}
# an equivalent formulation is
# y ~ f(theta, sigma) with theta = g(X, b)

# OLS solution
result_ols <- optim(par = c(1, 1), fn = ols, y = y, X = X, method = "BFGS")
result_ols

# optimize log-likelihoods
result_normal <- optim(par = c(1, 1, 1), fn = normal_loglik, y = y, X = X, method = "BFGS")
result_normal

result_normal2 <- optim(par = c(1, 1, 1), fn = normal2_loglik, y = y, X = X, method = "BFGS")
result_normal2

# compare again with OLS
summary(wage_ols)

## Assessing estimation uncertainty ---------------------

result <- optim(par = c(1, 1, 1), fn = normal_loglik, y = y, X = X, hessian = TRUE) # set hessian = TRUE to optain Hessian matrix, which contains the second-order partial derivates

inv_hess <- solve(result$hessian) # take the inverse of the Hessian to get the Fisher information matrix

sigma <- sqrt(diag(inv_hess)) # the square root of the diagonals are then the standard errors

estimates_df <- data.frame(params = result$par,
                           ci95lo = result$par - 1.96 * sigma,
                           ci95hi = result$par + 1.96 * sigma)
rownames(estimates_df) <- c("beta_0", "beta_1", "sigma2")
estimates_df


# Guía del fichero: https://rpubs.com/probestaunal/tablas

######################
#  ANÁLISIS GRÁFICO  #
######################

# graficar las frecuencias relativas
nj <- c(145, 2415, 3456, 852, 459, 157, 130)
names(nj) <- 0:6
barplot(nj)

# graficar las frecuencias relativas
hj <- prop.table(nj)
barplot(hj)

##################################################################
#                   DISTRIBUCIÓN DE FRECUENCIAS                  #
##################################################################
# Considerar el siguiente conjunto de datos asociados con el     #
# nivel educativo de una muestra de empleados (Bachillerato (B), #
# Pregrado (P), Maestría (M), y Doctorado (D)). Elaborar la      #
# tabla de frecuencias correspondiente.                          #
#                                                                #
# B, D, M, B, B, P, B, M, B, B, B, P, B, M, B, B, M, B, M, B, B, #
# B, B, B, B, B, P, B, B, B, B, M, B, P, B, B, M, B, B, B, D, B, #
# M, B, P, B, B, B, P, P                                         #
##################################################################

# datos
edu <- c("B", "D", "M", "B", "B", "P", "B", "M", "B", "B", "B", "P", "B", "M",
         "B", "B", "M", "B", "M", "B", "B", "B", "B", "B", "B", "B", "P", "B",
         "B", "B", "B", "M", "B", "P", "B", "B", "M", "B", "B", "B", "D", "B",
         "M", "B", "P", "B", "B", "B", "P", "P")
# tamaño de la muestra
n <- length(edu)
print(n)

# frecuencias absolutas
nj <- table(edu)
nj <- nj[c(1, 4, 3, 2)]
print(nj)

# frecuencias relativas
hj <- nj/n
print(hj)

# frecuencias absolutas acumuladas
Nj <- cumsum(nj)
print(Nj)

# frecuencias relativas acumuladas
Hj <- cumsum(hj)
print(Hj)

##################################################################################################
#                                    VARIABLES CUANTITATIVAS                                     #
##################################################################################################
# Considerar el siguiente conjunto de datos asociados con el peso (en kg) de una                 #
# muestra de materiales. Elaborar la distribución de frecuencias correspondiente.                #
#                                                                                #
# 103.1, 82.1 , 106.2, 100.9, 91.8, 96.1 , 126.9, 119.8, 93.1 , 86.8, 75.2 , 93.0, 82.3 , 94.8,  #
# 64.2 , 105.3, 108.0, 86.3 , 81.8, 138.1, 92.5, 66.3 , 66.6 , 142.2, 96.5 , 74.8, 95.4 , 100.1, #
# 81.9 , 112.0, 116.8, 103.2, 66.1, 60.4 , 78.7                                                  #
##################################################################################################

# datos
peso<- c(103.1, 82.1, 106.2, 100.9, 91.8,  96.1,  126.9, 119.8, 93.1, 86.8, 75.2, 93.0,
         82.3,  94.8, 64.2,  105.3, 108.0, 86.3,  81.8,  138.1, 92.5, 66.3, 66.6, 142.2,
         96.5,  74.8, 95.4,  100.1, 81.9,  112.0, 116.8, 103.2, 66.1, 60.4, 78.7)
# tamaño de la muestra
n <- length(peso)
print(n)

# numero de intervalos
m <- round(1 + 3.3*log(n, base = 10), 2)
print(m)

# rango
R <- max(peso) - min(peso)
print(R)

# amplitud
a <- R/m
print(a)

# limites
lim <- min(peso) + (0:m)*a
print(lim)
# frecuencias absolutas
nj <- table(cut(x = peso, breaks = lim, include.lowest = T))
print(nj)

# frecuencias relativas
hj <- nj/n
print(hj)

# frecuencias absolutas acumuladas
Nj <- cumsum(nj)
print(Nj)

# frecuencias relativas acumuladas
Hj <- cumsum(hj)
print(Hj)


f1 <- function(x) dnorm(x)
f2 <- function(x) dcauchy(x)
f3 <- function(x) dt(x, df = 1)
f4 <- function(x) dt(x, df = 5)
f5 <- function(x) dt(x, df = 30)

par(mfrow = c(1, 2))
curve(f1, -5, 5, xlab = expression(x), ylab = "Densidade", lwd = 2)
curve(f2, lwd = 2, col = "grey50", add = TRUE)
curve(f3, lwd = 2, col = "red", lty = 2, add = TRUE)
curve(f4, lwd = 2, col = "blue", lty = 3, add = TRUE)
curve(f5, lwd = 2, col = "red", lty = 4, add = TRUE)

curve(f1, 2, 5, xlab = expression(x), ylab = "Densidade", lwd = 2)
curve(f2, lwd = 3, col = "grey50", add = TRUE)
curve(f3, lwd = 3, col = "red", lty = 2, add = TRUE)
curve(f4, lwd = 3, col = "blue", lty = 3, add = TRUE)
curve(f5, lwd = 3, col = "red", lty = 4, add = TRUE)

legend(x = "topright",
       legend = c(
         "N(0,1)",
         "Cauchy",
         "T(1)",
         "T(5)",
         "T(30)"
       ),
       col = c("black", "grey50", "red", "blue", "red", "blue"),
       lty = c(1, 1, 2, 3, 4, 5),
       lwd = 2,
       bty = 'n')


# ......................................................................................
# ...............................Cvičení 1 - Kombinatorika..............................
# ..................Adéla Vrtková, Michal Béreš, Martina Litschmannová..................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

# * Variace ####
#
# V(n,k) - variace bez opakování, první argument bude celkový počet entit, druhý
# argument velikost výběru

# funkce se vytváří příkazem fucntion, je to objekt jehož jméno je dáno až proměnnou
# do které tento objekt přiřadím
variace = function(n,k) # zde zadávám počet parametrů a jejich jména
{ # celé tělo funkce je uzavřeno mezi závorkami {...}
    citatel = factorial(n)  # faktoriál v originálním Rku existuje tak jej použijeme
    jmenovatel = factorial(n-k)
    return(citatel/jmenovatel)    # to co funkce vrátí se dává do příkazu return(...)
}

# V*(n,k) - variace s opakováním

variace_opak = function(n,k)
{
  return(n^k)
}

# * Permutace ####
#
# P(n)=V(n,n) - permutace

permutace = function(n)
{
  return(variace(n,n))
}

# P*(n1,n2,n3,....,nk) - permutace s opakováním, vstup bude vektor s jednotlivými počty
# unikátních entit

permutace_opak = function(vec_n) # vec_n je vektro počtů hodnot př.: vec_n = c(2,2,2,4,3)
{
    n = sum(vec_n) # spočteme kolik máme hodnot celkem
    res_temp=factorial(n) #jejich faktoriál = hodnota v čitateli
    # jednoduchý cyklus začíná příkazem for, pak v závorkách následuje název iterátoru a z
    # jakého seznamu bude brán
    for(pocet in vec_n) # pocet je iterátor a postupně bude nabývat hodnot z vektoru vec_n
    {
        # postupně dělíme faktoriálem každého počtu unikátních entit
        res_temp=res_temp/factorial(pocet)
    }
    return(res_temp)
}

# * Kombinace ####
#
# C(n,k) - kombinace

kombinace = function(n,k)
{
  return(choose(n,k)) # funkce for kombinace už existuje v Rku a jmenuje se choose
}

# C*(n,k) - kombinace s opakováním

kombinace_opak = function(n,k)
{
  return(choose(n+k-1,k)) # použijeme známý vzorec
}

#  Úlohy na cvičení ####
#
# * Příklad 1. ####
#
# V prodejně mají k dispozici tři typy zámků. Pro otevření prvního
# zámku je nutno zmáčknout čtyři z deseti tlačítek označených číslicemi 0 až 9. (Na
# pořadí nezáleží - tlačítka zůstávají zmáčknuta.)
# Druhý zámek se otevře pokud zmáčkneme šest tlačítek z deseti.
# Pro otevření třetího zámku je nutno nastavit správnou kombinaci
# na čtyřech kotoučích. Který z těchto zámků nejlépé chrání před
# zloději?

z1=kombinace(10,4)
z2=kombinace(10,6)
z3=variace_opak(10,4)
paste("pocet kombinaci: ",z1,",",z2,",",z3)
paste("pradvedepodobnost nahodnehootevreni: ",1/z1,",",1/z2,",",1/z3)

# * Příklad 2. ####
#
# V prodejně nabízejí dva druhy zamykání kufříku. První kufřík se zamyká šifrou, která
# se skládá
# z šesti číslic. Druhý kufřík se zamyká dvěma zámky, které se otevírají současně. Šifra
# každého
# z nich se skládá ze tří číslic. Určete pro každý kufřík pravděpodobnost otevření
# zlodějem při
# prvním pokusu. Který typ zámku je bezpečnější?

z1=variace_opak(10,6);
z2=variace_opak(10,3)*variace_opak(10,3);
z2_v2=variace_opak(10,3)+variace_opak(10,3);
paste("pocet kombinaci: ",z1,",",z2,",druha varianta - ",z2_v2)

# * Příklad 3. ####
#
# V urně je 40 koulí - 2 červené a 38 bílých. Z urny náhodně vytáhneme 2 koule. S jakou
# pravděpodobností budou obě červené?

poc_moz=kombinace(40,2);
poc_priz=kombinace(2,2);
prob=poc_priz/poc_moz;
paste("pravdepodobnost je: ",prob)

# * Příklad 4. ####
#
# Student si měl ke zkoušce připravit odpovědi na 40 otázek. Na dvě otázky, které mu dal
# zkoušející, neuměl odpovědět a tak řekl „To mám smůlu! To jsou jediné dvě otázky, na
# které neumím odpovědět.“ S jakou pravděpodobností mluví pravdu?

# * Příklad 5.  ####
#
# Test z chemie žák složí, pokud v seznamu 40 chemických sloučenin podtrhne jediné dva
# aldehydy, které v seznamu jsou. Jaká je pravděpodobnost, že test složí žák, který
# provede výběr
# sloučenin náhodně?

# * Příklad 6. ####
#
# Ze zahraničí se vracela skupina 40 turistů a mezi nimi byli 2 pašeráci. Na hranici
# celník 2 turisty
# vyzval k osobní prohlídce a ukázalo se, že oba dva jsou pašeráci. Zbylí turisté na to
# reagovali:
# „Celník měl opravdu štěstí!“, „Pašeráky někdo udal!“, . . .. Jak se postavit k těmto
# výrokům?
# Je oprávněné podezření, že pašeráky někdo udal?

# * Příklad 7. ####
#
# Z urny se třemi koulemi, dvěma červenými a jednou bílou, budou současně vybrány dvě
# koule.
# Student a učitel uzavřou sázku. Pokud budou obě koule stejné barvy, vyhraje student.
# Pokud
# budou mít koule různou barvu, vyhraje učitel. Je hra férová? Jaké jsou
# pravděpodobnosti výhry
# učitele a studenta?

# funkce combn vyrobí kombinace o předepsané velikosti - první parametr je vektor hodnot, druhý velikost výběru
combn(c('cerna','cerna','cervena'),2)

# * Příklad 8. ####
#
#
# Hra popsaná v příkladu 7 nebyla férová. Jakou kouli (červenou nebo bílou) musíme do
# urny přidat, aby hra férová byla?

combn(c('cerna','cerna','cerna','cervena'),2)
combn(c('cerna','cerna','cervena','cervena'),2)

# * Příklad 9. ####
#
# Chcete hrát Člověče nezlob se, ale ztratila se hrací kostka. Čím a jak lze nahradit
# hrací kostku,
# máte-li k dispozici hrací karty (balíček 32 karet) a 4 různobarevné kuličky?

# * Příklad 10. ####
#
# Chcete hrát Člověče nezlob se, ale ztratila se hrací kostka. Jak lze nahradit hrací
# kostku, máte-li
# k dispozici 3 různobarevné kuličky?

# * Příklad 11. ####
#
# V prodejně vozů Škoda mají v měsíci únoru prodejní akci. Ke standardnímu vybavení
# nabízejí
# 3 položky z nadstandardní výbavy zdarma. Nadstandardní výbava zahrnuje 7 položek:
# - tempomat, vyhřívání sedadel, zadní airbagy, xenonová světla, stropní okénko,
# bezpečnostní
# zámek převodovky, speciální odolný metalízový lak.
#
# Kolik možností má zákazník, jak zvolit 3 položky z nadstandardní výbavy?

kombinace(7,3)

# * Příklad 12. ####
#
#  Při zkoušce si do 5. řady sedlo 12 studentů. Zkoušející chce určit sám, jak tyto
# studenty v řadě
# rozesadit.
# - Kolik je možností jak studenty rozesadit?
# - Student Brahý žádá, aby mohl sedět na kraji a odejít dříve, aby stihl vlak. Kolik je
# možností jak studenty rozesadit, chce-li zkoušející vyhovět požadavku studenta
# Brahého?
# - Kolik je možností jak studenty rozesadit, nesmějí-li Pažout a Horáček sedět vedle
# sebe?

#a
permutace(12)
prazdnych_sedadel=8
permutace_opak(c(1,1,1,1,1,1,1,1,1,1,1,1,prazdnych_sedadel))
#b
1*permutace(11)+permutace(11)*1
#c
vedle_sebe=permutace(11)+permutace(11)
permutace(12)-vedle_sebe

# * Příklad 13. ####
#
# Kolik anagramů lze vytvořit ze slova STATISTIKA?

statistika=c(2,3,2,2,1)
permutace_opak(statistika)

# * Příklad 14. ####
#
# V Tescu dostali nové zboží – 6 druhů chlapeckých trik. Od každého druhu mají alespoň 7
# kusů.
# Maminka chce synovi koupit 4 trika. Kolik je možností, jak je vybrat
# - mají-li být všechna různá?
# - připouští-li, že mohou být všechna stejná?

#a
kombinace(6,4)
#b
kombinace_opak(6,4)

# * Příklad 15. ####
# Kolik hesel délky 5 můžeme vytvořit ze znaků abecedy
# - nejsou-li rozlišována velká a malá písmena?
# - jsou-li rozlišována velká a malá písmena?

#a
variace_opak(26,5)
#b
variace_opak(52,5)


#The built-in standard deviation function applies the Bessel correction.  To reverse this, we can apply an uncorrection.
#If na.rm is true, missing data points (NA values) are removed.
 reverseBesselCorrection <- function(x, na.rm=FALSE)
 {
   if(na.rm) x <- x[!is.na(x)]
   len <- length(x)
   if(len < 2) stop("2 or more data points required")
   sqrt((len-1)/len)
 }
 testdata <- c(2,4,4,4,5,5,7,9)
 reverseBesselCorrection(testdata)*sd(testdata) #2


sample_size=c(6,6,6,6,6)

# l=y1bar-(y2bar+y3bar+y4bar+y5bar)/4

# thus we identify a1 = 4, a2 = -1, a3 =-1, a4 = -1 , a5=-1
a=c(4,-1,-1,-1,-1)

test=0
i=1
while(i<=length(sample_size)){
  test=test+a[i]^2
  i=i+1
}
print(test)
y1bar=1.175
y2bar=1.293
y3bar=1.328
y4bar=1.415
y5bar=1.500
l=4*y1bar-y2bar-y3bar-y4bar-y5bar
print(l)
# we can obtain the sum of squares associated with the contrast from
SSC1=(sample_size[1]*(l^2))/test
print(SSC1)

a=c(0,1,1,-1,-1)
test=0
i=1
while(i<=length(sample_size)){
  test=test+a[i]^2
  i=i+1
}
l=0*y1bar+y2bar+y3bar-y4bar-y5bar
# we can obtain the sum of squares associated with the contrast from
SSC2=(sample_size[2]*(l^2))/test
print(SSC2)

a=c(0,1,-1,0,0)
test=0
i=1
while(i<=length(sample_size)){
  test=test+a[i]^2
  i=i+1
}
l=0*y1bar+y2bar-y3bar+0*y4bar+0*y5bar
# we can obtain the sum of squares associated with the contrast from
SSC3=(sample_size[2]*(l^2))/test
print(SSC3)

a=c(0,0,0,1,-1)
test=0
i=1
while(i<=length(sample_size)){
  test=test+a[i]^2
  i=i+1
}
l=0*y1bar+0*y2bar+0*y3bar+y4bar-y5bar
# we can obtain the sum of squares associated with the contrast from
SSC4=(sample_size[2]*(l^2))/test
print(SSC4)


x = c(-3, -1, 1, 3, 5, 7)
y = c(14, 4, 2, 8, 22, 44)

n = length(x)

num = sum(x * y) - sum(x) * sum(y) / n
den = sum(x * x) - sum(x) * sum(x) / n

B1 = num / den
B0 = (sum(y) - (B1 * sum(x))) / n

png('images/disp_diagram.png')
plot(x, y)
dev.off()

B0
B1

print('For x = 0 predicted value is')
print(B1 * 0 + B0)

print('For x = 2 predicted value is')
print(B1 * 2 + B0)


softmax <- function (x) {
    m <- max(x)
    exps <- exp(x - m)
    s <- sum(exps)
    return(exps / s)
}


library(Biodem)
m <- matrix(c(3,2,2,1), nrow=2)
mtx.exp(m, 0)
#      [,1] [,2]
# [1,]    1    0
# [2,]    0    1
mtx.exp(m, 1)
#      [,1] [,2]
# [1,]    3    2
# [2,]    2    1
mtx.exp(m, 2)
#      [,1] [,2]
# [1,]   13    8
# [2,]    8    5
mtx.exp(m, 3)
#      [,1] [,2]
# [1,]   55   34
# [2,]   34   21
mtx.exp(m, 10)
#         [,1]   [,2]
# [1,] 1346269 832040
# [2,]  832040 514229


#' The Epanechnikov kernel
#' @param R vector of distances to convert to weights
#' @param bw bandwidth of the kernel
#' @return vector of kernel weights, given by \eqn{1 - (R / bw)^2} if \eqn{R < bw}; otherwise 0
#' @export
epanechnikov = function(R, bw) {
    ifelse( R < bw, 1-(R/bw)**2, 0)
}

#' The cubic kernel
#' @param d vector of distances to convert to weights
#' @param bw bandwidth of the kernel
#' @return vector of kernel weights, given by \eqn{1 - (7 * (d / bw)^2 - 8.75 * (d / bw)^3 + 3.5 * (d / bw)^5 - 0.75 * (d / bw)^7} if \eqn{d < bw}; otherwise 0
#' @export
cubic = function(d, bw) {
    ifelse(d<bw, 1 - (7*(d/bw)**2 - 8.75*(d/bw)**3 + 3.5*(d/bw)**5 - 0.75*(d/bw)**7), 0)
}

#' The spherical kernel
#' @param d vector of distances to convert to weights
#' @param bw bandwidth of the kernel
#' @return vector of kernel weights, given by \eqn{1 - 1.5 * (d / bw) + 0.5 * (d / bw)^3} if \eqn{d < bw}; otherwise 0
#' @export
spherical = function(d, bw) {
    ifelse(d<bw, 1 - 1.5*(d/bw) + 0.5*(d/bw)**3, 0)
}

#' The bisquare kernel
#' @param R vector of distances to convert to weights
#' @param bw bandwidth of the kernel
#' @return vector of kernel weights, given by \eqn{(1 - (R / bw)^2)^2} if \eqn{R < bw}; otherwise 0
#' @export
bisquare = function(R, bw) {
    ifelse( R < bw, (1 - (R/bw)**2)**2, 0)
}


=begin
  ----------^ sample-jordanform01.rb
  require "algebra"

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

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

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

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

  m = m.convert_to(jf.type)
  p jf == pt * m * qt #=> true
  ----------$ sample-jordanform01.rb
=end


# Example : 2.5A   Chapter : 2.5   Pageno : 87
# Inverse of difference matrix is Sum matrix
A<-matrix(c(1,-1,0,0,1,-1,0,0,1),ncol=3)
A1<-solve(A)
print("Inverse of the difference matrix is singular ")
print(A1)


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

kNN <- function(dataset, points, k, dist = euclidean) {
  answer <- array(dim=c(length(points[,1])))

  for (i in 1:length(points[,1])) {
    distance <- array(dim=dim(dataset)[1])
    for (j in 1:dim(dataset)[1]) {
      distance[j] <- dist(dataset[j, 3:4], points[i,])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- c(0, 0, 0)
    names(classesCount) = unique(iris$Species)
    for (j in 1:k) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1
    }
    answer[i] = names(which.max(classesCount))[1]
  }

  return (answer)
}

fast_cvloo_knn <- function() {
  maxK <- length(iris[,1]) - 1
  classes = unique(iris$Species)

  ans <- rep(x = 0, times = maxK)
  for (i in 1:length(iris[,1])) {
    # for (i in 1:10) {
    cat("\r", "Processing sample ", i, " of ", length(iris[,1]))
    dataset <- iris[-i,]
    # print(dataset)
    distance <- array(dim=c(length(dataset[,1])))
    for (j in 1:(length(dataset[,1]))) {
      distance[j] <- euclidean(dataset[j, 3:4], iris[i, 3:4])
    }
    sortedDataset <- dataset[order(distance),]

    classesCount <- rep(x = 0, times = length(classes))
    names(classesCount) = classes
    for (j in 1:maxK) {
      classesCount[sortedDataset$Species[j]] <- classesCount[sortedDataset$Species[j]] + 1

      classForCurrentK = names(which.max(classesCount))[1]
      if (classForCurrentK == iris$Species[i]) {
        ans[j] = ans[j] + 1
      }
    }

  }
  cat("\n")
  for (i in 1:length(ans)) {

    ans[i] = ans[i] / length(iris[,1] - 1)
  }

  return (ans)
}

par(mfrow=c(1,2), pty="s")
# LOO CV, looking for the best k
stats <- fast_cvloo_knn()
plot(1:(length(iris[,1]) - 1), stats, type="l", xlab="k", ylab="Accuracy")

maxPoint = which(stats == max(stats))
points((1:(length(iris[,1]) - 1))[maxPoint], stats[maxPoint], pch = 19, col = "red")

bestK <- which.max(stats)
cat("Best K =", bestK, "\n")

# k-NN demo
z <- array(dim=c(10, 2))
for (i in 1:length(z[,1])) {
  z[i,] = c(runif(1, min = 1, max = 7), runif(1, min = 0, max = 2.5))
}

print(z)

result <- kNN(iris, z, 5)

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], bg = colors[result], pch = 22)


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

rf <- 0.02  # 2% interest rates
num.sims <- 100000 # 100,000 simulations
s0 <- 90  # underlier price at t=0
s.bar <- 95
K <- 102  # strike price
sigma <- 0.25  # volatility of underlier log-returns
T <- 2  # 2 years = option expiry
tau <- 1  # mid-life of one-year bond
lambda <- 2  # mean reversion rate; 2 => half-life = ln(2)/2 = 0.35 years

## arithmetic Brownian motion; normal underlier price
w1 <- rnorm(num.sims) # simulated W_T values
sigma.abm <- sigma*s0  # rescale volatility for initial prife level
s.sim.abm <- s0 + rf*T + sigma.abm*sqrt(T)*w1
opt.payoff.abm <- pmax(s.sim.abm - K, 0)
opt.value.abm <- mean(opt.payoff.abm)*exp(-rf*T)

## geometric Brownian motion; normal underlier log-returns
w2 <- rnorm(num.sims) # simulated W_T values
s.sim.gbm <- s0*exp((rf-sigma^2/2)*T + sigma*sqrt(T)*w2)
opt.payoff.gbm <- pmax(s.sim.gbm - K, 0)
opt.value.gbm <- mean(opt.payoff.gbm)*exp(-rf*T)

## Ornstein-Uhlenbeck process for underlier price
w3 <- rnorm(num.sims) # simulated W_T values
s.sim.ou <- s.bar + exp(-lambda*T)*(s0-s.bar) + sigma*s.bar*
        sqrt((1-exp(-2*lambda*T))/(2*lambda))*w3
opt.payoff.ou <- pmax(s.sim.ou - K, 0)
opt.value.ou <- mean(opt.payoff.ou)*exp(-rf*T)

## Brownian bridge; two-year bond maturing at 100
## option is struck at 102 in year 1
## FYI: vol of 0.25 is very high for a two-year bond
w4 <- rnorm(num.sims) # simulated W_tau values
s.bar.bb <- s0 + (100-s0)*tau/T
s.sim.bb <- s.bar.bb + sigma*s.bar.bb*sqrt(tau/T*(T-tau)/T)*w4
opt.payoff.bb <- pmax(s.sim.bb - K, 0)
opt.value.bb <- mean(opt.payoff.bb)*exp(-rf*tau)


# Plot of generator function for frank cupola
library(copula)
u= seq(0.000001, 1, length=500)
frank = iPsi(copula=archmCopula(family="frank", param=1), u)
plot(u, frank, type="l", lwd=3, ylab=expression(phi(u)))
abline(h=0)
abline(v=0)

## Scatter plot of 9 bivariate frank copulas
set.seed(5640)
theta = c(-100, -50, -10, -1, 0, 5, 20, 50, 500)
par(mfrow=c(3,3), cex.axis=1.2, cex.lab=1.2, cex.main=1.2)
for(i in 1:9){
  U= rCopula(n=200, copula=archmCopula(family="frank", param=theta[i]))
  plot(U, xlab=expression(u[1]), ylab=expression(u[2]),
                          main=eval(substitute(expression(paste(theta, " = ", j)),
                         list(j = as.character(theta[i])))))
}


birthday  = function(k)
{
	prod = 1
	for(i in (365-k+1):365)
	{
		prod = prod*i
	}

	return (1-prod/(365^k))
}

num_people = c(2:50)
probability = c()
for(i in 1:length(num_people))
{
	res = birthday(num_people[i])
	probability = cbind(probability, res)
}

plot(num_people, probability, type="l", xlab="number of people", ylab="probability of birthday match")
abline(h = 0.5, col="red", lty="dashed")
title("Birthday problem")


crime_rate=c(876,578,718,388,562,971,698,298,673,537,642,856,376,508,529,393,354,735,811,504,807,719,464,410,491,557,771,685,448,571,189,661,877,563,647,447,336,526,624,605,496,296,628,481,224,868,804,210,421,435,291,393,605,341,352,374,267,684,685,460,466,498,562,739,562,817,690,720,758,731,480,559,505,703,809,706,631,626,639,585,570,928,516,885,751,561,1020,592,814,843)

lower_quartile= 464.5
upper_quartile=718.5 # calculated in previous example

iqr=IQR(crime_rate)

lower_inner_fence= lower_quartile - (1.5*iqr)
upper_inner_fence= upper_quartile + (1.5*iqr)
lower_outer_fence= lower_quartile - (3*iqr)
upper_outer_fence= upper_quartile +(3*iqr)
print(lower_inner_fence)
print(upper_inner_fence)
print(lower_outer_fence)
print(upper_outer_fence)


#number of trials
n<-5
#  the probability of success when one person is selected from the population is
z<-0.9
#   probability that exactly one person in the sample of five households is unemployed.

y<-4
probability_forexactone_unemployed<-(factorial(n))/(factorial(y)*factorial(n-y))*(z^y)*(1-z)^(n-y)
print(probability_forexactone_unemployed)
# the probability of one or fewer being unemployed
probability_foroneorfew_unemployed=((factorial(n))/(factorial(4)*factorial(n-4))*(z^4)*(1-z)^(n-4))+((factorial(n))/(factorial(5)*factorial(n-5))*(z^5)*(1-z)^(n-5))
print(probability_foroneorfew_unemployed)


##########################
# SECTION 2.13: INDEXING #
##########################

# open dataset
library(dslabs)
data('murders')

# define population, total and state
population <- murders$population
total <- murders$total
state <- murders$state

# ------------------------
# Subsetting with logicals
# ------------------------

# calculating murders rate per population
rate <- total / population * 100000

# which state have murder rates inferior than 0.71?
index <- rate < 0.71
index
state[index]

# logical operators are integers, also. we can sum up them!
# hence, how many state have murder rates inferior than 0.71?
sum(index)

# ------------------------
# Logical operators
# ------------------------

# the logical operator AND (&) return return TRUE when both
# of the given conditions are true.

# select state with murder rates equal or inferior than 1.2
# and located on the west:
safe <- rate <= 1.0
west <- murders$region == 'West'
index <- safe & west
state[index]

# ------------------------
# Which, match and %in%
# ------------------------

# The function `which` tells us which entries of a logical vector are TRUE.
# We can acess the murder rate of California:
ind <- which(state == "California")
rate[ind]

# The `match` function tells us which indexes of a second vector match each of the entries of a first vector.
# Say we wish to subsect the states vector, containing only New York, Florida and Texas:
ind <- match(c("New York", "Florida", "Texas"), state)
ind

# Thus, we can look at the rates of these states:
rate[ind]

# The `%in%` operator is kinda like the same in python: it tells us whether or not each element of a first vector is in a second.
# Let’s imagine you are not sure if Boston, Dakota, and Washington are states. You can find out like this:
c("Boston", "Dakota", "Washington") %in% state


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(2.7, 2.4, 1.9, 2.6, 2.4, 1.9, 2.3,
            2.2, 2.5 ,2.3 ,1.8, 2.5, 2.0 ,2.2 )
confidence_interval(vector, 0.95)


skew=function(x)
{
	n = length(x)
	nfact = n/((n - 1) * (n - 2))
	xm = mean(x)
	xv = sqrt(var(x))
	skw = sum((x - xm)^3)
	skew = (nfact * skw)/xv^3
	skew
}


# Mean and Standard Deviation of the Binomial Probability Distribution
#number of trials
n<-1218
#  the probability of success of single event  is
z<-0.5
Mean<-n*z
print(Mean)
standard_deviation=sqrt(n*z*(1-z))
print(standard_deviation)
# survey of 1,218 customersrevealsthat 516 would add the new service
observed_valueof_y=516
# y = 516 is more than (3 * standard_deviation), or 52.35, less than Mean
# thus the observed number of customers in sample who would add the new service is too small
print(" Consequently, the company concluded that offering the new service was not a good idea")


#### deterministic L Matrices ####
determL <- function(typeL, m, n, k ) {
  # returns a deterministic L Matrix as described in Ledermann et al (2011)
  #
  # Steps:
  #   1. find pre image v
  #   2. get GS image w
  #   3. select n last columns of w
  #
  # Example
  # ==========
  # l = detemL('Ledermann',10,2)
  #
  # Parameters
  # ==========
  # m : int
  #   number of rows in l
  # n : int
  #   number of columns in l
  # k : int
  #   additional parameter for Type I,II,III L matrices
  #
  # Output
  # ==========
  # l : numeric (two dimensional array)
  #   deterministic L Matrix

  ## Assertion
  if (!any(typeL==c('Ledermann', 'TypeI','TypeII', 'TypeIII','Type I','Type II','Type III','I','II', 'III'))) {
    stop(sprintf("unkown type %s for type of deterministic L Matrix", typeL))}
  if (nargs() < 3) {
    stop("not enough input arguments")}
  if (!m%%1==0) {
    stop(sprintf("%f is not an integer value", m))}
  if (!n%%1==0) {
    stop(sprintf("%f is not an integer value", n))}
  if (!typeL=='Ledermann' & !nargs()==4){
    stop("L Matrices of Type I-III need an additional integer parameter k")}

  ## find pre-image
  # Ledermann
  if (typeL %in% c('Ledermann')){
    v = matrix(0, m, m-1)
    for (c in 1:m-1) {
      v[c,c] = 1
      v[c+1,c] = -1
    }

  # Type I
  } else if (typeL %in% c('TypeI', 'Type I', 'I')){
    if (!(2*k <= m+1-n)) {
      stop(" relation 2*k <= m+1-n not fullfilled see Ledermann 2011")
    }
    v <- matrix(0, m, m+1-2*k)
    for (c in 1:(m+1-2*k)) {
      v[c:(c+2*k-1), c] <- rep(c(1,-1),k)
    }

  # Type II
  } else if (typeL %in% c('TypeII', 'Type II', 'II')){
    if (!(m-k >= n)) {
      stop(" relation m-k < n not fullfilled see Ledermann 2011")
    }
    v <- matrix(0, m, m-k)
    for (c in 1:(m-k)) {
      v[c:(c+k-1), c] <- rep(1,k)
      v[c+k, c] <- -k
    }
  # Type III
  } else if (typeL %in% c('TypeIII', 'Type III', 'III')){
    if (!(m-2 >= n)) {
      stop(" relation m-2 >= n not fullfilled see Ledermann 2011")
    }
    v <- matrix(0, m, m-2)
    for (c in 1:(m-2)) {
      v[c, c] <- k
      v[c+1, c] <- -1
      v[c+2, c] <- 1-k
    }
  }

  ## get GS image w
  w <- gramSchmidt(l)$Q

  ## select n last columns of w
  return(w[ , (ncol(w)-(n-1)):ncol(w)])
}

#### data-specific L Matrices ####
dataL <- function(y) {
  # returns a data-specific L Matrix as described in Ledermann et al (2011)
  # Steps:
  #   1. de-mean
  #   2. orthogonalize with GS
  #
  # Example
  # ==========
  #   l = dataL(y)
  #
  # Parameters
  # ==========
  #   y : numeric (tow dimensional array)
  # original sample
  #
  # Output
  # ==========
  #   l : numeric (two dimensional array)
  # data-specific L Matrix

  ## Assertion
  if (!ncol(y)<nrow(y)) {
    stop("Sample must have more rows (observations) than columns (risk factors)")}

  ## de-mean
  v <- y - matrix(apply(y, 2, mean),nrow(y),ncol(y),byrow=TRUE)

  ## orthogonalize with GS
  return(gramSchmidt(v)$Q)
}


#### #### #### #### #### #### #### #### #### #### ####
####
#### ICA
#### http://rstudio-pubs-static.s3.amazonaws.com/93614_be30df613b2a4707b3e5a1a62f631d19.html
#### #### #### #### #### #### #### #### #### #### ####

rm(list=ls())

library(fastICA)

# Generiamo dei dati
S <- cbind(sin((1:1000)/20), rep((((1:200)-100)/100), 5))
# vediamo cosa abbiamo generato
par(mfrow=c(1,2))
plot(1:1000, S[,1], type = "l",xlab = "S1", ylab = "")
plot(1:1000, S[,2], type = "l", xlab = "S2", ylab = "")
par(mfrow=c(1,1))

# Creiamo un segnale misto
# Matrice dei "pesi"
A <- matrix(c(0.291, 0.6557, -0.5439, 0.5572), 2, 2)
A
# Mixiamo i segnali
X <- S %*% A
# vediamo il nuovo segnale
par(mfrow=c(1,2))
plot(1:1000, X[,1], type = "l",xlab = "X1", ylab = "")
plot(1:1000, X[,2], type = "l", xlab = "X2", ylab = "")
par(mfrow=c(1,1))

# Implementiamo ICA
a <- fastICA(X, 2, alg.typ = "parallel", fun = "logcosh", alpha = 1,
             method = "R", row.norm = FALSE, maxit = 200,
             tol = 0.0001, verbose = TRUE)

# vediamo i risultati
par(mfrow=c(1,2))
plot(1:1000, a$S[,1], type = "l", xlab = "S'1", ylab = "")
plot(1:1000, a$S[,2], type = "l", xlab = "S'2", ylab = "")
par(mfrow=c(1,1))

# confrontiamo con i dati originali
par(mfrow=c(1,2))
plot(1:1000, a$S[,2]/S[,1], type = "l", xlab = "Ratio S'1", ylab = "")
plot(1:1000, a$S[,1]/S[,2], type = "l", xlab = "Ratio S'2", ylab = "")
par(mfrow=c(1,1))

# proviamo ad aumentare il numero di classi
a3 <- fastICA(X, 3, alg.typ = "parallel", fun = "logcosh", alpha = 1,
             method = "R", row.norm = FALSE, maxit = 200,
             tol = 0.0001, verbose = TRUE)

# Aggiungiamo del rumore
a3 <- fastICA(cbind(X,rnorm(nrow(X),0,0.2)), 3, alg.typ = "parallel", fun = "logcosh", alpha = 1,
             method = "R", row.norm = FALSE, maxit = 200,
             tol = 0.0001, verbose = TRUE)

par(mfrow=c(1,3))
plot(1:1000, a3$S[,1], type = "l", xlab = "S", ylab = "")
plot(1:1000, a3$S[,2], type = "l", xlab = "S", ylab = "")
plot(1:1000, a3$S[,3], type = "l", xlab = "S", ylab = "")
par(mfrow=c(1,1))


#' n-sided polygons
#' Calculate the coordinates for an nsided polygon
#' @param x,y Numeric scalar. Origin of the polygon.
#' @param n Integer scalar. Number of sides.
#' @param r Numeric scalar. Radious of the polygon.
#' @param d Numeric scalar. Starting degree in radians.
#' @return
#' A two column matrix with the coordinates to draw a n sided polygon.
#' @examples
#' graphics.off()
#' oldpar <- par(no.readonly = TRUE)
#'
#' par(xpd = NA, mfrow = c(3, 3), mai = rep(0, 4))
#' for (n in c(2, 3, 4, 5, 6, 8, 12, 20, 50)) {
#'
#'   plot.new()
#'   plot.window(c(-1.25,1.25), c(-1.25,1.25))
#'
#'   for (i in seq(1, .0005, length.out = 200)) {
#'     col <- adjustcolor("tomato", alpha.f = i)
#'     polygon(npolygon(x=(i-1)/4, y = (i-1)/4, r = i, d = i-1, n = n),
#'             col = NA, border=col)
#'   }
#'
#'   mtext(sprintf("n = %i", n), side = 1, line = -3)
#' }
#'
#' par(oldpar)
#' @export
npolygon <- function(
  x = 0,
  y = 0,
  n = 6L,
  r = 1.0,
  d = 2.0*pi/(n)/2
) {

  deg <- seq(d, 2.0*pi + d, length.out = n + 1)[-(n+1)]

  coords <- cbind(
    x = cos(deg)*r + x,
    y = sin(deg)*r + y
  )

}


# Goal: To do nonlinear regression, in three ways
#       By just supplying the function to be fit,
#       By also supplying the analytical derivatives, and
#       By having him analytically differentiate the function to be fit.
#
# John Fox has a book "An R and S+ companion to applied regression"
# (abbreviated CAR).
# An appendix associated with this book, titled
#   "Nonlinear regression and NLS"
# is up on the web, and I strongly recommend that you go read it.
#
# This file is essentially from there (I have made slight changes).

# First take some data - from the CAR book --
library(car)
data(US.pop)
attach(US.pop)
plot(year, population, type="l", col="blue")

# So you see, we have a time-series of the US population. We want to
# fit a nonlinear model to it.

library(stats)                            # Contains nonlinear regression
time <- 0:20
pop.mod <- nls(population ~ beta1/(1 + exp(beta2 + beta3*time)),
  start=list(beta1=350, beta2=4.5, beta3=-0.3), trace=TRUE)
# You just write in the formula that you want to fit, and supply
# starting values. "trace=TRUE" makes him show iterations go by.

summary(pop.mod)
# Add in predicted values into the plot
lines(year, fitted.values(pop.mod), lwd=3, col="red")

# Look at residuals
plot(year, residuals(pop.mod), type="b")
abline(h=0, lty=2)

# Using analytical derivatives:
model <- function(beta1, beta2, beta3, time) {
  m <- beta1/(1+exp(beta2+beta3*time))
  term <- exp(beta2 + beta3*time)
  gradient <- cbind((1+term)^-1,
                    -beta1*(1+term)^-2 * term,
                    -beta1*(1+term)^-2 * term * time)
  attr(m, 'gradient') <- gradient
  return(m)
}

summary(nls(population ~ model(beta1, beta2, beta3, time),
            start=list(beta1=350, beta2=4.5, beta3=-0.3)))

# Using analytical derivatives, using automatic differentiation (!!!):
model <- deriv(~ beta1/(1 + exp(beta2+beta3*time)), # rhs of model
               c('beta1', 'beta2', 'beta3'), # parameter names
               function(beta1, beta2, beta3, time){} # arguments for result
               )
summary(nls(population ~ model(beta1, beta2, beta3, time),
            start=list(beta1=350, beta2=4.5, beta3=-0.3)))

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


rm(list=ls())

dim_rf <- 10

matrix(0,dim_rf,dim_rf)

matrix(1:dim_rf,dim_rf)

matrix(1:(dim_rf*dim_rf),dim_rf)

runif(10)

rf <- matrix(runif(dim_rf*dim_rf),ncol=dim_rf)

rf

set_tree <- function(elem,prob) {
  if(elem>prob)
    elem <- 0
  else
    elem <- 1
}

rf <-apply(rf,1:2,set_tree,0.5)

rf

image(rf,asp=1,axes=F,col=c("white","black"))

image(rf)

generate_rf <- function(sideDim,p)
{
  rf <- matrix(runif(sideDim*sideDim),ncol=sideDim)
  rf <-apply(rf,1:2,set_tree,p)
  #image(rf,asp=1,axes=F,col=c("white","black"))
  return(rf)
}

generate_rf(100,0.4)

generate_rf(100,0.5)

rf <- generate_rf(10,0.5)

rf

rf[1,] <- 2

for(j in 1:ncol(rf))
{

  if( rf[1,j]==2 & rf[2,j]==1)
    rf[2,j] <- 2
}

rf

for(i in 2:nrow(rf))
  for(j in 1:ncol(rf))
  {
    if( rf[i-1,j]==2 & rf[i,j]==1)
      rf[i,j] <- 2
  }

image(rf,asp=1,axes=F,col=c("white","black","red"))

for(i in 2:nrow(rf))
  for(j in 2:(ncol(rf)-1))
  {
    if( (rf[i-1,j]==2 || rf[i-1,j-1]==2 ||
                   rf[i-1,j+1]==2) && rf[i,j]==1)
      rf[i,j] <- 2
  }

image(rf,asp=1,axes=F,col=c("white","black","red"))

# This function only propagate the fire in one direction
#
fire_rf <- function(rf) {
  dimi=nrow(rf)
  dimj=ncol(rf)-1
  rf[1,] <- 2
  for(i in 2:dimi)
    for(j in 2:dimj)
    {
      if((rf[i-1,j]==2 || rf[i-1,j-1]==2 || rf[i-1,j+1]==2) && (rf[i,j]==1))
        rf[i,j] <- 2
    }
  image(rf,asp=1,axes=F,col=c("white","green","red"))
  return(rf)
}

rf <- generate_rf(100,0.5)

rf1 <- fire_rf(rf)

image(rf1,asp=1,axes=F,col=c("white","green","red"))

countBurned <- function(rf)
{
  bur <-0
  dimi=nrow(rf)
  dimj=ncol(rf)

  for(i in 2:dimi)
    for(j in 1:dimj)
    {
      if(rf1[i,j]==2 )
        bur <- bur + 1
    }
  return(bur/((dimi-1)*dimj))
}

rf <- generate_rf(100,0.4)
rf1 <- fire_rf(rf)
countBurned(rf1)

# Make a plot of the proportion of burned
# sites versus p (probability of tree establishment)
#

pp <- seq(0.1,.9,0.05)
propBurned <- pp
for(i in 1:length(pp) )
{
  rf <- generate_rf(200,pp[i])
  rf1 <- fire_rf(rf)
  propBurned[i] <- countBurned(rf1)
}

plot(propBurned ~ pp)

df <- data.frame(pp,propBurned)

require(ggplot2)

ggplot(df,aes(x=pp,y=propBurned))+geom_line()

## Infection in 1 dimension
#
# Now we have to propagate the infection
# there are two possibilities: contagion with
# probability lambda or recuperation with
# probability mu
#
# dim_in: is the size of the infection
# time_in: is the time
#
simulate_inf <- function(lambda,mu,dim_in,time_in){

  inf<-matrix(0,time_in,dim_in)
  inf[1,] <- ifelse(runif(dim_in)>0.5,1,0)
  for(i in 1:(time_in-1))
    for(j in 2:(dim_in-1))
    {
      if(inf[i,j]==0){

        if(inf[i,j-1]==1){
          inf[i+1,j] <- ifelse(runif(1)<=lambda,1,0)
        }
        else if(inf[i,j+1]==1 ){
          inf[i+1,j] <- ifelse(runif(1)<=lambda,1,0)
        }
      }
      else
      {
        inf[i+1,j] <- ifelse(runif(1)<=mu,0,1)
      }
    }
  image(inf,asp=1,axes=F,col=c("grey","brown"))
}

simulate_inf(.4,.3,50,100)


diabetes <- matrix(c(326,160,8,64), nrow=2)
colnames(diabetes) <- c("DiabNO", "DiabYes")
rownames(diabetes) <- c("StressNO", "StressYes")
TableDiabetes <- as.table(diabetes)

DfBiabetes <- as.data.frame(TableDiabetes)

LogModel <- glm(Var2 ~ Var1, weights = Freq, data = DfBiabetes, family = binomial(logit))
summary(LogModel)

Px0=(exp(-3.7075))/(1+exp(-3.7075))
Px0
Px1=(exp(-3.7075+2.7912))/(1+exp(-3.7075+2.7912))
Px1

Oddsx0=exp(-3.7075)
Oddsx0
Oddsx1=exp(2.7912-3.7075)
Oddsx1

OR = exp(2.7912-3.7075)/exp(-3.7075)
OR

Beta = LogModel$coefficient[1]
Alpha = LogModel$coefficient[2]
Beta
Alpha

P0 <- exp(LogModel$coefficient[1]) / (1 + exp(LogModel$coefficient[1]))
P1 <- exp(LogModel$coefficient[1] + LogModel$coefficient[2]) / (1 + exp(LogModel$coefficient[1]+LogModel$coefficient[2]))
P0
P1

odds0 <- P0 / (1 - P0)
odds1 <- P1 / (1 - P1)
odds0
odds1

OR1 <- odds1 / odds0
OR1

OR2 <- (TableDiabetes[1,1]*TableDiabetes[2,2]) / (TableDiabetes[1,2]*TableDiabetes[2,1])
OR2


# Define a general vector
v <- c(1, 1, 2, 3, 5, 8, 13, 21)

# In R, operations on vector occurs *element-wise*:
v3 <- v * 3
v3

# Two vectors of the same length can be operated
a <- c(1, 2, 3, 4)
b <- c(4, 8, 12, 16)
soma <- a + b
soma
diferenca <- a - b
diferenca
multiplication <- a * b
multiplication
division <- a / b
division


library(deSolve)

diffeq <- function (t, state, f_params) {
    # State variables
    # ---------------
    # u: rabbits
    # v: foxes
    with(
        as.list(c(state, f_params)), {
            du = a*u - b*u*v
            dv = -c*v + d*b*u*v

            return(list(c(du, dv)))
        }
    )
}

f_params <- c(a = 1.0, b = 0.1, c = 1.5, d = 0.75)
state <- c(u = 10, v = 5)
t <- seq(0, 18, by = 0.01)

out <- as.data.frame(ode(func = diffeq, y = state, parms = f_params, times = t))

matplot(out[,-1], type = "l", xlab = "Time", ylab = "Population")
legend("topright", c("Rabbits", "Foxes"), lty = c(1,2), col = c(1,2), box.lwd = 0)


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

rm(list = ls())

n <- 40 - 1  # due to there was one tie
# 39

V <- 242

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

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

## Asymptotic pvalue (with continuity correction)
2 * (1 - pnorm(abs(V + 0.5 * sign(V.mean - V) - V.mean) / sqrt(V.var)))
# 0.039555378139781

## Exact
2 * (1 - psignrank(V - (V.mean < V), n, lower.tail = V.mean < V))
# 0.0385776563234685


## Dexter Barrows
## dbarrows.github.io
## McMaster University
## 2016

## ymat: 	Contains the initial conditions where:
#  			- rows are locations
#  			- columns are S, I, R
## pars: 	Contains the parameters: global values for R0, r, N, eta, berr
## T: 		The stop time. Since 0 in included, there should be T+1 time steps in the simulation
## neinum:	Number of neighbors for each location, in order
## neibmat: Contains lists of neighbors for each location
#			- rows are parent locations (nodes)
# 			- columns are locations each parent is attached to (edges)
StocSSIRstan <- function(ymat, pars, T, steps, neinum, neibmat, berrmat, bmatlim) {

	## number of locations
    nloc <- dim(ymat)[1]

    ## storage
    ## dims are locations, (S,I,R,B), times
    # output array
    out <- array(NA, c(nloc, 4, T+1), dimnames = list(NULL, c("S","I","R","B"), NULL))
    # temp storage
    BSI <- numeric(nloc)
    rI <- numeric(nloc)

    ## extract parameters
    R0 <- pars[['R0']]
    r <- pars[['r']]
    N <- pars[['N']]
    eta <- pars[['eta']]
    berr <- pars[['berr']]
    phi <- pars[['phi']]

    B0 <- rep(R0*r/N, nloc)

    ## state vectors
    S <- ymat[,'S']
    I <- ymat[,'I']
    R <- ymat[,'R']
    B <- B0

    ## assign starting to output matrix
    out[,,1] <- cbind(ymat, B0)

    h <- 1 / steps

    for ( i in 1:(T*steps) ) {

    	if (i <= bmatlim) {
		    B <- exp( log(B) + eta*(log(B0) - log(B)) + berrmat[,i])
	    } else {
	        B <- exp( log(B) + eta*(log(B0) - log(B)) + rnorm(nloc, 0, berr) )
	    }

        for (loc in 1:nloc) {
        	n <- neinum[loc]
        	sphi <- 1 - phi*(n/(n+1))
        	ophi <- phi/(n+1)
        	nBIsum <- B[neibmat[loc,1:n]] %*% I[neibmat[loc,1:n]]
        	BSI[loc] <- S[loc]*( sphi*B[loc]*I[loc] + ophi*nBIsum )
        }

        rI <- r*I

        dS <- -BSI
        dI <- BSI - rI
        dR <- rI

        S <- S + h*dS
        I <- I + h*dI
        R <- R + h*dR

        if (i %% steps == 0)
            out[,,i/steps+1] <- cbind(S,I,R,B)

    }

	return(out)

}

### Suggested parameters
#
# T       <- 60
# i_infec <- 5
# steps   <- 7
# N       <- 500
# sigma   <- 10
#
# pars <- c(R0 = 3.0,     # new infected people per infected person
#           r = 0.1,      # recovery rate
#           N = 500,      # population size
#           eta = 0.5,    # geometric random walk
#           berr = 0.5,   # Beta geometric walk noise
# 			phi = 0.5 )	  # interconnectivity degree


#
# Exemplo 2
#

# Série de MacLaurin para a exponencial de x
# para x=3 até n=4 (A série de MacLaurin é a
# mesma série de Taylor desenvolvida em torno
# de 0).
x <- 3
maclaurin <- 1 + x
maclaurin <- maclaurin + x^2 / factorial(2)
maclaurin <- maclaurin + x^3 / factorial(3)
maclaurin <- maclaurin + x^4 / factorial(4)

maclaurin
# valor real da exponencial de x
exp(x)


library(SAGx) ## for gap statistic
library(cluster) ## for hierarchical cluster, k-mean cluster & silhouette width
library(Hmisc) ## for error bar plot

set.seed(7)       ## for random number later
x1 <- c(rnorm(20, sd = .05),
        rnorm(20, mean = 1, sd = .05),
        rnorm(20, mean = 2.5, sd= .05))

## x1 dimension with 3 clusters
x2 <- 4+c(rnorm(20, sd = 0.5),
          rnorm(20, mean = 10, sd = 1.0),
          rnorm(20, mean = 10, sd = 1))

## x2 dimension with 3 clusters
plot(x1,x2)  ## scatter plot of the data

dat = cbind(x1, x2) ##  combine two vectors into one data matrix
hc0 = hclust(dist(dat), method = "ave")
## hierarchical clustering (hc) with average linkage
plot(hc0) ## plot the dendrogram of the hc result

# Using gap statistic to determine k in HC - 1
k = 6   ## check all possible numbers of clusters, 2~6
gap = rep(0, k) ## initialize the gap statistics
se = rep(0, k) ## initialize the standard error
for (i in 2:k) {
  mem = cutree(hc0, i) ## get the cluster membership by using “cuttree” on the object of hier. cluster.
  result=gap(dat, class=mem)
  ## get the gapstatistics
  gap[i] = result[1] ## extract the gap stat values se[i]=result[2] ## and the s.e. values
}

errbar(1:k, gap, gap - se, gap + se, xlab = "Number of clusters") ## error bar plot
lines(1:k, gap) ## connect them

# Using silhouette width to determine k in HC
k = 6
sil = rep(0,k)
for (i in 2:k){
  mem = cutree(hc0, i)
  aa = silhouette(mem, dist(dat))
  sil[i] = mean(aa[,3])
}
plot(1:k, sil)
lines(1:k, sil)

km = kmeans(dat, centers = 2)
mem = km$cluster
plot(x1, x2, col = mem+1)

# Use gap statistic to determine k in K-means
k = 6   ## check all possible numbers of clusters, 2~6
gap = rep(0,k)      ## initialize the gap statistics
se = rep(0, k) ## initialize the standard error
for (i in 2:k) {
  km = kmeans(dat, centers = i)
  mem = km$cluster
  result = gap(dat, class = mem) ## get the gap statistics
  gap[i] = result[1] ## extract the gap stat values se[i]=result[2] ## and the s.e. values
}

errbar(1:k, gap, gap-se, gap+se, xlab="Number of clusters") ## error bar plot
lines(1:k, gap) ## connect them

# Use silhouette width to determine k in K-means
k = 6
sil = rep(0, k)
for (i in 2:k) {
  km = kmeans(dat, centers = i)
  mem = km$cluster
  aa = silhouette(mem, dist(dat))
  sil[i] = mean(aa[,3])
}
plot(1:k, sil)
lines(1:k, sil)

# How about just let k=3 for both HC and K- means, and check
hc0 = hclust(dist(dat))
mem = cutree(hc0, 3)
plot(x1, x2, col = mem)

km = kmeans(dat, 3)
mem = km$cluster
plot(x1, x2, col = mem)

# revisit the data ...
plot(x1, x2)
plot(x1, x2, xlim = c(-0.2, 16), ylim = c(-0.2, 16))

# Scaling needed
x1.sc = x1/sd(x1)
x2.sc = x2/sd(x2)
dat.sc = cbind(x1.sc, x2.sc)
hc1 = hclust(dist(dat.sc), "ave")
plot(hc1)

# For the scaled data, perform HC and gap
K = 6
gap = rep(0, k)
se = rep(0, k)

for (i in 2:k) {
  mem = cutree(hc1, i)
  result = gap(dat.sc, class = mem)
  gap[i] = result[1]
  se[i]=result[2]
}
errbar(1:k, gap, gap-se, gap+se, xlab="Number of clusters")
mem3 = cutree(hc1, 3)
plot(x1, x2, col = mem3)
lines(1:k, gap)

# For the scaled data, perform Kmeans and gap
k = 6
gap = rep(0,k)
se = rep(0,k)
for (i in 2:k) {
  km = kmeans(dat.sc, centers = i)
  mem = km$cluster
  result = gap(dat.sc, class = mem)
  gap[i] = result[1]
  se[i] = result[2]
}

errbar(1:k, gap, gap-se, gap+se, xlab="Number of clusters")
lines(1:k, gap)

# For the scaled data, perform Kmeans and silhouette width
k = 6
sil = rep(0, k)
for (i in 2:k) {
  km = kmeans(dat.sc, centers=i)
  mem = km$cluster
  aa = silhouette(mem, dist(dat.sc))
  sil[i] = mean(aa[,3])
}
plot(1:k, sil)
lines(1:k, sil)

km = kmeans(dat.sc, centers = 3)
mem3 = km$cluster
# What???? K-means is sensitive to seeds initialization
plot(x1, x2, col=mem3)

# Recommend: Hybrid ... (hierarchical+kmeans)
# Use the seeds info from HC result
hc = hclust(dist(dat.sc), method = "ave")
mem = cutree(hc, 3)
c1 = tapply(x1.sc, mem, mean)
c2 = tapply(x2.sc, mem, mean)

# then do kmeans clustering:
km = kmeans(dat.sc, centers = cbind(c1, c2))
plot(x1, x2, col=km$cluster)


#' Calculation of significance level alpha_n
#'
#' For a given sample size n and the significance level alpha (alpha is the
#' probability for minimum one observation to fall into the outlier region)
#' the probability alpha_n for an  individual observation  to fall into the
#' outlier region is calculated.
#' @param n A sample size
#' @param alpha A significance level, default value 0.05
#' @return alpha_n
#' @keywords alpha_n
#' @export
#' @examples
#' get_alpha_n(1) # returns alpha_n = 0.05 since sample size n = 1 and default value of alpha is 0.05
#'
#' get_alpha_n(1, 0.1) # returns alpha_n = 0.1 since sample size n = 1

get_alpha_n <- function(n, alpha = 0.05) {
  if(alpha <= 0 | 1 <= alpha){
    stop(paste("alpha not beteen 0 and 1"));
  }
  if(any(n <= 0)){
    stop(paste("Sample size n not positive"));
  }
  return(1 - (1 - alpha)^(1 / n));
}

#' Robust estimates for location-scale families of distributions
#'
#' The robust estimates of the scale (Q_n) and location parameters for
#' location-scale families of distributions.
#' Implemented distributions: normal, gumbel, cauchy, laplace, logistic
#' @param x A sample
#' @param distribution The distribution name
#' @return ret The list structure with location and scale -  the estimates of location and scale parameters.
#' @keywords robust estimator
#' @export
#' @examples
#' x <- rnorm(100)
#' estimates <- get_robust_estimates(x)
#' estimates$location
#' estimates$scale
#'
#' x <- rcauchy(100)
#' estimates <- get_robust_estimates(x, "cauchy")
#' estimates
#'
#' x <- rlogis(100)
#' estimates <- get_robust_estimates(x, "logis")
#' estimates
#'

get_robust_estimates <- function(x, distribution = "norm") {
  require("robustbase");

  if(!(distribution %in% c("norm", "logis", "cauchy", "gumbel",
    "laplace", "lnorm", "extII"))){
    stop(paste("given distribution is supported yet"));
  }

  n <- length(x);
  mu <- NA;
  sigma <- NA;

  if(distribution == "lnorm") {
    x <- log(x);
  }

  k_const <- switch (distribution,
    norm = 2.22191445,
    logis = 1.307883,
    cauchy = 1.2071068,
    gumbel = 1.957615,
    extII = 1.957615,
    laplace = 1.9305030,
    lnorm = 2.22191445
  )

  sigma <- Qn(x, constant = k_const);
  med <- median(x);
  mu <- switch (distribution,
    norm = med,
    logis = med,
    cauchy = med,
    laplace = med,
    gumbel = med - 0.3665129*sigma,
    extII = med + 0.3665129*sigma,
    lnorm = med
  )

  ret <- list(location=mu, scale=sigma)
  return(ret);
}

#' constant b_n
#'
#' The calculation of the constant b_n necessary for BP test
#' @param n A sample size
#' @param m An estimate of location parameter mu (default value (theoretical) 0)
#' @param s An estimate of shape parameter sigma (default value (theoretical) 1)
#' @param distribution The distribution name
#' @param alternative The choice of alternative
#' @return ret The b_n value
#' @keywords b_n constant
#' @export
#' @examples
#' get_bn(100, distribution = "norm")
#'
get_bn <- function(n, m = 0, s = 1, distribution = "norm", alternative = "greater") {

  bn <- NA;
  if(!(alternative %in% c("greater", "less", "two.sided"))){
    stop(paste("Choose alternative from greater/less/two.sided"));
  }

  if(!(distribution %in% c("norm", "logis", "cauchy", "gumbel",
    "laplace", "lnorm", "extII"))){
    stop(paste("given distribution is supported yet"));
  }

  if(n < 3){
    stop(paste("Sample size is not sufficient"));
  }

  if(alternative == "greater" | alternative == "less") {
    if(distribution == "norm") {
      bn <- m + s*qnorm((n-1)/n);
    } else if(distribution == "gumbel") {
      bn <- m - s*log(-log(1-1/n));
    } else if(distribution == "extII") {
      bn <- m + s*log(log(n));
    } else if(distribution == "logis") {
      bn <- m + s*log(n-1);
    } else if(distribution == "cauchy") {
      bn <- m + s*n/pi;
    } else if(distribution == "lnorm") {
      bn <- exp(m + s*qnorm((n-1)/n))
    } else if(distribution == "laplace") {
      bn <- m + s*log(n/2);
    }
  } else { ## two.sided alternative
    if(distribution == "norm") {
      bn <- m + s*qnorm(1-1/(2*n));
    } else if(distribution == "logis") {
      bn <- m + s*log(2*n-1);
    } else if(distribution == "cauchy") {
      bn <- m + s*2*n/pi;
    } else if(distribution == "laplace") {
      bn <- m + s*log(n);
    } else if(distribution == "lnorm") {
      bn <- m + s*log(n);
    } else if(distribution == "gumbel") {
      bn1 <- m + s*log(log(n));
      bn2 <- m - s*log(-log(1-1/n));
      bn <- c(bn2, bn1)
    } else if(distribution == "extII") {
      bn1 <- m + s*log(log(n));
      bn2 <- m - s*log(-log(1-1/n));
      bn <- c(bn2, bn1)
    }
  }
  return(bn);
}

#' constant a_n
#'
#' The calculation of the constant a_n nessisary for BP test
#' @param n A sample size
#' @param m An estimate of location parameter mu (default value (theoretical) 0)
#' @param s An estimate of shape parameter sigma (default value (theoretical) 1)
#' @param distribution The distribution name
#' @param alternative The choice of alternative
#' @return ret The a_n value
#' @keywords a_n constant
#' @export
#' @examples
#' get_an(100, distribution = "norm")
#'
#'
get_an <- function(n, m = 0, s=1, distribution = "norm", alternative = "greater"){
  an <- NA;

  if(!(alternative %in% c("greater", "less", "two.sided"))){
    stop(paste("Choose alternative from greater/less/two.sided"));
  }

  if(!(distribution %in% c("norm", "logis", "cauchy", "gumbel",
    "laplace", "lnorm", "extII"))){
    stop(paste("given distribution is supported yet"));
  }

  if(n < 3){
    stop(paste("Sample size is not sufficient"));
  }

  if(alternative == "greater" | alternative == "less") {
    if(distribution == "norm") {
      an <- s/qnorm(1 - 1/n)
    } else if(distribution == "gumbel") {
      an <- -s/((n-1)*log(1-1/n))
    } else if(distribution == "extII") {
      an <- s/log(log(n))
      #an <- s/exp(-log(log(n)))
    } else if(distribution == "logis") {
      an <- s*n/(n-1);
    } else if(distribution == "cauchy") {
      an <- s*n/pi;
    } else if(distribution == "lnorm") {
      bn <- get_bn(n, m, s, distribution);
      an <- s*bn/(n*dnorm(qnorm(1 - 1/n)))
    } else if(distribution == "laplace") {
      an <- s;
    }
  } else {
    if(distribution == "norm") {
      an <- s/qnorm(1 - 1/(2*n))
    }  else if(distribution == "logis") {
      an <- s*4*n/(2*n-1);
    } else if(distribution == "cauchy") {
      an <- s*2*pi/(2*n*(sin(pi/(2*n)))^2);
    } else if(distribution == "laplace") {
      an <- 2*s;
    }  else if(distribution == "lnorm") {
      bn <- get_bn(n, m, s, distribution);
      an <- s*bn/(n*dnorm(qnorm(1 - 1/(2*n))))
    } else if(distribution == "gumbel") {
      an1 <- s/(log(n))
      an2 <- -s/((n-1)*log(1-1/n))
      an <- c(an2, an1)
    } else if(distribution == "extII") {
      an1 <- s/(log(n))
      an2 <- -s/((n-1)*log(1-1/n))
      an <- c(an2, an1)
    }
  }
  return(an);
}

#' Critical values of BP test
#'
#' The method with estimated aproximations of critical values.
#' For two.sided alternatives the exact approximations were provided.
#' For less common configurations the simulation is applied and exact critical value is calculated.
#' @param n A sample size
#' @param s A upper limit (default s=5)
#' @param alpha The significance level  (default: 0.05)
#' @param distribution The distribution name
#' @param alternative The choice of alternative ("two.sided"/"greater"/"less")
#' @param gen_num The number of simulations to used in order to calculate p-value.
#' @return ret The critical value of statistics U
#' @keywords BP critical values
#' @export
#' @examples
#' get_critical(100)
#'
#'
get_critical <- function(n, s = 5, alpha = 0.05, distribution = "norm", alternative = "two.sided", gen_num = 10000) {
  critical <- NA;

  if (alternative == "two.sided") {
    if (distribution == "norm") {
      if(alpha == 0.05) {
        if (s == 5) {
          critical <- 0.9853
          return(critical)
        }
      }
    } else if (distribution == "logis") {
      if(alpha == 0.05) {
        if (s == 5) {
          x <- log(log(log(log(n))));
          if(n %% 2 == 1) {
            critical <- 1 - (0.010536      -0.006989  * x)
          }else {
            critical <- 1 - (0.005306      -0.018044  * x)
          }
          return(critical)
        }
      }
    } else if (distribution == "laplace") {
      if(alpha == 0.05) {
        if (s == 5) {
          x <- log(log(log(log(n))));
          if(n %% 2 == 1) {
            critical <- 1 - (0.009657      -0.006613 * x)
          }else {
            critical <- 1 - (0.006819      -0.013780 * x)
          }
          return(critical)
        }
      }
    } else if (distribution == "gumbel") {
      if(alpha == 0.05) {
        if (s == 5) {
          x <- log(log(log(log(n))));
          if(n %% 2 == 1) {
            critical <- 1 - (0.005755      -0.002166   * x)
          }else {
            critical <- 1 - ( 0.00302       -0.00840   * x)
          }
          return(critical)
        }
      }
    } else if (distribution == "cauchy") {
      if(alpha == 0.05) {
        if (s == 5) {
          x <- log(log(log(log(n))));
          if(n %% 2 == 1) {
            critical <- 1 - ( 0.009183      -0.003114  * x)
          }else {
            critical <- 1 - (0.008783      -0.004095   * x)
          }
          return(critical)
        }
      }
    }
  }

  if(is.na(critical)){
    r_samples <- switch(distribution,
      "norm" = lapply(rep(n, gen_num), rnorm),
      "cauchy" = lapply(rep(n, gen_num), rcauchy),
      "logis" = lapply(rep(n, gen_num), rlogis),
      "laplace" = lapply(rep(n, gen_num), rlaplace),
      "lnorm" = lapply(rep(n, gen_num), rlnorm),
      "gumbel" = lapply(rep(n, gen_num), rgumbel),
      "extII" = lapply(rep(n, gen_num), rextII)
    )
    statistics <- lapply(r_samples, bp_statistic, distribution = distribution, alternative=alternative, s = s)
    ms <- lapply(statistics, function(X){return(X$Test_statistic_U)})
    critical <- quantile(unlist(ms), 1-alpha)[[1]]

    #warning("At given s, alpha and alternative, exact critical values is not implemented.
    #  Rough approximation is used insted.")
    #critical <- (1-alpha)^(1/s)
  }
  return(critical)

}

#' Main BP statistic
#'
#' The calculation of the value of the BP test statistic U.
#' @param data A given data
#' @param distribution The distribution name
#' @param alternative The choice of alternative
#' @return ret The value of the statistic U
#' @keywords BP statistic
#' @export
#' @examples
#' x <- rnorm(100)
#' get_main_bp_statistic(x)
#'
#'
get_main_bp_statistic <-  function(data, distribution = "norm",
  alternative = "two.sided") {
  bp <- bp_statistic(data, distribution, alternative)
  return(bp$Test_statistic_U)
}

#' p-value of BP test
#'
#' The use simulation and for given conditions calculate exact p-value.
#' Since simulation is used it might take few minutes.
#' @param statistic_val A given BP statistics value
#' @param n The size of the sample
#' @param distribution The distribution name
#' @param alternative The chooise of alternative
#' @param gen_num The number of simulations to used in order to calculate p-value.
#' @return ret The p-value of given BP statistics
#' @keywords BP p-value
#' @export
#' @examples
#' x <- rnorm(100)
#' bp <- bp_statistic(x)
#' get_pvalue(bp$Test_statistic_U, 100)
#'
get_pvalue <- function(statistic_val, n, distribution = "norm", alternative = "two.sided", gen_num = 1e4) {
  r_samples <- switch(distribution,
    "norm" = lapply(rep(n, gen_num), rnorm),
    "cauchy" = lapply(rep(n, gen_num), rcauchy),
    "logis" = lapply(rep(n, gen_num), rlogis),
    "laplace" = lapply(rep(n, gen_num), rlaplace),
    "lnorm" = lapply(rep(n, gen_num), rlnorm),
    "gumbel" = lapply(rep(n, gen_num), rgumbel),
    "extII" = lapply(rep(n, gen_num), rextII)
  )
  statistics <- lapply(r_samples, get_main_bp_statistic, distribution = distribution, alternative=alternative)
  p.value <- mean(unlist(statistics) > statistic_val)
  return(p.value)
}

#' data investigation for outliers
#'
#' The procedure to find outliers and then check the goodness-of-fit with
#' given distribution.
#'
#' @param data A given sample
#' @export
#' @examples
#' investigate_sample(example1)
#'
investigate_sample <- function(data, alpha = 0.05, verbose = FALSE) {
  #require(evd)

  dist_list <- c("norm", "gumbel", "logis", "laplace",  "cauchy")#

  fit_list <- rep(list(1), length(dist_list))
  found_list <- c()
  number_list <- c()
  valid_dist <- ""

  for(i in 1:length(dist_list)) {
    bp <- bp_test(data, distribution = dist_list[i])
    found_list <- bp$found_outliers
    number_list <-  bp$number_of_outliers
    x <- data[!bp$outlier]
    #ks <- ks.test(x, paste("p", dist_list[i], sep=""))
    ks <- ks_check(x, distribution = dist_list[i], verbose = verbose)
    ad <- ad_check(x, distribution = dist_list[i], verbose = verbose)

    if(!ad$rejected) {
      valid_dist <- dist_list[i];

      dist_n <- switch(valid_dist,
        norm = "normal",
        logis = "logistic",
        cauchy = "cauchy",
        laplace = "laplace",
        gumbel = "gumbel")
      cat(paste("\n After checking the hypothesis about absence of outliers in ", dist_n, " distribution,\n",
        "the alternative "))
      if(found_list) {
        cat(" were accepted and ", number_list, " outliers was identified.\n")
        cat("\n After outliers removal in data, the goodness-of-fit hypothesis was checked:\n
          the null hypothesis that data is from ", dist_n, " distribution was accepted.\n Cleaned sample could be used for futher investigation. \n")

      } else {
        cat(" were rejected so no outliers was found.\n")
        cat("\n The goodness-of-fit hypothesis was checked:\n
          the null hypothesis that data is from ", dist_n, " distribution was accepted.\n Cleaned sample could be used for futher investigation. \n")
      }

      print(paste("KS test statistics U:   ", round(ks$U, 2), " with critical value: ", round(ks$critical, 2)))
      print(paste("AD test statistics A^2: ", round(ad$A2, 2), " with critical value: ", round(ad$critical, 2)))

      break
    }
  }

  if (valid_dist == "") {
    cat("no distributions out of normal, cauchy, logistic, laplace does not fit the goodness-of-fit for given distributions after outliers removal.")
  }

}

ks_test <- function(x, distribution = "norm") {

  n <- length(x);
  distr <- switch(distribution,
    norm = pnorm,
    logis = plogis,
    cauchy = pcauchy,
    gumbel = pgumbel,
    extII = pextII,
    laplace = plaplace
  )
  x <- sort(x)

  va <- var(x)
  be <- sqrt(6 * va / pi^2);
  mu <- switch (distribution,
    norm = mean(x),
    gumbel = mean(x) - be * 0.5772,
    extII = mean(x) + be * 0.5772,
    logis = mean(x),
    cauchy = mean(x),
    laplace = mean(x)
  )

  sds <- switch (distribution,
    norm = sd(x),
    gumbel = be,
    extII = be,
    logis = sqrt(va * 3 / (pi^2)),
    cauchy = get_robust_estimates(x, distribution = distribution)$scale,
    laplace = sqrt(va/2)
  )

  U <- distr(x, mu,  sds);
  Dp <- max((1:n) / n - U);
  Dm <- max(U - (1:n - 1) / n);
  D <- max(Dm, Dp);

  return(D);
}

ks_check <- function(x, distribution = "norm", alpha = 0.05, verbose = FALSE, gen_num = 10000) {
  n <- length(x);
  ks <- ks_test(x, distribution = distribution);
  critical <- NA;

  if (alpha == 0.05) {
    critical <- switch(distribution,
      norm = exp(-0.195445 - 0.485438 * log(n)),
      logis = exp(-0.107282 - 0.486688 * log(n)),
      cauchy = 0.8966121,
      gumbel = 1.0834,
      laplace = exp(-0.024938 - 0.476576 * log(n))
    )

  } else {
    distr <- switch(distribution,
      norm = rnorm,
      logis = rlogis,
      cauchy = rcauchy,
      gumbel = rgumbel,
      laplace = rlaplace
    )

    sam <- lapply(rep(n, gen_num), distr);
    ks <- lapply(sam, ks_test, distribution);
    critical <- quantile(unlist(ks), 1 - alpha);
  }

  rejected <- FALSE;
  if (ks > critical) {
    if(verbose) {
      print(paste("KS: The null hypothesis that data fit ", distribution, " is rejected. Distribution is not ", distribution))
    }
    rejected <- TRUE;
  } else {
    if(verbose) {
      print(paste("KS: The null hypothesis that data fit ", distribution ," was accepted."))
    }
    rejected <- FALSE;
  }

  return(list(rejected = rejected, U = ks, critical = critical))

}

ad_test <- function(x, distribution = 'norm') {
  n <- length(x);
  x <- sort(x);
  f <- switch (distribution,
    norm = pnorm,
    gumbel = pgumbel,
    logis = plogis,
    cauchy = pcauchy,
    laplace = plaplace
  )
  #mu <- mean(x)
  va <- var(x)
  be <- sqrt(6 * va / pi^2);
  mu <- switch (distribution,
    norm = mean(x),
    gumbel = mean(x) - be * 0.5772,
    logis = mean(x),
    cauchy = mean(x),
    laplace = mean(x)
  )

  sds <- switch (distribution,
    norm = sd(x),
    gumbel = be,
    logis = sqrt(va * 3 / (pi^2)),
    cauchy = get_robust_estimates(x, distribution = distribution)$scale,
    laplace = sqrt(va/2)
  )
  log1 <- f(x, mu, sds);
  log2 <- f(rev(x), mu, sds);
  id <- 1:n;
  h <- (2*id - 1)*(log(log1) + log(1-log2))
  A <- -n - mean(h)

  return(A);
}

ad_check <- function(x, distribution = "norm", alpha = 0.05, verbose = FALSE, gen_num = 10000) {
  n <- length(x);
  ks <- ad_test(x, distribution = distribution);
  critical <- NA;

  if (alpha == 0.05) {
    critical <- switch(distribution,
      norm = 0.7388575,
      logis = 0.8962129,
      cauchy = exp(-1.351995 + 1.056177 * log(n)),
      gumbel = 1.071733,
      laplace = 1.323736
    )

  } else {
    distr <- switch(distribution,
      norm = rnorm,
      logis = rlogis,
      cauchy = rcauchy,
      gumbel = rgumbel,
      laplace = rlaplace
    )

    sam <- lapply(rep(n, gen_num), distr);
    ks <- lapply(sam, ad_test, distribution);
    critical <- quantile(unlist(ks), 1 - alpha);
  }

  rejected <- FALSE;
  if (ks > critical) {
    if(verbose) {
      print(paste("AD: The null hypothesis that data fit ", distribution, " is rejected. Distribution is not ", distribution))
    }
    rejected <- TRUE;
  } else {
    if(verbose) {
      print(paste("AD: The null hypothesis that data fit ", distribution ," was accepted."))
    }
    rejected <- FALSE;
  }

  return(list(rejected = rejected, A2 = ks, critical = critical))

}

dextII <- function(q, mu = 0, sigma = 1) {
  p <- -exp((q - mu)/sigma - exp((q - mu)/sigma))/sigma
  return(p)
}

pextII <- function(q, mu = 0, sigma = 1) {
  p <- 1-exp(-exp((q-mu)/sigma))
  return(p)
}

qextII <- function(p, mu = 0, sigma = 1) {
  q<- mu + sigma * log(-log(1-p))
  return(q)
}

rextII <- function(n, mu = 0, sigma = 1) {
  r <- runif(n)
  q <- mu + sigma * log(-log(1-r))
  return(q)
}

#' outliersTests: A package containing statistical tests of identification
#' unknown number of outliers
#'
#' Statistical test for various location-scale family distributions
#' normal, logistic, cauchy, laplace to test does sample contain outliers and
#' identifying those outliers in sample.
#'
#' @section outliersTests functions:
#'
#'
#' \code{\link{bp_test}}: The calculation of the test statistic U and the p-value of the BP test for
#' outliers and finding of observations declared by the test as outliers.
#'
#' \code{\link{investigate_sample}}: The procedure to find outliers and then visualize sample after outliers removal
#' and calculating goodness-of-fit with packages fitdistrplus and flexsurv
#'
#' \code{\link{get_robust_estimates}}:  The robust estimates of the scale (Q_n) and location parameters for
#' location-scale families of distributions.
#' Implemented distributions: normal, gumbel, cauchy, laplace, logistic
#'
#' @section outliersTests package data:
#'
#' \code{\link{example1}}: - example data
#'
#' \code{\link{example2}}: - example data
#'
#' @docType package
#' @name outliersTests
NULL


## 2. Brief Recap ##

p_2 <- 1/6
p_odd <- 3/6
p_2_or_4 <- 2/6

## 3. Updating Probabilities With New Information ##

p_3 <- 1/4
p_6 <- 0/4
p_odd <- 2/4
p_even <- 2/4

## 4. Conditional Probability ##

p_december <- 1/3
p_31 <- 2/3
p_summer <- 0/3
p_ends_r <- 1/3

## 5. Conditional Probability Formula ##

card_b <- 21
card_a_and_b <- 9
p_a_given_b <- card_a_and_b / card_b

## 6. Example Walkthough ##

p_negative_given_non_hiv <- 6/30
print(p_negative_given_non_hiv)

## 7. Conditional Probability Formula Revisited ##

p_premium_given_chrome <- 158/2762
p_basic_given_safari <- 274/1288
p_free_given_firefox <- 2103/2285
more_likely_premium <- 'Safari'

Data Analyst in R/Step 5 - Probability and Statistics/4. Conditional Probability in R/1. Conditional Probability.r


library(nimble)
library(igraph)

# note: ~ and <- have meanings same as JAGS/BUGS
pumpCode <- nimbleCode({

  for (i in 1:N) {
    theta[i] ~ dgamma(alpha,beta)
    lambda[i] <- theta[i]*t[i]
    x[i] ~ dpois(lambda[i])
  }

  alpha ~ dexp(1.0)
  beta ~ dgamma(0.1,1.0)
})

# we need to divide the data (something that appears in the likelihood function) and
# constants - two separate lists (warnings are issued if constants are included in data)
pumpConsts <- list(N = 10, t = c(94.3, 15.7, 62.9, 126, 5.24, 31.4, 1.05, 1.05, 2.1, 10.5))

pumpData <- list(x = c(5, 1, 5, 14, 3, 19, 1, 1, 4,  22))

pumpInits <- list(alpha = 1, beta = 1, theta = rep(0.1, pumpConsts$N))

# call to set up model - compiles and checks for correct syntax
pump <- nimbleModel(code = pumpCode, name = "pump", constants = pumpConsts, data = pumpData, inits = pumpInits)

pump$getNodeNames()

pump$logProb_x
pump$lifted_d1_over_beta

pump$modelDef

pump$modelDef$BUGScode

# Plot the graphs
pump$plotGraph()

pump$getDependencies(c("alpha"))
pump$getDependencies(c("beta"))

# Check the way the samplers are applied.
pump$checkConjugacy()

# generate from the distribution for theta (can use nimble to simulate data)
set.seed(0)
simulate(pump,"theta") # takes current alpha and betas to create new thetas
print(pump$theta)

# calculate the log probabilities (log posterior distribution)
pump$calculate(pump$getDependencies(c("theta")))
# can use function like you would use a function in R

mcmc.out <- nimbleMCMC(code = pumpCode, constants = pumpConsts,
                       data = pumpData, inits = pumpInits,
                       monitors = c("alpha","beta","theta"),
                       nchains = 2, niter = 10000,thin=1,nburnin=2000,
                       samplesAsCodaMCMC = TRUE,
                       summary = TRUE, WAIC = TRUE)

# Compile the model
Cpump <- compileNimble(pump,showCompilerOutput = TRUE)

# smart to compile model first if you plan to run the model multiple times
# as opposed to the code above, where it is compiled & run in the same function call
mcmc.out <- nimbleMCMC(model=Cpump,
                       monitors = c("alpha","beta","theta"),
                       nchains = 2, niter = 10000, thin=1,nburnin=2000,
                       samplesAsCodaMCMC = TRUE,
                       summary = TRUE, WAIC = TRUE)

print(str(mcmc.out))
mcmc.out$summary

pumpConf <- configureMCMC(pump, print = TRUE)


#!/usr/bin/env Rscript

# Author  : Bhishan Poudel
# Date    : Feb 9, 2016
# Program :

# setting working directory
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

# Start device driver to save output
#postscript(file="Pareto_distribution.eps", height=14, width=8)

# Define Pareto distributions for Salpeter IMF
dpareto <- function(x, alpha=1.35, b=1) (alpha>0)*(b>0)^alpha / x^(alpha+1)
ppareto <- function(x, alpha=1.35, b=1) (x>b)*(1-((b>0)/x)^(alpha>0))
qpareto <- function(u, alpha=1.35, b=1) (b>0)/(1-u)^(1/(alpha>0)) # 0<u<1
rpareto <- function(n, alpha=1.35, b=1) qpareto(runif(n),alpha,b)

# Produce Pareto-distributed simulated dataset with n=500; plot
par(mfrow=c(1,3))
z <- rpareto(500)

dotchart ( log10(z), main='', xlab='log stellar mass', pch=20, cex.lab=1.5 )

x <- seq(1, 50, len=1000)
plot (log10(x), log10(dpareto(x)), type="l", ylab='', xlab='log stellar mass',
     cex.lab=1.5, cex.axis=1.5)
lines(log10(x), log10(ppareto(x)), type="l", lty=2)
legend (0.4, -0.3, legend=c('log(p.d.f)', 'log(c.d.f)'), lty=c(1,2), cex=1.5)

u=seq(.0005, .9095, len=1000)
plot (log10(qpareto(u)), u, type="l", xlab='log stellar mass', ylab='Quantile',
     cex.lab=1.5, cex.axis=1.5)
par(mfrow=c(1,1))

# Turn off device driver
#dev.off()


library(deSolve)
library(simecol)
library(reshape2)
library(ggplot2)

hivmodel.dr <- new("odeModel",
  main = function(time, init, parms, ...){
    with(as.list(c(init,parms)),{
      # ODEs
      N1 <- S1+I1
      N2 <- S2+I2
      dS1 <- lambd1-beta*c1*p11*(I1/N1)*S1-beta*c1*p12*(I2/N2)*S1-mu*S1
      dI1 <- beta*c1*p11*(I1/N1)*S1+beta*c1*p12*(I2/N2)*S1-gamma*I1-mu*I1
      dS2 <- lambd2-beta*c2*p21*(I1/N1)*S2-beta*c2*p22*(I2/N2)*S2-mu*S2
      dI2 <- beta*c2*p21*(I1/N1)*S2+beta*c2*p22*(I2/N2)*S2-gamma*I2-mu*I2
      list(c(dS1,dI1,dS2,dI2))
    })},
    parms = list(p11=0.1,p12=0.9,p21=0.1,p22=0.9,beta=0.01,c1=1,c2=1,gamma=1./520,mu=1./(70*52),lambd1=1000./(70*52),lambd2=9000./(70*52)),
    times = c(from=0,to=40*52,by=1),
    init = c(S1=999,I1=1,S2=9000,I2=0),
    solver = "lsoda"
)

calcprop <- function(c1,c2,N1,N2){
  bigc <- c1*N1+c2*N2
  c(p11=c1*N1/bigc,p12=c2*N2/bigc,p21=c1*N1/bigc,p22=c2*N2/bigc)
}

calcpref <- function(c1,c2,N1,N2,rho1,rho2){
  p11 <- rho1+(1-rho1)*(c1*(1-rho1)*N1)/(c1*(1-rho1)*N1+c2*(1-rho2)*N2)
  p22 <- rho2+(1-rho2)*(c2*(1-rho2)*N2)/(c1*(1-rho1)*N1+c2*(1-rho2)*N2)
  p12 <- (1-rho1)*(c2*(1-rho2)*N2)/(c1*(1-rho1)*N1+c2*(1-rho2)*N2)
  p21 <- (1-rho2)*(c1*(1-rho1)*N1)/(c1*(1-rho1)*N1+c2*(1-rho2)*N2)
  c(p11=p11,p12=p12,p21=p21,p22=p22)
}

# Preferential mixing
dr.pref.p <- calcpref(2,1,10000,90000,0.9,0.9)
dr.pref.co.par <- as.list(c(dr.pref.p,c(beta=0.01,c1=2,c2=1,gamma=1./520,mu=1./(70*52),lambd1=10000./(70*52),lambd2=90000./(70*52))))
dr.pref.sim <- hivmodel.dr
parms(dr.pref.sim) <- dr.pref.co.par

dr.pref.sim <- sim(dr.pref.sim)
dr.pref.out <- out(dr.pref.sim)

# Turn output into 'long' format
dr.pref.out.long <- melt(as.data.frame(dr.pref.out),"time")

# Plot
ggplot(dr.pref.out.long,aes(x=time,y=value,colour=variable,group=variable)) +
  geom_line(lwd=2) + xlab("Time")+ylab("Number")


=begin
  # sample-factorize05.rb

  require "algebra"

  def show(f, mod = 0)
    if mod > 0
      zp = ResidueClassRing(Integer, mod)
      pzp = Polynomial(zp, f.variable)
      f = f.convert_to(pzp)
    end
    fact = f.factorize
    printf "mod %2d: %-15s  =>  %s\n", mod, f, fact
  end

  Px = Polynomial(Integer, "x")
  x = Px.var
  f = x**4 + 10*x**2 + 1
  #f = x**4 - 10*x**2 + 1
  show(f)
  Primes.new.each do |mod|
    break if mod > 100
    show(f, mod)
  end

  #mod  0: x^4 + 10x^2 + 1  =>  x^4 + 10x^2 + 1
  #mod  2: x^4 + 1          =>  (x + 1)^4
  #mod  3: x^4 + x^2 + 1    =>  (x + 2)^2(x + 1)^2
  #mod  5: x^4 + 1          =>  (x^2 + 3)(x^2 + 2)
  #mod  7: x^4 + 3x^2 + 1   =>  (x^2 + 4x + 6)(x^2 + 3x + 6)
  #mod 11: x^4 - x^2 + 1    =>  (x^2 + 5x + 1)(x^2 + 6x + 1)
  #mod 13: x^4 + 10x^2 + 1  =>  (x^2 - x + 12)(x^2 + x + 12)
  #mod 17: x^4 + 10x^2 + 1  =>  (x^2 + 3x + 1)(x^2 + 14x + 1)
  #mod 19: x^4 + 10x^2 + 1  =>  (x + 17)(x + 10)(x + 9)(x + 2)
  #mod 23: x^4 + 10x^2 + 1  =>  (x^2 + 6)(x^2 + 4)
  #mod 29: x^4 + 10x^2 + 1  =>  (x^2 + 21)(x^2 + 18)
  #mod 31: x^4 + 10x^2 + 1  =>  (x^2 + 22x + 30)(x^2 + 9x + 30)
  #mod 37: x^4 + 10x^2 + 1  =>  (x^2 + 32x + 36)(x^2 + 5x + 36)
  #mod 41: x^4 + 10x^2 + 1  =>  (x^2 + 19x + 1)(x^2 + 22x + 1)
  #mod 43: x^4 + 10x^2 + 1  =>  (x + 40)(x + 29)(x + 14)(x + 3)
  #mod 47: x^4 + 10x^2 + 1  =>  (x^2 + 32)(x^2 + 25)
  #mod 53: x^4 + 10x^2 + 1  =>  (x^2 + 41)(x^2 + 22)
  #mod 59: x^4 + 10x^2 + 1  =>  (x^2 + 13x + 1)(x^2 + 46x + 1)
  #mod 61: x^4 + 10x^2 + 1  =>  (x^2 + 54x + 60)(x^2 + 7x + 60)
  #mod 67: x^4 + 10x^2 + 1  =>  (x + 55)(x + 39)(x + 28)(x + 12)
  #mod 71: x^4 + 10x^2 + 1  =>  (x^2 + 43)(x^2 + 38)
  #mod 73: x^4 + 10x^2 + 1  =>  (x + 68)(x + 44)(x + 29)(x + 5)
  #mod 79: x^4 + 10x^2 + 1  =>  (x^2 + 64x + 78)(x^2 + 15x + 78)
  #mod 83: x^4 + 10x^2 + 1  =>  (x^2 + 18x + 1)(x^2 + 65x + 1)
  #mod 89: x^4 + 10x^2 + 1  =>  (x^2 + 9x + 1)(x^2 + 80x + 1)
  #mod 97: x^4 + 10x^2 + 1  =>  (x + 88)(x + 54)(x + 43)(x + 9)
((<_|CONTENTS>))
=end


ybar = 390          # sample mean
mu0 = 380              # hypothesized value
sigma = 35.2           # population standard deviation
n = 50                 # sample size
z = (ybar- mu0)/(sigma/sqrt(n))
print(z) # test statistic

# We then compute the critical value at .01 significance level.
#  For alpha= .01, reject the null hypothesis if lies more than 2.33
alpha = .01
# critical value
z.alpha = qnorm(1-alpha)
print(z.alpha)
print("the observed value of z < critical value,  so we might be tempted to accept the null hypothesis")
#  but Beta is not computed so  there is insufficient evidence to reject the null hypothesis.
# To reach a conclusion about whether to accept or reject  H0, beta should be calculated.


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

# Grab constant-maturity US Treasuries
ust.tickers <- c("FRED/DGS3MO", "FRED/DGS2", "FRED/DGS5", "FRED/DGS10", "FRED/DGS30")
ust <- Quandl(ust.tickers, type="xts")/100
ust.colnames <- c("T3M", "T2Y", "T5Y", "T10Y", "T30Y")
colnames(ust) <- ust.colnames

# Grab inflation-indexed US Treasuries
tips.yields <- c("TIPSY02", "TIPSY05", "TIPSY10")
tips <- Quandl("FED/TIPSY", type="xts")[,tips.yields]/100

# expected inflation and CPI are only available monthly...
# For expected inflation and CPI, only get the first column of data... like so:
exinfl <- Quandl("FRBC/EXIN", type="xts")[,1]
colnames(exinfl) <- c("EXINFL")
cpi <- Quandl("FRBC/USINFL", type="xts")[,1]
colnames(cpi) <- c("CPI")

# Calculate inflation and surprise by projecting CPI for one year ahead
# The surprise is how much the CPI differed from what was
# projected a year earlier
infl.yoy <- log(cpi) - log(lag(cpi, 12))
colnames(infl.yoy) <- c("INFL.YOY")
infl.mom <- (log(cpi) - log(lag(cpi)))*12
colnames(infl.mom) <- c("INFL.MOM")
excpi <- cpi*(1+exinfl)  # expected CPI in twelve months
cpi.surprise <- log(cpi) - log(lag(excpi, 12))  # % CPI surprise
colnames(cpi.surprise) <- c("INFLSURP")

# combine the data and carry monthly observations forward
inflation.tmp <- cbind(ust, tips, infl.yoy, infl.mom, exinfl, cpi, excpi, cpi.surprise)["1999/"]
inflation.data <- na.locf(inflation.tmp)

# backward Hodrick-Prescott filter function
hpbackfilter <- function(y, lambda) {
    n <- length(y)
    I <- diag(1, nrow = n)
    # build the curvature matrix
    K <- matrix(0, nrow=n-2, ncol=n)
    for (i in 1:(n-2)) {
        K[i,i:(i+2)] = c(1,-2,1)
    }
    # now invert and multiply by the data
    hat.matrix <- solve(I+2*lambda*t(K)%*%K)
    hat.matrix %*% y
}
lambda.monthly <- 129600 # for monthly data
tau <- hpbackfilter(cpi, lambda.monthly)


# likelihood ratio statistics for testing the significanse of added model parameters
# and  Akaike's An Information Criterion

#  input

n.par.1<-91               # number of parameter in model 1
n.par.2<-87                # number of parameter in model 2
neg.like.1<- -175.477     # negative log likelihood, model 1 (taken from file sms.rep "objective function (negative log likelihood):"  or from sms.par file
neg.like.2<- -167.324     # negative log likelihood, model 2

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

# likelihood ratio statistics for testing the significanse of a change in  model parameters

n.free<-abs(n.par.1-n.par.2)

P.value<-1-pchisq(2*abs(neg.like.1-neg.like.2),n.free)
P.value
# a P.value <0.05 shows significant effect of changing the number of parameters

##############################################
#Akaike's An Information Criterion
#     Generic function calculating the Akaike information criterion for
#     one or several fitted model objects for which a log-likelihood
#     value can be obtained, according to the formula -2*log-likelihood
#     + k*npar, where npar represents the number of parameters in the
#     fitted model, and k = 2 for the usual AIC, or k = log(n) (n the
#     number of observations) for the so-called BIC or SBC (Schwarz's
#     Bayesian criterion).

k<-2
AIC1<-2*neg.like.1+k*n.par.1
AIC1

AIC2<-2*neg.like.2+k*n.par.2
AIC2
AIC1


######################################################################
###
### Hierarchilca clustering
### https://www.datacamp.com/community/tutorials/hierarchical-clustering-R
#######################################################################
# Data Set Information:
# The examined group comprised kernels belonging to three different varieties of wheat: Kama, Rosa and Canadian, 70 elements each, randomly selected for
the experiment. High quality visualization of the internal kernel structure was detected using a soft X-ray technique. It is non-destructive and considerably cheaper than other more sophisticated imaging techniques like scanning microscopy or laser technology. The images were recorded on 13x18 cm X-ray KODAK plates. Studies were conducted using combine harvested wheat grain originating from experimental fields, explored at the Institute of Agrophysics of the Polish Academy of Sciences in Lublin.

# Attribute Information:
# To construct the data, seven geometric parameters of wheat kernels were measured:
# 1. area A,
# 2. perimeter P,
# 3. compactness C = 4*pi*A/P^2,
# 4. length of kernel,
# 5. width of kernel,
# 6. asymmetry coefficient
# 7. length of kernel groove.

rm(list=ls())
## Libraries
library(cluster)
library(dendextend)
library(dplyr)
library(ggplot2)

##
WD = "/Users/gianlucamastrantonio/Desktop/statistico/lavori/lezioni/DataSpace/2018/Lez9/"
setwd(WD)

# carichiamo i dati
seeds_df <- read.csv(paste(WD,"seeds_dataset.txt",sep=""),sep = '\t',header = FALSE)
# cambiamo i nomi
feature_name <- c('area','perimeter','compactness','length.of.kernel','width.of.kernal','asymmetry.coefficient','length.of.kernel.groove','type.of.seed')
colnames(seeds_df) <- feature_name
str(seeds_df)
summary(seeds_df)

# eliminiamo gli NA
for(i in 1:ncol(seeds_df))
{
	W = which(!is.na(seeds_df[,i]))
	seeds_df = seeds_df[W,]
}

# "standardizziamo" le variabili e salviamo la clusterizzazione
seeds_label <- seeds_df$type.of.seed
seeds_df$type.of.seed <- NULL
str(seeds_df)
seeds_df_sc <- as.data.frame(scale(seeds_df))
summary(seeds_df_sc)

# plots
ggplot(seeds_df_sc, aes(x=area, y = perimeter, color = factor(seeds_label))) + geom_point()
ggplot(seeds_df_sc, aes(x=area, y = compactness, color = factor(seeds_label))) + geom_point()
ggplot(seeds_df_sc, aes(x=area, y = length.of.kernel, color = factor(seeds_label))) + geom_point()

plot(density(seeds_df_sc$area))
plot(density(seeds_df_sc$perimeter))
plot(density(seeds_df_sc$compactness))
#...

# calcoliamo la matrice distanza
dist_mat <- dist(seeds_df_sc, method = 'euclidean')
# stimiamo il modello
hclust_avg <- hclust(dist_mat, method = 'average')
plot(hclust_avg)
# tagliamo il dendogramma con 3 clusters
cut_avg <- cutree(hclust_avg, k = 3)
table(cut_avg,seeds_label)

# qualche plot
ggplot(seeds_df_sc, aes(x=area, y = perimeter, color = factor(cut_avg))) + geom_point()
ggplot(seeds_df_sc, aes(x=area, y = compactness, color = factor(cut_avg))) + geom_point()
ggplot(seeds_df_sc, aes(x=area, y = length.of.kernel, color = factor(cut_avg))) + geom_point()

# calcoliamo le varianze dentro i gruppi con un funzione
wss <- function(d) {
  sum(scale(d, scale = FALSE)^2)
}
wrap <- function(i, hc, x) {
  cl <- cutree(hc, i)
  spl <- split(x, cl)
  wss <- sum(sapply(spl, wss))
  wss
}
res <- sapply(seq.int(1, 10), wrap, h = hclust_avg, x = seeds_df_sc)

plot(1:10,res,type="b", main="Total Within SS by Various K",
 ylab="Average Total Within Sum of Squares",
 xlab="Value of K")

# possiamo vedere i cluster che stiamo creando
plot(hclust_avg)
rect.hclust(hclust_avg , k = 3, border = 2:6)
abline(h = 3, col = 'red')

# un'latro modo di rappresentare i clusters
avg_dend_obj <- as.dendrogram(hclust_avg)
avg_col_dend <- color_branches(avg_dend_obj, h = 3)
plot(avg_col_dend)

# vediamo il numero di osservazione nei cluster
cut_avg <- cutree(hclust_avg, k = 3)
seeds_df_cl <- mutate(seeds_df, cluster = cut_avg)
count(seeds_df_cl,cluster)

ggplot(seeds_df_cl, aes(x=area, y = perimeter, color = factor(cluster))) + geom_point()

# vediamo la silhouette
D <- daisy(seeds_df_sc)
k =3
plot(silhouette(cutree(hclust_avg, k = k), D), col=1:8, border=NA)

## potremmo vedere i risultati che si
# ottengono con il k-means


#'@title calcHMFormFactor
#'
#'@description Calculate form factor (1+k_1) from the Holtrop & Mennen method.
#'
#'@param maxDraft Maximum summer load line draft (vector of numericals, m)
#'@param lwl Waterline length (vector of numericals, m) (see \code{\link{calclwl}})
#'@param breadth Moulded breadth (vector of numericals, m)
#'@param maxDisplacement Maximum ship displacement (vector of numericals, m^3)
#'@param Cp Prismatic coefficient (vector of numericals, dimensionless) (see
#' \code{\link{calcCp}})
#'@param Cstern Afterbody form coefficient:
#'\itemize{\item V-shaped Hull = -10
#'         \item U-Shaped Hull =  10
#'         \item Normal Hull = 0 (default) }
#' Can supply either a vector of numericals, a single number, or rely on the default
#'@param lcb Longitudinal position of center of buoyancy (vector of numericals,
#' see \code{\link{calclcb}})
#'
#'@return \code{formFactor} (vector of numericals)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#'Holtrop, J. and Mennen, G. G. J. 1984. "A Statistical Re-Analysis of Resistance
#'and Propulsion Data'.
#'
#'@seealso \itemize{
#'\item \code{\link{calclwl}}
#'\item \code{\link{calcCp}}
#'\item \code{\link{calclcb}} }
#'
#'@family Holtrop-Mennen Calculations
#'
#'@examples
#' calcHMFormFactor(c(13.57,11.49),c(218.75, 209.25),c(32.25,32.20),c(80097,52382.04),c(0.81,0.67))
#' calcHMFormFactor(13.57,218.75,32.25,80097,0.81)
#'
#'@export

calcHMFormFactor<-function(maxDraft,lwl,breadth,maxDisplacement,Cp,Cstern=0,lcb=0){

  formFactor<-
    0.93+0.487118*
    #c14
    (1+0.011*Cstern)*
    ((breadth/lwl)^1.06806)*
    ((maxDraft/lwl)^0.46106)*
     (  #L/Lr
       (1/(1-Cp+(0.06*Cp*-lcb)/(4*Cp-1))
        )^0.121563)*
    ((lwl^3/maxDisplacement)^0.36486)*((1-Cp)^-0.604247)

return(formFactor)

}


#' Harmonic mean
#'
#' @description Calculates harmonic mean
#'
#' @param x numeric vector
#'
#' @return Harmonic mean
#' @export
#'
#' @examples
#'
#' x <- rexp(100,.5)
#'
#' harmonic_mean(x)
#'

harmonic_mean <- function(x){

  if(sum(x == 0, na.rm = TRUE) > 0 ){
    warning("There is at least one value = 0 and that cause the harmonic mean to be 0.")
  }

  1/mean(1/x, na.rm = TRUE)

}


findLargestprime <- function(x) {
    n <- 2
    while (x %% n != 0) {
        n <- n+1
    }

    if (n == x) {
       return (x)
    }
    return (findLargestprime(x/n))
}

l <- findLargestprime(600851475143)
print(l)


#Sign test se usa para decidir si una
#distribucion binomial tiene la misma posibilidad
#de exito de gallo

'''
A soft drink company has invented a new drink,
and would like to find out if it will be as
popular as the existing favorite drink.
For this purpose, its research department
arranges 18 participants for taste testing.
Each participant tries both drinks in random
order before giving his or her opinion.

It turns out that 5 of the participants like the
new drink better, and the rest prefer
the old one. At .05 significance level,
can we reject the notion that the two drinks are equally popular?
'''

binom.test(5,18)

'''
	Exact binomial test

data:  5 and 18
number of successes = 5, number of trials =
18, p-value = 0.09625
alternative hypothesis: true probability of success is not equal to 0.5
95 percent confidence interval:
 0.09694921 0.53480197
sample estimates:
probability of success
             0.2777778

Debido a que p-value es mayor a la significancia
aceptamos la hipotesis nula
'''

Parcial/5. Metodos no parametricos/SignTest.r


install.packages("plotly")
library(plotly)

# experimento completamente al azar

x <- seq(0, 1, length=100)
fd <- dunif(x)

plot_ly(x = x , y = fd, type = 'scatter', mode='lines', fill = 'tozeroy')

fp <- punif(x)
plot_ly(x = x , y = fp, type = 'scatter', mode='lines', fill = 'tozeroy')

#-------------------------------------------------
# uniform
# params specific minimum and maximum

# dunif for density plot
limits <- seq(0,10,by=0.01)
z <-dunif(x=limits,min=0,max=5)
names(z) <- limits
plot(x=limits, y=z,type="l",xlim=c(0,10))

#punif for cumulative density (= tail probabilities)
limits <- seq(0,10,by=0.01)
z <-punif(q=limits,min=0,max=5)
names(z) <- limits
plot(x=limits, y=z,type="l",xlim=c(0,10))

#qunif for quantiles
qunif(p=c(0.025,0.975),min=0,max=5)

#runif for random data
hist(runif(n=100,min=0,max=5))
hist(runif(n=1000,min=0,max=5))
#------------------------------------


# https://baseballwithr.wordpress.com/2017/02/20/bayesian-learning-about-a-hitting-probability/

library('TeachBayes')

# Construct df of plausible hitting probabilities

bayes_df <- data.frame(P = seq(0.2, 0.34, by=0.01),
                       Prior=rep(1/15, 15))

# Player hits 100 times, getting 30 hits
# Add column with likelihood of this outcome,
# as a function of the hitting P

bayes_df$Likelihood <- dbinom(30, size=100, prob=bayes_df$P)

# Use bayesian_crank() function to compute posteriors
bayes_df <- bayesian_crank(bayes_df)

# Plot priors and posteriors
prior_post_plot(bayes_df)

# Use discint to find prob interval for P

discint(select(bayes_df, P, Posterior), 0.6)

# Investigate Joey Votto's 2016 batting probability

normal_prior <- normal.select(list(p=.5, x=.320), list(p=.1, x=.280))

normal_prior

normal_draw(c(0.320, 0.031))

# Votto hit .326 in 556 AB's
# SE = sqrt(.326 * (1 - .326) / 556) = 0.0199

normal_update(normal_prior, c(0.326, 0.0199))

many_normal_plots(list(c(0.32, 0.0312), c(0.324, 0.0168)))

qnorm(c(0.05, 0.95), mean=.324, sd=0.0168)


library(dslabs)
library(tidyverse)
library(haven)

galton_heights <- read_dta('galton-stata11.dta')
str(galton_heights)

#Getting the average of sons with whose fathers' height is around 72 inches
conditional_avg <- galton_heights %>% filter(gender == "M", round(father) == 72) %>% summarize(avg = mean(height)) %>% .$avg
conditional_avg

#plot(father, son)
galton_heights %>% mutate(father_strata = factor(round(father))) %>%  filter(gender == "M") %>% ggplot(aes(father_strata, height)) + geom_boxplot() + geom_point()

#plotting conditional sons' height due to fathers' height
galton_heights %>% mutate(father = round(father)) %>% group_by(father) %>% filter(gender == "M") %>% summarise(son_conditional_avg = mean(height)) %>% ggplot(aes(father, son_conditional_avg)) + geom_point()

#correlation
r <- galton_heights %>% filter(gender == "M") %>% summarise(r = cor(father, height)) %>% .$r

#plottoing the relation between heights and the correlation regression
galton_heights %>% mutate(father = round(father)) %>% group_by(father) %>% filter(gender == "M") %>% summarise(son = mean(height)) %>% mutate(z_father = scale(father), z_son = scale(son)) %>%
  ggplot(aes(z_father, z_son)) + geom_point() + geom_abline(intercept = 0, slope = r)

#parameters of linear regression y = b + m*x
male <- galton_heights %>% filter(gender == "M")
mu_x <- mean(galton_heights$father)
mu_y <- mean(male$height)
s_x <- sd(galton_heights$father)
s_y <- sd(male$height)
r <- cor(galton_heights$father, male$height)
m <- r*s_y / s_x
b <- mu_y - m*mu_x

#plot
galton_heights %>% filter(gender == "M") %>% ggplot(aes(father, height)) + geom_point(alpha = 0.5) + geom_abline(intercept = b, slope = m)

#Stratifying sons' height by the standardized fathers' height
galton_heights %>% filter(gender == "M") %>% mutate(z_father = round((father - mean(father))/sd(father))) %>% filter(z_father %in% -2:2) %>%
  ggplot() + stat_qq(aes(sample = height)) + facet_wrap(~z_father)

#Variance
#When two variables follow a bivariate normal distribution, the variation
#explained can be calculated as  𝜌2×100
vari <- r^2
vari

#linear regression
lm(height ~ father, data = male)

#least squares estimate
rss <- function(beta0, beta1, data) {
  resid <- male$height - (beta0 + beta1 * male$father)
  return(sum(resid^2))
}
beta1 = seq(0, 1, len=nrow(galton_heights))
results <- data.frame(beta1 = beta1, rss = sapply(beta1, rss, beta0 = 25))
results %>% ggplot(aes(beta1, rss)) + geom_line() + geom_line(aes(beta1, rss), col=2)

#Monte Carlo simulation
B <- 1000
N <- 100
lse <- replicate(B, {
  sample_n(male, N, replace = TRUE) %>%
    lm(height ~ father, data = .) %>% .$coef
})

sample_n(male, N, replace = TRUE) %>%
  lm(male ~ father, data = .) %>% summary

lse <- data.frame(beta_0 = lse[1,], beta_1 = lse[2,])
lse %>% summarize(cor(beta_0, beta_1))

library(gridExtra)
p1 <- lse %>% ggplot(aes(beta_0)) + geom_histogram(bins = 20, binwidth = 1, color = "black")
p2 <- lse %>% ggplot(aes(beta_1)) + geom_histogram(bins = 20, binwidth = 0.01, color = "black")
grid.arrange(p1, p2, ncol = 2)

#If we standardize the father heights
B <- 1000
N <- 50
lse <- replicate(B, {
  sample_n(male, N, replace = TRUE) %>%
    mutate(father = father - mean(father)) %>%
    lm(height ~ father, data = .) %>% .$coef
})

cor(lse[1,], lse[2,])

#Drawing graphs with confidence interval and different ways to get the predictions
male %>% ggplot(aes(father, height)) + geom_point() +
  geom_smooth(method = "lm")

male %>% mutate(Y_hat = predict(lm(height ~ father, data =  .))) %>%
  ggplot(aes(father, Y_hat)) + geom_line()

fit <- male %>% lm(height ~ father, data =  .)
Y_hat = predict(fit, se.fit = TRUE)
names(Y_hat)

model <- lm(height ~ father, data = male)
predictions <- predict(model, interval = c("confidence"), level = 0.95)
data <- as_tibble(predictions) %>% bind_cols(father = male$father)

ggplot(data, aes(x = father, y = fit)) +
  geom_line(color = "blue", size = 1) +
  geom_ribbon(aes(ymin=lwr, ymax=upr), alpha=0.2) +
  geom_point(data = male, aes(x = father, y = height))