# OLS conditions violations: Heterscedasticity
# Based on:
# https://stats.stackexchange.com/questions/33028/measures-of-residuals-heteroscedasticity
# See also:
# https://stats.stackexchange.com/questions/258485/simulate-linear-regression-with-heteroscedasticity

set.seed(17)
n <- 500

make_x = function(){return (rgamma(n, shape=6, scale=1/2))}
make_e = function(x){return (rnorm(length(x), sd=abs(sin(x))))}
b = 2
f = function(x){return (b*x)}
dgp = function(){
  x <- make_x()
  y = f(x)+make_e(x)
  return (data.frame(x=x,y=y))
}

# single run
x <- make_x()
e <- make_e(x)
y_true = f(x)
y <- y_true + e
fit <- lm(y ~ x + 0)

# regression
png("C:/Users/Евгений/Documents/GitHub/multiple-regression-revisited/hsc1.png")
plot(x,y, main="Observations with heteroscedаsticity")
abline(0, b, col="green")
abline(fit, col="red")
dev.off()

# repeat estimation
extract_b0  = function(lm_){return (coef(lm_)[1])}
get_b = function(){coef(lm(y~x+0, data = dgp()))}
n_experiments = 1000
bs = replicate(n_experiments, get_b())

# plot estimator desities

png("C:/Users/Евгений/Documents/GitHub/multiple-regression-revisited/hsc2.png")

b_avg = mean(bs)
b_sd = sd(bs)
h = hist(bs, breaks=40, freq=FALSE,
         main=paste("Distribution of b on", n_experiments,"experiments"),
         sub=paste("True value:", b, "    ",
                   "Mean: ", round(b_avg,4), "    ",
                   "SD: ", round(b_sd,4)),
         xlab="b",
         col="lightblue")
# curve(dnorm(x, mean=b_avg, sd=b_sd), add=TRUE, col="darkblue", lwd=2)
lines(density(bs), col="darkblue", lwd=2)
abline(v=b, col ="green")
abline(v=b_avg, col ="red")

# from https://stackoverflow.com/questions/6973579/plotting-probability-density-mass-function-of-dataset-in-r
# hist(energy,probability=TRUE)
# lines(density(bs), col="darkblue", lwd=2)

dev.off()


hist_nw <- function(x, alpha=0.01, pvalue=0.99, breaks=NULL, suppress='no') {
    ## plot histogram, normal distribution, and Weibull distribution
    ## add lines for upper tolerance limits for given alpha and pvalue
    ## alpha  = 1 - confidence
    ## pvalue = coverage (tolerance interval only)

    ## normal distribution calculations
    tol_out <- normtol.int(x, alpha = alpha, P=pvalue, side=1)
    upper_tolerance_limit_norm <- tol_out$'1-sided.upper'

    ## Weibull distribution calculations
    tol_out <-  exttol.int(x, alpha=alpha, P=pvalue, side=1, dist="Weibull")
    shape   <- tol_out$'shape.1'
    scale   <- tol_out$'shape.2'
    upper_tolerance_limit_weib <- tol_out$'1-sided.upper'

    ## create vectors with density distributions
    xmin    <- min(x)
    xmax    <- max(x,upper_tolerance_limit_norm,upper_tolerance_limit_weib)
    chuncks <- (xmax-xmin)/1000
    xrange  <- seq(xmin,xmax,by=chuncks)
    xmean   <- mean(x)
    xsd     <- sd(x)
    xdensity_norm <- dnorm(xrange,xmean,xsd)
    xdensity_weib <- dweibull(xrange,shape=shape,scale=scale)
    maxdensity <- max(xdensity_norm, xdensity_weib)

    ## make histogram
    ## warning: xlim range can mess up x-axis
    ## obtain histogram parameters but suppress plot
    out <- hist(x, plot=FALSE)
    if (is.null(breaks)) breaks <- length(out$breaks)
    ymax <- max(out$density, maxdensity)
    ## create plot
    hist(x, breaks=breaks,
         xlim=c(xmin,xmax+(xmax-xmin)/breaks),
         ylim=c(0,maxdensity),
         freq=FALSE)

    ## add distributions
    lines(x=xrange, y=xdensity_norm, col='red', lty=1)
    lines(x=xrange, y=xdensity_weib, col='blue', lty=1)

    ## add lines for mean and upper 1-sided 99/99 tolerance limits
    abline(v=xmean,col="red")
    abline(v=upper_tolerance_limit_norm,col="red",lty=2)
    abline(v=upper_tolerance_limit_weib,col="blue",lty=2)

    ## print to screen
    if (suppress == 'no') {
        cat("Tolerance limit input parameters:\n")
        cat("   upper, 1-sided,", pvalue*100,"/",(1-alpha)*100,"\n")
        cat("\n")
        cat("Normal distribution (red):\n")
        cat("   mean               =",xmean,"\n")
        cat("   standard deviation =",xsd,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_norm,"\n")
        cat("\n")
        cat("Weibull distribution (blue):\n")
        cat("   shape              =",shape,"\n")
        cat("   scale              =",scale,"\n")
        cat("   tolerance limit    =",upper_tolerance_limit_weib,"\n")
    }
}
## hist_nw(mtcars$mpg)


# Example : 2   Chapter : 2.5   Pageno : 82
# Inverse of an Elimination Matrix
E<-matrix(c(1,-5,0,0,1,0,0,0,1),ncol=3)
E1<-solve(E)
print("The inverse of the given elimination matrix is")
print(E1)


## Author: Sergio García Prado

rm(list = ls())

## a)
####

## Asymptotic distibution of (p1.hat, p2.hat) as parameters p1 of Bin(n, p1) and
## p2 of Bin(n, p2) independent of each other.
##
## (p1.hat, p2.hat) ~ N_2( (p1, p2) , [p1 * (1 - p1) / n, 0;
##                                     0, p2 * (1 - p2) / n] )
##

## b)
####
n1 <- 50
y1 <- 35

n2 <- 50
y2 <- 40

n <- c(n1, n2)
y <- c(y1, y2)

alpha <- 0.05

LogLikelihood <- function(p, y, n) {
  sum(y * log(p) + (n - y) * log(1 - p))
}

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

opt <- optim(runif(2), NegativeLogLikelihood, y = y, n = n, hessian = TRUE,
              lower = rep(10e-3, 2), upper = rep(1 - 10e-3, 2), method = "L-BFGS-B")

(p.hat <- opt$par)
# 0.69999745777599 0.799999683303738

(p.hat.var <- solve(opt$hessian))
# 0.004199941	0.000000000
# 0.000000000	0.003199902

g.transform <- c(-2, 1)

(g.hat <- (g.transform %*% p.hat)[1])
# -0.59999999367853

(g.hat.var <- (g.transform %*% p.hat.var %*% g.transform)[1])
# 0.0199995879878169

## Wald's Confidence Interval at (1 - alpha)% level.
g.hat + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(g.hat.var)
# -0.87717790348746 -0.3228220838696

## b)
####
g.zero <- 0

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

(W.pvalue <- 1 - pchisq(W, df = 1))
# 2.20869627943765e-05

## b)
####

LogLikelihoodHZero <- function(pp, ...) {
  LogLikelihood(c(2 * pp, pp), ...)
}

NegativeLogLikelihoodHZero <- function(...) {
  - LogLikelihoodHZero(...)
}

opt.hzero <- optim(runif(1), NegativeLogLikelihoodHZero, y = y, n = n,
                   lower = 10e-3, upper = 0.5 - 10e-3, method = "L-BFGS-B" )

(LRT <- 2 * (LogLikelihood(p.hat, y, n) - LogLikelihoodHZero(opt.hzero$par, y, n)))
# 36.089146035026

(LRT.pvalue <- 1 - pchisq(LRT, df = 1))
# 1.88493831654313e-09


#break-even multiple products

# computing a value-weighted average

# product A, CM of $10
# product B, CM of $6

# for each 1 unit of A, 2 units of B are sold
volumes <- c(1, 2)
# contribution margins
CMs <- c(10, 6)

#make the volumes relative
vol_weights <- volumes / sum(volumes)
vol_weights
#[1] 0.3333333 0.6666667

# weighted CM
CM_weighted <- weighted.mean(  CMs, vol_weights )
CM_weighted
#[1] 7.333333

#if fixed costs are $10,000 then break-even is
beUnits <- 10000/CM_weighted
beUnits
#1363.636

#volumes
beUnits * vol_weights
#[1] 454.5455 909.0909
#454.5 units of A, 909 units of B (adds up to beUnits)


twostreaks=function(song){
# song is a vector of 0's and 1's that represents the hits (0) and
# misses (1) of the notes in order

  temp = diff(c(0,which(song == 1),length(song)+1))-1
  top2 = -sort.int(-temp,partial=1:min(2,length(temp)))[1:2]
  len_top2 = sum(top2,na.rm = T)

  # About these commands:
  # which(song == 1) returns a vector indicating which on which notes (indices) a miss occurs
  #                this is important for you because it will indicate the end of a streak
  # c(0,which(song == 1),length(song)+1) creates a vector starting with 0 (indicates the beginning of the song),
  #                 then the locations of misses, and then the length of the song + 1 (indicates when the song has ended)
  # By doing a partial sort of the above vector we can quickly find to longest streaks. However, since the sort.int function
  #   doesn't sort in decreasing order you need to first negate the vector of hit streaks so an
  #   increasing sort finds the correct streaks, then negate the results to obtain the actual values.
  #   While other methods could be used to obtain the same information (possibly by sorting the entire "temp" vector)
  #   this provides a nice illustration of how to use some of the more computationally efficient tools in R that may
  #   otherwise go unnoticed.
  #
  # The combination of min(2,length(temp)) and the na.rm = T in the sum are needed when only one hit streak occurs.

  return(len_top2)
}

# Hypothesis test based on the twostreaks method
twostreaks_test = function(song,B=1000){
    # song is a vector of 0's and 1's that represents the hits (0)
	# and misses (1) of the notes in order
	# B is the number of new samples to generate

	test_stat = twostreaks(song)
	n = length(song)
	tstar_b = numeric(B)
	for(b in 1:B){
		song_tmp = sample(song)  # for permutation test
#		song_tmp = sample(song,replace=T) # for non-parametric bootstrap
#		song_tmp = rbinom(n,1,mean(song)) # for parametric bootstrap
		tstar_b[b] = twostreaks(song_tmp)
	}

	# calculate the two-sided p-value from the sampling distribution
	pval = 2*min(sum(tstar_b >= test_stat),sum(tstar_b <= test_stat))/B
		# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B
	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
twostreaks(songA)
twostreaks_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
twostreaks(songB)
twostreaks_test(songB,5000)


### 主成分分析の例
### - 県別の生活環境に関するデータ

## パッケージの読み込み
require(MASS)
require(tidyverse)
require(ggfortify)
require(GGally)

## データの読み込み ("jpamenity.csv"を用いる)
raw <- read.csv(file="data/jpamenity.csv") # データの読み込み
scan(file="data/jpamenity.txt",what=character(),sep=";") # 説明の表示

## データの整形
mydata <- raw[-1,-c(1,2)] # 不要な行・列を削除
names(mydata) <-  names(read.csv("data/jpamenityitem.csv")) # 変数名の略記
rownames(mydata) <- raw[-1,1] # 各行の名前を県名
areaname <- c("北海道","東北","関東","中部","近畿","中国","四国","九州")
area <- rep(areaname,c(1,6,7,9,7,5,4,8))

## データの内容を表示
## print(mydata) # 全データの表示
head(mydata)  # 最初の6個を表示
## tail(mydata)  # 最後の6個を表示

## データの散布図 (一部項目のみ): 図(a)
item <- c(1,7,8,18,19,20)
## print(names(mydata)[item])
ggscatmat(data.frame(mydata,area),
          columns=item, color="area", alpha=.5) +
    theme(text=element_text(family="HiraMaruProN-W4"))
## ## ggparis を用いる場合 (legendが付かない)
## ggpairs(data.frame(mydata,area),
##         columns=item, mapping=aes(colour=area)) +
##     theme(text=element_text(family="HiraMaruProN-W4"))

## 主成分分析
model <-princomp(mydata,cor=TRUE)
## model <-prcomp(mydata,scale.=TRUE) # prcompを使う場合

## 分析結果を表示
print(model)
## 寄与率 (正規化あり): 図(b)
plot(model)

## 主成分得点 (scale=1) [既定値]: 図(c)
autoplot(model, data=mydata, shape=FALSE,
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="県別の生活環境") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 中心部の拡大表示: 図(d)
autoplot(model, data=mydata, shape=FALSE,
         xlim=c(-.3,.3), ylim=c(-.3,.3),
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="県別の生活環境 (中心を拡大)") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 主成分得点 (scale=0): 図(e)
autoplot(model, data=mydata, scale=0, shape=FALSE,
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="scale=0での表示") +
    theme(text=element_text(family="HiraMaruProN-W4"))

## 主成分得点 (scale=1/2): 図(f)
autoplot(model, data=mydata, scale=1/2, shape=FALSE,
         label=TRUE, label.family="HiraMaruProN-W4", label.size=3,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.family="HiraMaruProN-W4",
         loadings.label.size=4, loadings.label.colour="blue",
         main="scale=1/2での表示") +
    theme(text=element_text(family="HiraMaruProN-W4"))


'''
A fast food franchise is test marketing 3 new
menu items. To find out if they have the same
popularity, 6 franchisee restaurants are
randomly chosen for participation in the study.
In accordance with the randomized block design,
each restaurant will be test marketing all
3 new menu items. Furthermore, a restaurant
will test market only one menu item per week,
and it takes 3 weeks to test market all menu
items. The testing order of the menu items
for each restaurant is randomly assigned as
well.

Suppose each row in the following table represents
the sales figures of the 3 new menu in a restaurant
after a week of test marketing. At .05 level of significance,
test whether the mean sales volume for the 3 new menu items
are all equal.
'''

library(readr)
dataset <- read_csv('fastfood-2.csv')
View(dataset)

#creamos un vector
r = c(t(as.matrix(df2)))

f = c("Item1", "Item2", "Item3")

k = 3
n = 6

#treatment factors
tm = gl(k, 1, n*k, factor(f))

#blocking factors
blk = gl(n, k, k*n)

av = aov(r ~ tm +blk)

summary(av)

'''
            Df Sum Sq Mean Sq F value Pr(>F)
tm           2    539     269    4.96  0.032 *
blk          5    560     112    2.06  0.155
Residuals   10    543      54

Como el p-value 0.032 es menor a la significancia .05, rechazamos la hipotesis
'''


nstreaks=function(song)
{
# song is a vector of 0's and 1's that represents the hits (0) and
# misses (1) of the notes in order

# determine the total number of hit streaks
  streaks = sum(diff(c(song,1)) == 1)

  # About these commands:
  # diff(c(song,1) calculates the difference between consecutive entries in this vector; we don't actually care about
  #			 the locations of the misses but how many hits occur between misses; we start the process of finding this
  #			 by finding the difference between consecutive indices in the vector.  The end of hit streaks are indicated
  # 		 by this difference being 1 (i.e., going from a hit of 0 to a miss of 1).  Attaching an additional 1 at
  # 		 the end of the song will ensure that if the song ends in a steak of hits it is included in the total.
  # sum( above vector == 1) counts the number of hit streaks

  return(streaks)
}

# Hypothesis test based on the nstreaks test method
nstreaks_test = function(song,B=1000){
    # song is a vector of 0's and 1's that represents the hits (0)
	# and misses (1) of the notes in order
	# B is the number of new samples to generate

	test_stat = nstreaks(song)
	n = length(song)
	tstar_b = numeric(B)
	for(b in 1:B){
		song_tmp = sample(song)  # for permutation test
#		song_tmp = sample(song,replace=T) # for non-parametric bootstrap
#		song_tmp = rbinom(n,1,mean(song)) # for parametric bootstrap
		tstar_b[b] = nstreaks(song_tmp)
	}

	# calculate the two-sided p-value from the sampling distribution
	pval = 2*min(sum(tstar_b >= test_stat),sum(tstar_b <= test_stat))/B
		# calculate a one sided p-value
#	pval = sum(tstar_b >= test_stat)/B
	return(pval)
}

# Examples using Songs A and B from Table 1

songA = c(1,0,0,0,0,0,1,0,1,0,0,1,0,0,0,0,1,0,0,0)
nstreaks(songA)
nstreaks_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
nstreaks(songB)
nstreaks_test(songB,5000)


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

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

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

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

#6 задание
print ("sixth task")
install.packages("lpSolveAPI") # Загружаем библиотеку
library(lpSolveAPI) # Активируем библиотеку линейного программирования
M <- make.lp(ncol= 2) # Объявляем количество неотрицательных переменных в M
name.lp(M, "Example") # Объявляем название "Example"для задачи(модели) М
colnames(M) <- c("X1", "X2") # Объявляем названия переменных в модели М
lp.control(M, sense = "min")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(10,5)) # Задаем целевую функцию:
add.constraint(M, c(2,4), ">=", 4) # Задаем ограничение:
add.constraint(M, c(4, 1), ">=",1) #
add.constraint(M, c(2, -3), "<=",6) #

rownames(M) <- c("A", "B","C") # Называем ограничения в модели М
M # Выводим модель M на экран
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M) # Достигнутый min
X1.opt<- get.variables(M)[1]; X1.opt # Оптимальное значение для X1
X2.opt<- get.variables(M)[2]; X2.opt # Оптимальное значение для X2
f.max<- get.objective(M); f.max# Значение целевой функции на оптимальном решении


# Your friend investigates the three observations above 700 grams and discovers that she had ordered
# the incorrect meal on those dates.
# She removes these observations from the data set and proceeds with the analysis using n=27.
#
# She assumes a normal likelihood for the data with unknown mean μ and unknown variance σ2.
# She uses the model presented in Lesson 10.2 where, conditional on σ2,
# the prior for μ is normal with mean mmm and variance σ2/w.

# Next, the marginal prior for σ2 is Inverse-Gamma(a,b).
#
# Your friend's prior guess on the mean dish weight is 500 grams,
# so we set m=500. She is not very confident with this guess,
# so we set the prior effective sample size w=0.1. Finally, she sets a=3 and b=200.
#
# We can learn more about this inverse-gamma prior by simulating draws from it. If a random variable
# X follows a Gamma(a,b) distribution, then 1/X follows an Inverse-Gamma(a,b) distribution.
# Hence, we can simulate draws from a gamma distribution and take their reciprocals,
# which will be draws from an inverse-gamma.

# Simulate a large number of draws (at least 300) from the prior for σ2
# and report your approximate prior mean from these draws. It does not need to be exact.

m = 500
w = .1
alpha = 3
beta  = 200

n = 27

x_mean = 609.7
x_var  = 401.8

alpha_prim = 16.5
beta_prim  = 6022.9
m_prim     = 609.3

prior_var_1 = 1 / rgamma(10000, alpha, beta)

posterior_var_1  = 1 / rgamma(10000, alpha_prim, beta_prim)

posterior_mean_1 = rnorm(10000, m_prim, sqrt((posterior_var_1 / (w + n))))

quantile(posterior_mean_1, c(.025, .975))

# You complete your experiment at Restaurant A with n=30 data points,
# which appear to be normally distributed.
# You calculate the sample mean y¯= 622.8 and sample variance s2 = 403.1.

# Repeat the analysis from Question 9 using the same priors and draw samples from the
# posterior distribution of sigma_A^2 and μA (where the A denotes that these parameters are for Restaurant A).

# Treating the data from Restaurant A as independent from Restaurant B,
# we can now attempt to answer your friend's original question:
# is restaurant A more generous?

# To do so, we can compute posterior probabilities of hypotheses
# like μA > μB.
# This is a simple task if we have simulated draws for μA and μB.
# For i=1,…,N (the number of simulations drawn for each parameter),
# make the comparison μA > μB using the i-th draw for μA and μB.
# Then count how many of these return a TRUE value and divide by N, the total number of simulations.

n_A = 30

x_mean_A = 622.8
x_var_A  = 403.1

alpha_prim_A = alpha + (n_A / 2)
beta_prim_A  = beta + ((n_A - 1) / 2) * x_var_A + ((w * n_A) / (2 * (w + n_A))) * (x_mean_A - m)**2
m_prim_A     = (n_A * x_mean_A + w * m) / (w + n_A)

prior_var_A = 1 / rgamma(10000, alpha, beta)

posterior_var_A  = 1 / rgamma(10000, alpha_prim_A, beta_prim_A)

posterior_mean_A = rnorm(10000, m_prim_A, sqrt((posterior_var_A / (w + n_A))))

sum(posterior_mean_A > posterior_mean_1) / 10000


## 1. Probability In Terms of Sets ##

coin_toss_omega <- length(c('HH', 'TT', 'HT', 'TH'))

## 2. Venn Diagrams ##

p_c <- 3/6
p_d <- 3/6
p_c_or_d <- 4/6
p_c_and_d <- 2/6

## 3. Unions and Intersections of Sets ##

operation_1 <- FALSE
operation_2 <- TRUE
operation_3 <- FALSE
operation_4 <- TRUE

## 4. Mutually Exclusive Events ##

mutual_exclusive_1 <- TRUE
mutual_exclusive_2 <- TRUE
mutual_exclusive_3 <- FALSE

## 5. The Addition Rule ##

p_heart_or_diamonds <- 13/52 + 13/52
p_face_card <- 3/52 + 3/52 + 3/52 + 3/52

## 6. A More General Addition Rule ##

p_f_or_t <- 0.26 + 0.11 - 0.03

Data Analyst in R/Step 5 - Probability and Statistics/3. Probability Fundamentals in R/2. Probability Rules.r


## Loss/cost functions and their gradients

## the least squares cost function - matrix operations
ls_cost_fn<-function(actual,prediction){
  n<-nrow(actual)
  (1/n)*t(prediction-actual)%*%(prediction-actual)
}

## least squares gradient - matrix operations
ls_gradient_fn<-function(w,X,y){
  if(is.null(dim(X)[2])){
    #single obs case - for stochastic alg
    X*(X%*%w-y)
  }else{
    #complete cases
    t(X)%*%(X%*%w-y)
  }
}

## Log loss function
ll_cost_fn<-function(actual, prediction) {
  epsilon <- .000000000000001
  yhat <- pmin(pmax(prediction, epsilon), 1-epsilon)
  logloss <- -mean(actual*log(yhat)
                   + (1-actual)*log(1 - yhat))
  return(logloss)
}

## -gradient of the log loss function
ll_gradient_fn<-function(w,X,y){
  n<-nrow(X)
  if(is.null(n)){
    n<-1
  }
  cost<-0
  for(i in 1:n){
    cost<-cost+(-(y*X*(1/(1+exp(X%*%w))) -
                       (1-y)*X*(1/(1+exp(-X%*%w)))))
  }
  cost/n
}


#' Fitting Weibull-log-normal model to wave data
#'
#' @description
#' This function fits a Weibull-log-normal (\code{wln}) model to the given wave data, such that the wave height
#' \code{hs} follows a translated (or 3-parameter) Weibull distribution, and the wave period given the wave
#' follows a conditional log-normal distributuion with the location and scale parameters as functions
#' of the corresponding \code{hs} value.
#'
#' @param data the wave data in the form a \code{data.table} with wave height \code{hs} and wave period
#' \code{tp} as columns.
#'
#' @param npy the number of data points per year, usually estimated by the number of rows in the
#' supplied wave data divided by the total period of data coverage (in years).
#'
#' @param weibull_method the method for fitting the Weibull distribution to the \code{hs} column in the wave data. Choose
#' between \code{"lmom"} for L-moment or \code{"mle"} for maximum likelihood estimator. The default option
#' is \code{"lmom"}.
#'
#' @details
#' The input \code{data} must be a \code{data.table} object with \code{hs} and \code{tp} columns. This can be
#' generated by reading a CSV file using function \code{\link[data.table]{fread}}.
#'
#' The formulation of the conditional distribution is given by
#' \deqn{log(tp | hs=h) ~ N(\mu(h), \sigma(h)^2)}
#' where the mean and the standard deviation are
#' \deqn{\mu(h) = a_0 + a_1 h^a_2 and \sigma(h) = b_0 + b_1 exp(h * b_2)}
#'
#' A two-step regression-based estimation method is used for fitting the conditional distribution of
#' \code{tp} given \code{hs}. The conditonal means and standard deviations are
#' estimated over fixed-width bands of \code{hs} in the first step, and regressed onto the above
#' functions of \code{hs} in the second step.
#'
#' @return A joint distribution object of class \code{wln} containing the key information of a fitted
#' Weibull-log-normal model, including the three parameters of the Weibull distribution for \code{hs} (as a named
#' numeric vector) and the six parameters of the conditional log-normal distribution for \code{tp} given \code{hs}
#' (as an unamed numeric vector, in the order of \eqn{{a_0, a_1, a_2, b_0, b_1, b_2}}).
#'
#' It is possible to replace one or multiple \code{hs} or \code{tp} parameters in an existing \code{wln} object
#' (see the examples provided below). The current version of the package does not automatically check the
#' validity of these user-input parameters. Therefore users are advised to perform the check independently.
#'
#' @examples
#' # Load data
#' data(ww3_pk)
#'
#' # Fit Weibull-log-normal distribution
#' wln1 = fit_wln(data = ww3_pk, npy = nrow(ww3_pk)/10, weibull_method = "mle")
#'
#' # Fit Weibull-log-normal distribution using the alternative method
#' wln2 = fit_wln(data = ww3_pk, npy = nrow(ww3_pk)/10, weibull_method = "lmom")
#'
#' # Update the hs parameters for object wln1
#' wln3 = copy(wln1)
#' wln3$hs$par[["loc"]] = 0.66
#' wln3$hs$par[["scale"]] = 2.2
#' wln3$hs$par[["shape"]] = 1.8
#'
#' @references
#' Haver, Sverre & Winterstein, Steven. (2009). Environmental Contour Lines: A Method for Estimating Long
#' Term Extremes by a Short Term Analysis. Transactions - Society of Naval Architects and Marine Engineers. 116.
#'
#' @seealso \code{\link{fit_ht}}, \code{\link{sample_jdistr}}
#'
#' @export
fit_wln = function(data, npy, weibull_method="lmom"){

  res = list()
  class(res) = "wln"
  res$npy = npy
  res$hs = .fit_weibull(data = data$hs, weibull_method = weibull_method)
  res$tp = .fit_iform_lnorm(hs = data$hs, tp = data$tp)
  return(res)
}

# Conditional log-normal used for IFROM -----------------------------------

.fit_iform_lnorm = function(hs, tp){

  input_data = data.table(hs, tp)[sort.list(-hs)]
  mod_data = input_data[, .(log_mean=mean(log(tp)), log_sd=sd(log(tp))), .(hs=round(hs/.hs_res)*.hs_res)]

  mod_mean = nls(
    formula = log_mean~.cond_norm_mean(hs, a0, a1, a2), data = mod_data,
    start = list(a0=1, a1=1, a2=.1), algorithm = "port", control = list(maxiter = 1e3, warnOnly=T))

  mod_sd = nls(
    formula = log_sd~.cond_norm_sd(hs, b0, b1, b2), data = mod_data, lower = c(0, 0, -Inf),
    start = list(b0=0.25, b1=0.1, b2=-0.1), algorithm = "port", control = list(maxiter = 1e3, warnOnly=T))

  res = list(par = c(coef(mod_mean), coef(mod_sd)))
  class(res) = "iform_lnorm"
  return(res)
}

.cond_norm_mean = function(hs, a0, a1, a2){
  a0+a1*hs^a2
}
.cond_norm_sd = function(hs, b0, b1, b2){
  b0+b1*exp(b2*hs)
}

# Weibull fit ----------------------------------------------------

.fit_weibull = function(data, weibull_method){
  res = list()

  if(weibull_method=="lmom"){
    out = as.numeric(lmom::pelwei(lmom::samlmu(data)))
    res$par = c(loc=out[1], scale=out[2], shape=out[3])
    res$conv = NA
  }else if(weibull_method=="mle"){
    theta0 = c(min(data-min(data))/2, sd(data), 1)
    op = nlminb(
      start = theta0,
      objective = .nll_weibull3, data = data,
      lower = c(.limit_zero, .limit_zero, .limit_zero),
      upper = c(min(data)-.limit_zero, .limit_inf, .limit_inf))
    res$par = c(loc=op$par[1], scale=op$par[2], shape=op$par[3])
    res$conv = op$convergence
  }else{
    stop("Only \"lmom\" and \"mle\" are supported.")
  }

  class(res) = "weibull"
  return(res)
}

.nll_weibull3 = function(theta, data) {
  if(theta[1]>=min(data) || theta[2]<=0 || theta[3]<=0){
    res = .limit_inf
  }else{
    nll = dweibull(data-theta[1], scale=theta[2], shape=theta[3], log = TRUE)
    res = -sum(nll)
  }
  return(res)
}


# ***************************** Neural Network ***************************
sigmoid <- function(z) {
  return(1/(1 + exp(-z)))
}

## Loss Function (Cross Entropy)
forward <- function(theta, X, y, lambda) {
  m <- length(y)
  return(1/m * sum(-y * log(sigmoid(X %*% theta)) - (1 - y) *
                     log(1 - sigmoid(X %*% theta))) + lambda/2/m * sum(theta[-1]^2))
}

## Gradient
gradient <- function(theta, X, y, lambda) {
  m <- length(y)
  return(1/m * t(X) %*% (sigmoid(X %*% theta) - y) + lambda/m *
           c(0, theta[-1]))
}

# expand 2-dimension to N dimensions: N = (degree + 1) * (degree + 2) / 2
mapFeature <- function(X1, X2, degree) {
  out <- rep(1, length(X1)) #for bias
  for (i in 1:degree) {
    for (j in 0:i) {
      out <- cbind(out, (X1^(i - j)) * (X2^j))
    }
  }
  return(out)
}

# ***************************** Parameter Optimizer ***************************

lambda <- 1
learningRate <- 1e-1
maxIteration <- 10000
tolerance <- 1e-6

mu <- 0.9
v <- NA
m <- NA
cache <- NA
decayRate <- 0.99
beta1 <- 0.9
beta2 <- 0.995

train <- function(dt, y, method){
  nPara <- ncol(dt)
  initialTheta <- rep(0, nPara)
  v <<- rep(0, nPara)
  m <<- rep(0, nPara)
  cache <<- rep(0, nPara)

  #sampling data from all train data: mini-batch
  #here, give all data (full batch)
  res <- paraOptim(dt, y, initialTheta, method)
}

TRACE_MODE <- TRUE
trace.log <- NULL
trace.level <- 10

paraOptim <- function(dt, y, theta, method){
  trace.df <- NULL

  #pre_loss <- NaN
  for(i in 0:maxIteration){
    loss <- forward(theta, dt, y, lambda)
    dx <- gradient(theta, dt, y, lambda)

    if(TRACE_MODE && (i %% trace.level == 0) ){
      trace.row <- c(epoch=i, loss=loss, theta=theta)
      trace.df <- rbind(trace.df, trace.row)
    }

    delta <- paraUpdate(method, dx, i+1)
    theta <- theta + delta

    if(sqrt(sum(delta ^ 2)) < tolerance) break
    #if((!is.nan(pre_loss)) && abs(pre_loss - loss) < tolerance) break
    #pre_loss <- loss
  }

  if(i %% maxIteration != 0){
    trace.row <- c(epoch=i, loss=loss, theta=theta)
    trace.df <- rbind(trace.df, trace.row)
  }

  converged <- if(i >= maxIteration) FALSE else TRUE
  trace.log <<- rbind(trace.log, list(method=method, final.loss=loss, final.iteration=i, converged=converged, trace=trace.df))

  print(theta)
  print(i)
  print(loss)

  return(list(theta=theta,loss=loss,iteration=i))
}

paraUpdate <- function(method, dx, t){
  if(method == "SGD"){ #Stochastic Gradient Descent
    delta <- -learningRate * dx
  }
  else if(method == "momentum"){
    v <<- mu * v - learningRate * dx
    delta <- v
  }
  else if(method == "NAG"){ #Nesterov Accelerated Gradient
    v_prev <- v
    v <<- mu * v - learningRate * dx
    delta <- -mu * v_prev + (1 + mu) * v
  }
  else if(method == "AdaGrad"){ #Duchi et al., 2011
    cache <<- cache + dx ^ 2
    delta <- -learningRate * dx / (sqrt(cache) + 1e-7)
  }
  else if(method == "RmsProp"){ #Geoff Hinton’s Coursera, 2012
    cache <<- cache * decayRate + dx ^ 2 * (1 - decayRate)
    delta <- -learningRate * dx / (sqrt(cache) + 1e-7)
  }
  else if(method == "Adam"){ #Kingma and Ba, 2014
    m <<- beta1 * m + (1-beta1) * dx
    v <<- beta2 * v + (1-beta2) * (dx ^ 2)
    if(t < 10){
      mb <- m / (1-beta1^t)
      vb <- v / (1-beta2^t)
    }
    else{
      mb <- m
      vb <- v
    }
    delta <- -learningRate * mb / (sqrt(vb) + 1e-7)
  }
  else{
    print("Error: No such optimization method!")
  }

  return(delta)
}

# ***************************** TEST Stage ***************************

data <- read.csv("ex2data2.txt", header = F) #from Andrew Ng Course

sampleSize <- 1000

randomSample <- function(sampleSize){
  data <- cbind(runif(sampleSize, -1, 1), runif(sampleSize, -1, 1), runif(sampleSize, -1, 1))
  data[,3] <- ifelse(data[,3] > 0, 1, 0)
  return(data)
}

#data <- randomSample(sampleSize) #generate random data

X <- as.matrix(data[,c(1,2)])
y <- data[,3]
X <- mapFeature(X[,1],X[,2], 3)
m <- nrow(X)
n <- ncol(X)

initialTheta <- rep(0, n)
#initialTheta <- rnorm(n) / sqrt(n) #Xavier initialization (Glorot et al., 2010)

trace.log <- NULL

train(X, y, "SGD")
train(X, y, "momentum")
train(X, y, "NAG")
train(X, y, "AdaGrad")
train(X, y, "RmsProp")
train(X, y, "Adam")

plotRes("epoch")
plotRes("position", paraX.ind=2, paraY.ind = 3) #para.ind = 1 is the bias parameter

res <- optim(initialTheta, forward, gradient, X, y, lambda, method = "BFGS", control = list(maxit = maxIteration, trace=3))
res$par
res$value
res$counts
res <- optim(initialTheta, forward, gradient, X, y, lambda, method = "L-BFGS-B", control = list(maxit = maxIteration, trace=6))
res$par
res$value
res$counts

# **************************** Visulization ****************************
maxEpoch <- 500
plotRes <- function(type, paraX.ind=2, paraY.ind=3) #show loss over paraX when set paraY.ind = 0
{
  #color_arr <- NULL;
  xrange <- NA
  yrange <- NA
  labels <- NULL;
  for(i in 1:nrow(trace.log)){
    col <- rgb(runif(5),runif(5),runif(5))
    #color_arr <- cbind(color_arr, col)

    labels <- c(labels, trace.log[[i,1]])

    xx <- trace.log[i,5]
    td <- as.data.frame(xx$trace)
    if(is.na(xrange)) {
      xrange <- c(min(td[,2+paraX.ind]),max(td[,2+paraX.ind]))
    }
    else{
      xrange = c(min(xrange[1], min(td[,2+paraX.ind])),max(xrange[2], max(td[,2+paraX.ind])))
    }

    if(is.na(yrange)){
      yrange <- c(min(td[,2+paraY.ind]),max(td[,2+paraY.ind]))
    }
    else{
      yrange = c(min(yrange[1], min(td[,2+paraY.ind])),max(yrange[2], max(td[,2+paraY.ind])))
    }
  }

  xx <- trace.log[1,5]
  td <- as.data.frame(xx$trace)
  if(type == "epoch"){
    px <- td$epoch
    py <- td$loss

    plot(x=px, y=py, col=color_arr[1], type="l", main="Convergence Performance", pch=0, xlab="epoch", ylab="loss", lty=1, lwd=2, xlim=c(0,maxEpoch))
  }
  else{
    px <- td[,2+paraX.ind]
    py <- td[,2+paraY.ind]

    xrange[2] <- xrange[2] + (xrange[2]-xrange[1])*0.4 #preserve space for legend
    plot(x=px, y=py, col=color_arr[1], type="l", main="Convergence Performance", pch=0, xlab="para 1", ylab="para2", lty=1, lwd=2,xlim=xrange,ylim=yrange)

    points(x=px[1], y=py[1], col="black", type='p', lwd=2, lty=1, pch=16, cex=2)  #start Point
    text(px[1],py[1], labels="start", adj=c(-0.3, 0.2))
  }

  for(i in 2:nrow(trace.log)){
    xx <- trace.log[i,5]
    td <- as.data.frame(xx$trace)

    if(type == "epoch"){
      px <- td$epoch
      py <- td$loss
    }
    else{
      px <- td[,2+paraX.ind]
      py <- td[,2+paraY.ind]
    }
    points(x=px, y=py, col=color_arr[i], type='l', lwd=2, lty=1, pch=0)

    fp <- nrow(td)
    points(x=px[fp], y=py[fp], col="black", type='p', lwd=2, lty=1, pch=13,cex=1.5)  #final point
  }

  legend("topright", legend = labels, col = color_arr,
         lty = 1, bg = "transparent", lwd=2)

}


# ************************************************
### simon munzert
### ols and multiple regression
# ************************************************

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

# ************************************************
# Implementing interactive relationships ---------

data("wage1")
?wage1

# without interaction
summary(wage_model <- lm(wage ~ exper + tenure, data = wage1))

# with interaction
summary(wage_model <- lm(wage ~ exper + tenure + exper*tenure, data = wage1))

# with interaction, multiplicative variable created manually
wage1$experXtenure <- wage1$exper * wage1$tenure
View(select(wage1, wage, exper, tenure, experXtenure))
summary(wage_model <- lm(wage ~ exper + tenure + experXtenure, data = wage1))

# with interaction, constitutive variables automatically added
summary(wage_model <- lm(wage ~ exper*tenure, data = wage1))

# ************************************************
# Discrete constitutive terms --------------------

data("wage1")
?wage1

# recode continuous variable to discrete variable
table(wage1$edu)
wage1$educ_cat <- car::recode(wage1$educ, "0:9='low' ;
                                           10:14='medium' ;
                                           15:18='high'",
                                           as.factor.result = TRUE,
                                           levels = c("low", "medium", "high"))

# run model
summary(wage_model <- lm(wage ~ educ_cat*female, data = wage1))
summary(wage_model <- lm(wage ~ educ_cat, data = wage1))

# ************************************************
# Replicating Brambor et al. Fig. 2 --------------

# simulation setup
set.seed(123)
N <- 500
x <- runif(N, 0, 1) * 3

z <- runif(N, 0, 1)
z <- ifelse(z >= .5, 1, 0)
z[z >= .5] <- 1
z[z  < .5] <- 0

z <- rbinom(N, 1, .5)
b0 <- 2
b1 <- 0
b2 <- 2
b3 <- 2
e <- rnorm(N, 0, sqrt(.5))
y <- b0 + b1*x + b2*z + b3*x*z + e
dat <- as.data.frame(y = y, x = x, z = z)
# plot points
plot(x[z==0], y[z==0], pch = 1, ylim = c(0, 10), xlab = "X", ylab = "Y")
points(x[z==1], y[z==1], pch = "+")
# compute models
model_full <- lm(y ~ x*z, data = dat)
model_red  <- lm(y ~ x*z - z, data = dat)
# add lines, full model
abline(coef = c(coef(model_full)[1], coef(model_full)[2]), lwd = 3)
abline(coef = c(coef(model_full)[1] + coef(model_full)[3], coef(model_full)[2] + coef(model_full)[4]), lwd = 3)
# add lines, reduced model
abline(coef = c(coef(model_red)[1], coef(model_red)[2]), lwd = 3, col = "red")
abline(coef = c(coef(model_red)[1], coef(model_red)[2] + coef(model_red)[3]), lwd = 3, col = "red")

# ************************************************
# Plotting marginal effects ----------------------

## the interplot packacge

# continuous * continuous setup
summary(wage_model <- lm(wage ~ exper*tenure, data = wage1))

# tenure as mediator
interplot(m = wage_model, var1 = "exper", var2 = "tenure", hist  = TRUE) +
  xlab('Tenure') +
  ylab('Estimated coefficient for experience') +
  ggtitle('Estimated coefficient of experience\non wage by tenure') +
  theme(plot.title = element_text(face='bold'))

# experience as mediator
interplot(m = wage_model, var1 = "tenure", var2 = "exper", hist  = TRUE) +
  xlab('Experience') +
  ylab('Estimated coefficient for tenure') +
  ggtitle('Estimated coefficient of tenure\non wage by experience') +
  theme(plot.title = element_text(face='bold'))

# continuous * discrete setup
wage1$woman <- as.factor(wage1$female)
summary(wage_model <- lm(wage ~ exper*woman, data = wage1))

# tenure as mediator
interplot(m = wage_model, var1 = "exper", var2 = "woman") +
  xlab('Woman') +
  ylab('Estimated coefficient for experience') +
  ggtitle('Estimated coefficient of experience\non wage by gender') +
  theme(plot.title = element_text(face='bold'))

# experience as mediator
interplot(m = wage_model, var1 = "woman", var2 = "exper", hist  = TRUE) +
  xlab('Woman') +
  ylab('Estimated Coefficient for gender') +
  ggtitle('Estimated Coefficient of gender\non wage by experience') +
  theme(plot.title = element_text(face='bold'))

# for more ways to tweak the plots, see
browseURL("https://cran.r-project.org/web/packages/interplot/vignettes/interplot-vignette.html")

# ************************************************
# Diagnosing non-linearity and common support ----

library(interflex)
# Mac users facing installationg problems should check out
# browseURL("http://yiqingxu.org/software/interaction/RGuide.html")
# and perform the listed Terminal calls

# again, the model
summary(wage_model <- lm(wage ~ exper*tenure, data = wage1))

# raw plots
inter.raw(Y = "wage", D = "tenure", X = "exper", data = wage1)
inter.raw(Y = "wage", D = "exper", X = "tenure", data = wage1)
inter.raw(Y = "wage", D = "female", X = "exper", data = wage1)

# plots of Generalized Additive Model (GAM)
inter.gam(Y = "wage", D = "exper", X = "tenure", data = wage1)

# binning
inter.binning(Y = "wage", D = "female", X = "exper", Z = c("tenure"), data = wage1)
inter.binning(Y = "wage", D = "exper", X = "tenure", Z = c("female"), data = wage1, Xdistr = "density")
inter.binning(Y = "wage", D = "exper", X = "tenure", Z = c("female"), data = wage1, cutoffs = (seq(0, 40, 10)))

# kernel estimation
inter.kernel(Y = "wage", D = "exper", X = "tenure", Z="female", data = wage1, nboots = 200, parallel = TRUE, cores = 3)


## 2. Combining Vectors into Matrices ##

harvard <- c(1,1,1,1,3)
stanford <- c(2,9,3,4,10)
MIT <- c(3,3,2,2,1)
cambridge <- c(4,2,6,13,48)
oxford <- c(5,7,12,9,15)
columbia <- c(6,13,13,12,4)
uni_matrix<-rbind(harvard,stanford,MIT,cambridge,oxford,columbia)
uni_matrix

## 3. Naming Matrix Rows and Columns ##

uni_matrix <- rbind(harvard, stanford, MIT, cambridge, oxford, columbia)
categories <- c("world_rank", "quality_of_education", "influence", "broad_impact" ,"patents")
colnames(uni_matrix)<-categories
uni_matrix

## 4. Finding Matrix Dimensions ##

tuition <- c(43280,45000,45016,49350,28450,55161)
dim(uni_matrix)[1]==length(tuition)

## 5. Adding Columns to Matrices ##

tuition <- c(43280, 45000, 45016, 49350, 28450, 55161)
complete_matrix<-cbind(uni_matrix,tuition)
complete_matrix

## 6. Indexing Matrices By Element ##

complete_matrix <- cbind(uni_matrix, tuition)
oxford_influence<-complete_matrix['oxford','influence']
cam_stan_patents<-complete_matrix[c('cambridge','stanford'),'patents']
cam_stan_patents

## 7. Subsetting Matrices by Rows and Columns ##

oxford_rank<-complete_matrix['oxford',]
influence<-complete_matrix[,'influence']
harv_mit_rank<-complete_matrix[c('harvard','MIT'),]
influence_patents<-complete_matrix[,c('influence','patents')]

## 8. Ranking Universites ##

world_rank_rank<-rank(complete_matrix[,'world_rank'])
quality_of_education_rank<-rank(complete_matrix[,'quality_of_education'])
influence_rank<-rank(complete_matrix[,'influence'])
broad_impact_rank<-rank(complete_matrix[,'broad_impact'])
patents_rank<-rank(complete_matrix[,'patents'])
tuition_rank<-rank(complete_matrix[,'tuition'])

## 9. Scoring and Ranking Universities ##

ranks_matrix <- rbind(world_rank_rank, quality_of_education_rank, influence_rank, broad_impact_rank, patents_rank, tuition_rank)
sum(ranks_matrix[,('harvard')])
sum(ranks_matrix[,('stanford')])
sum(ranks_matrix[,('MIT')])
sum(ranks_matrix[,('cambridge')])
sum(ranks_matrix[,('oxford')])
sum(ranks_matrix[,('columbia')])


# ......................................................................................
# ........................Exercise 4 - Continuous random variable.......................
# ......................................................................................
# ......................................................................................

# If text does not display correctly, set File \Reopen with Encoding ... to UTF-8
# Use CTRL + SHIFT + O to display the contents of the script
# Use CTRL + ENTER to run commands on a single line

# **The content of this script is only as a supplementary illustration to the exercise,
# it is not necessary to know at the exam. It is important to be able to calculate
# manually.**
#
# * Numerical integration in R ####
#
# R function **integrate**integrate(f, a, b)=$\int_{a}^{b}f(x)dx$
#
# - **f** is a R function(defined by us) which has one input argument - a vector of
# values in which to return its values
#
# - **a** lower integration limit
#
# - **b** upper integration limit
#

f = function(x){return(x*x)} # x ^ 2
a = -1
b = 2
integrate(f, a, b)

x = seq(0,10,0.1)

y=x*x/100
plot(x,y)

(9*50-20^2)/9

#  Examples ####
#
# * Example 1. ####
#
# Random variable X has distribution function$F(x)=\begin{cases} 0    &      x \leq
# 0 \\ cx^2 &  0 < x \leq 1 \\ 1    &  1 < x \end{cases}$What values can the
# constant c take?
#

# derivative of F(x) is the density of density f(x)
# corresponding probability density at interval<0.1>
f = function(x){return(2*x)} # f(x)=2x
a = 0
b = 1
integrate(f, a, b)$value

# c=1, so the distribution function looks like this:
F.dist = function(x){
    res = x*x     # x ^ 2
    res[x<=0] = 0 # 0 for x<=0
    res[x>1] = 1  # 1 for x>1
    return(res)
}

x = seq(from = -1, to = 2, by = 0.01) # points on the x-axis
FX = F.dist(x) # values of F(x)
plot(x, FX, type = 'l') # draw as a line

# * Example 2. ####
#
# The distribution of a random variable X is given by the density$f(x)=\begin{cases}
# 2x+2 & x \in <-1;0> \\ 0    & x \notin <-1;0> \end{cases}$Specify:
#
# ** 2. a) ####
#
# $F(x)$,
#

f.dens = function(x){
    res = 2*x + 2
    # watch out for x<-1 because '<-' is in the assignment line
    res[x < -1] = 0 # 0 for x<=0
    res[x > 0] = 0  # 1 for x>1
    return(res)
}

x = seq(from = -2, to = 1, by = 0.01) # points on the x-axis
fx = f.dens(x) # values of f(x)
plot(x, fx, cex=0.2) # draw dots(cex is the size)

F.dist = function(x){
    res = x*x+2*x+1     # x ^ 2 + 2x + 1
    res[x < -1] = 0 # 0 for x<=0
    res[x > 0] = 1  # 1 for x>1
    return(res)
}

x = seq(from = -2, to = 1, by = 0.01) # points on the x-axis
FX = F.dist(x) # values of f(x)
plot(x, FX, type='l') # draw dots(cex is the size)

# ** 2. b) ####
#
# P(−2 ≤ X ≤ 0.5), P(−2 ≤ X ≤ −1), P(X>0.5), P(X=0.3)
#

# P(−2 ≤ X ≤.50.5)
integrate(f.dens, -2, -0.5)$value
integrate(f.dens, -1, -0.5)$value

# P(−2 ≤ X − −1)
integrate(f.dens, -2, -1)$value

# P(X>0.5)
integrate(f.dens, 0.5, 1e16)$value # This will not always work

# P(X=0.3)
integrate(f.dens, 0.3, 0.3)$value
# it is clear that this probability is 0
# corresponds to the integral sa=b, ie with zero size on the x-axis

# ** 2. c) ####
#
# mean, variance and standard deviation of the random variable X.
#

# E(X)
x_fx = function(x){
    fx = f.dens(x)
    return(x*fx)
}
# we integrate only where we know that f(x) is nonzero
E_X = integrate(x_fx, -1, 0)$value
E_X
-1/3

# E(X ^ 2)
xx_fx = function(x){
    fx = f.dens(x)
    return(x*x*fx)
}
# we integrate only where we know that f(x) is nonzero
E_XX = integrate(xx_fx, -1, 0)$value
E_XX
1/6

# D(X)
D_X = E_XX - E_X^2
D_X
1/18

# sigma(x)
std_X = sqrt(D_X)
std_X
sqrt(2)/6

# ** 2. d) ####
#
# mode $\hat{x}$
#

# mode=0

# ** 2. e) ####
#
# median $x_{0,5}$
#

x = seq(from = -2, to = 1, by = 0.001) # points on the x-axis
FX = F.dist(x)
plot(x, FX, type='l')
lines(c(-2, 1),c(0.5, 0.5))

x[FX >= 0.5][1] # first element zx for which F(x)>=0.5
(-2+sqrt(2))/2

# * Example 3. ####
#
# The random variable Y is defined as: Y=3X + 1, where X is the random variable from the
# previous example. Specify:
#
# ** 3. a) ####
#
# $F_Y(y)$
#

FY.dist = function(y){
    # calculated from the relation FY(y)=P(Y<y)=P(3X + 1<y)=...
    x = (y-1)/3
    FY = F.dist(x)
    return(FY)
}
y = seq(from = -3, to = 2, by = 0.001) # points on the x-axis
FY = FY.dist(y)
plot(y, FY, type='l')

# ** 3. b) ####
#
# $f_Y(y)$
#

# derivation of F_Y
fY.dens = function(y){
    res = 2/9*(y + 2)
    res[y < -2] = 0 # 0 for x<-2
    res[y > 1] = 0  # 1 for x>1
    return(res)
}
integrate(fY.dens,-2,1)$value # total integral check
y = seq(from = -3, to = 2, by = 0.001) # points on the x-axis
fY = fY.dens(y)
plot(y, fY, cex=0.2)

# ** 3. c) ####
#
# E(Y), D(Y), σ(Y)
#

# E(Y)
y_fy = function(y){
    fy = fY.dens(y)
    return(y*fy)
}
# we integrate only where we know that f(y) is nonzero
E_Y = integrate(y_fy, -2, 1)$value
E_Y
0

# alternatively
E_Y = 3*E_X + 1
E_Y

# E(Y ^ 2)
yy_fy = function(y){
    fy = fY.dens(y)
    return(y*y*fy)
}
# we integrate only where we know that f(y) is nonzero
E_YY = integrate(yy_fy, -2, 1)$value
E_YY
1/2

# D(Y)
D_Y = E_YY - E_Y^2
D_Y
1/2

# alternatively
D_Y = 3^2*D_X
D_Y

# sigma(Y)
sqrt(D_Y)
sqrt(2)/2

# * Example 4 ####
#
# Calculate $\omega$ such that a random variable X with probability
# density:$f(x)=\begin{cases} 0 & x < 0 \\ 3e^{-3x}    & x \geq 0 \end{cases}$is
# greater than $\omega$ with probability 0.3.
#

F.dist = function(x){
    res = 1 - exp(-3*x)
    res[x < 0] = 0 # 0 for x<=0
    return(res)
}

x = seq(from = -1, to = 3, by = 0.001) # points on the x-axis
FX = F.dist(x)
plot(x, FX, type='l')
lines(c(-1, 3),c(0.7, 0.7))

x[FX >= 0.7][1]

-1/3*log(0.3)


#Random design

'''
A fast food franchise is test marketing 3 new menu items.
To find out if they the same popularity, 18 franchisee
restaurants are randomly chosen for participation in t
he study. In accordance with the completely randomized design,
6 of the restaurants are randomly chosen to test market the
first new menu item, another 6 for the second menu item, and
the remaining 6 for the last menu item.
'''

'''
Suppose the following table represents the sales figures of
the 3 new menu items in the 18 restaurants after a week of
test marketing. At .05 level of significance, test whether
the mean sales volume for the 3 new menu items are all equal.

'''

#Cargar el archivo fastfood-1.txt

library(readr)
df1 <- read_csv('fastfood-1.csv')
View(dataset)

#Concatenar las filas
r = c(t(as.matrix(df1)))

f = c("Item1","Item2","Item3") #niveles de tratamiento
k = 3 #nro de niveles de tratamiento
n = 6# #obesrvaciones por tratamiento

#crear un vector de factores que corresponde a cada elemento de r en3 pasos

tm = gl(k, 1, n*k, factor(f))

#aplicamos aov
av = aov(formula formula = r ~ tm)

summary(av)

'''
            Df Sum Sq Mean Sq F value Pr(>F)
tm           2  745.4   372.7   2.541  0.112
Residuals   15 2200.2   146.7

Como pvalue = 0.112>.05 niveles de significancia, aceptamos la hipotesis
'''


#' @include Bayesian_Bricks.r

countFreq <- function(x,uniqx=NULL){
    if(!is.factor(x)){
        if(!is.null(uniqx)) x <- factor(x,levels=uniqx)
        else x <- factor(x)
    }
    as.numeric(tabulate(x,nbins = length(levels(x))))
}
countFreq_Weighted <- function(x,uniqx=NULL,w){
    if(length(x)!=length(w)) stop("length of x and w don't match")
    if(!is.factor(x)){
        if(!is.null(uniqx)) x <- factor(x,levels=uniqx)
        else x <- factor(x)
    }
    vapply(split(x=w,f=x),sum,FUN.VALUE = numeric(1),USE.NAMES = FALSE)
}

#' @title Random generation for Categorical distribution
#' @description
#' Generate random integer samples from a Categorical distribution. For a random variable x, the density function of categorical distribution is defined as
#'   \deqn{prod_{k in 1:K} p_k^{I(x=k)}}
#' Where K is the number of unique values.
#' @seealso \code{\link{dCategorical}}
#' @param n integer, number of samples.
#' @param p numeric, probabilities. length(p)=K.
#' @return An integer vector of length n.
#' @export
#' @examples
#' rCategorical(n=20,p=c(1,2))
rCategorical <- function(n,p){
    sample.int(n=length(p), size = n, replace = TRUE, prob = p)
}

#' @title Probability mass function for Categorical distribution
#' @description
#' Calculate probability masses for integer valued Categorical random samples.
#' For a random variable x, the density function of categorical distribution is defined as
#'   \deqn{prod_{k in 1:K} p_k^{I(x=k)}}
#' Where K is the number of unique values.
#' @seealso \code{\link{rCategorical}}
#' @param x integer, categorical samples.
#' @param p numeric, probabilities.
#' @return A numeric vector of the same length of 'x'.
#' @export
#' @examples
#' \donttest{
#' dCategorical(x=c(1L,2L,1L),p=c(1,2))
#' }
dCategorical <- function(x,p){
    p[x]
}

#' @title Random generation for Dirichelt distribution
#' @description
#' Generate random samples from Dirichlet distribution. For a random vector x, the density function is Dirichlet distribution is defined as:
#'   1/Beta(alpha) prod_{i=1:p}  x_i^{alpha_i -1}
#' Where Beta() is the beta function. p is the dimension of x.
#' @seealso \code{\link{dDir}}
#' @param n integer, number of samples.
#' @param alpha numeric, Dirichlet parameter.
#' @return A numeric matrix of n rows and length(alpha) columns.
#' @export
#' @examples
#' rDir(5,c(1,2,3)) #generate 5 samples with parameters c(1,2,3)
#' @import stats
rDir <- function(n, alpha){
    l <- length(alpha)
    x <- matrix(rgamma(l * n, alpha), ncol = l, byrow = TRUE)
    sm <- x %*% rep(1, l)
    x/as.vector(sm)
}

#' @title Density function for Dirichelt distribution
#' @description
#' Calculate the densities of a given set of Dirichlet samples. For a random vector x, the density function is defined as:
#'   1/Beta(alpha) prod_{i=1:p}  x_i^{alpha_i -1}
#' Where Beta() is the beta function. p is the dimension of x.
#' @seealso \code{\link{rDir}}
#' @param x matrix or numeric vector, if matrix every row of x is an observation, if numeric vector, it's the same as a matrix with only one row.
#' @param alpha numeric, Dirichlet parameter.
#' @param LOG logical, return the log density if set to "TRUE".
#' @return A numeric vector of density values.
#' @export
#' @examples
#' x <- rDir(5,c(1,2,3)) #generate 5 samples with parameters c(1,2,3)
#' dDir(x,c(1,2,3))
#' dDir(x,c(1,2,3),LOG=TRUE)
dDir <- function(x, alpha,LOG=FALSE){
    if(!is.matrix(x))
        if(is.numeric(x))
            x <- t(x)
        else
            stop("Error in ddir():x must be a matrix or an integer/numeric vector")
    if(length(alpha)==1) alpha <- rep(alpha,ncol(x))
    if(ncol(x)!=length(alpha))
        stop("Error in ddir(): columns of x and length of alpha don't match")
    out <- apply(x,1,function(l){
        s <- (alpha - 1) * log(l)
        s <- ifelse(alpha == 1 & l == 0, -Inf, s)
        sum(s)
    })
    logD <- sum(lgamma(alpha)) - lgamma(sum(alpha))
    out <- out- logD
    if(!LOG) out <- exp(out)
    return(out)
}

#' @title Create objects of type "CatDirichlet".
#' @description
#' Create an object of type "CatDirichlet", which represents the Categorical (Multinomial) and Dirichlet conjugate structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The created object will be used as a place for recording and accumulating information in the related inference/sampling functions such as posterior(), posteriorDiscard(), MAP(), marginalLikelihood(), dPosteriorPredictive(), rPosteriorPredictive() and so on. A categorical distribution is defined on a set of unique labels, usually these labels are integers, they can also be characters and factors.
#' @seealso \code{\link{posterior.CatDirichlet}},\code{\link{posteriorDiscard.CatDirichlet}},\code{\link{MAP.CatDirichlet}},\code{\link{MPE.CatDirichlet}},\code{\link{marginalLikelihood.CatDirichlet}},\code{\link{rPosteriorPredictive.CatDirichlet}},\code{\link{dPosteriorPredictive.CatDirichlet}} ...
#' @param objCopy an object of type "CatDirichlet". If "objCopy" is not NULL, the function create a new "CatDirichlet" object by copying the content from objCopy, otherwise this new object will be created by using "ENV" and "gamma". Default NULL.
#' @param ENV environment, specify where the object will be created.
#' @param gamma list, a named list of parameters, gamma=list(alpha,uniqueLabels). Where gamma$alpha is a numeric vector specifying the parameters of the Dirichlet distribution, gamma$uniqueLabels is a integer/character vector specifying the unique category labels of the Categorical distribution.
#' @return An object of class "CatDirichlet".
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=c(1,2,1),uniqueLabels = letters[1:3]))
#' obj #print the content
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
CatDirichlet <- function(objCopy=NULL,ENV=parent.frame(),gamma=list(alpha=1,uniqueLabels=1L)){
    object <- BasicBayesian(ENV = ENV)

    if(!is.null(objCopy)){
        if(!.is(objCopy,"CatDirichlet")) stop("'objCopy' must be of class 'CatDirichlet'")
        object$gamma <- objCopy$gamma
        object$H <- objCopy$H
        object$F <- objCopy$F
    }else{
        if(!missing(gamma))
            if((!is.list(gamma)) |
               (!all(names(gamma) %in% c("alpha","uniqueLabels"))))
                stop("gamma must be list(alpha,uniqueLabels)")
        if(length(gamma$alpha)==1L) gamma$alpha <- rep(gamma$alpha,length(gamma$uniqueLabels))
        if(length(gamma$alpha)!=length(gamma$uniqueLabels)) stop("length of 'alpha' and 'uniqueLabels' in 'gamma' don't match!")
        object$gamma <- gamma
        object$H <- "Dirichlet"
        object$F <- "Categorical"
    }

    class(object) <- c("CatDirichlet",class(object))
    return(object)
}

#' @title Sufficient statistics of a "CatDirichlet" object
#' @description
#' For following Categorical-Dirichlet model structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The sufficient statistics of a set of samples x is: \cr
#' \itemize{
#'  \item the effective counts of each unique label in x. i.e. T(x)[i] = sum(uniqueLabels[i]%in%x). Unique values of x must be in obj$gamma$uniqueLabels, where "obj" is a "CatDirichlet" object, see examples below.
#' }
#' @seealso \code{\link{CatDirichlet}}, \code{\link{sufficientStatistics_Weighted.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param x numeric,integer or character, samples of the Categorical distribution.
#' @param foreach logical, specifying whether to return the sufficient statistics for each observation. Default FALSE.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return An object of class "ssCat", the sufficient statistics of a set of categorical samples. Or an object of the same class as x if foreach=TRUE.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26,1,2),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' w <- runif(20)
#' sufficientStatistics(obj=obj,x=x)       #return the counts of each unique label
#' sufficientStatistics_Weighted(obj=obj,x=x,w=w) #return the weighted counts of each unique lable
#' sufficientStatistics(obj=obj,x=x,foreach = TRUE) #return the sample itself
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
sufficientStatistics.CatDirichlet <- function(obj,x,foreach=FALSE,...){
    if(missing(x)) stop("'x' must be specified")
    if(!is.vector(x)) x <- as.vector(x)
    if(foreach){
        x
    }else{
        ss <- countFreq(x=x,uniqx = obj$gamma$uniqueLabels)
        class(ss) <- "ssCat"
        ss
    }
}

#' @title Weighted sufficient statistics of a "CatDirichlet" object
#' @description
#' For following Categorical-Dirichlet model structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' the sufficient statistics of a set of samples x and weights w are: \cr
#'   the effective counts (in this case the sum of the weight w) of each unique label in x \cr
#' Unique values of x must be in obj$gamma$uniqueLabels, where "obj" is a "CatDirichlet" object, see examples below.
#'
#' @seealso \code{\link{sufficientStatistics.CatDirichlet}} \code{\link{CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param x numeric,integer or character, samples of the Categorical distribution.
#' @param w numeric, sample weights.
#' @param foreach logical, specifying whether to return the sufficient statistics for each observation. Default FALSE.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return An object of class "ssCat", the sufficient statistics of a set of categorical samples. Or an object of the same class as x if foreach=TRUE.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26,1,2),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' w <- runif(20)
#' sufficientStatistics(obj=obj,x=x)       #return the counts of each unique label
#' sufficientStatistics_Weighted(obj=obj,x=x,w=w) #return the weighted counts of each unique lable
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
sufficientStatistics_Weighted.CatDirichlet <- function(obj,x,w,foreach=FALSE,...){
    if(missing(x)|missing(w)) stop("'x' and 'w' must be both specified")
    if(!is.vector(x)) x <- as.vector(x)
    if(!is.vector(w)) w <- as.vector(w)
    if(length(x)!=length(w)) stop("length of 'x' and 'w' don't match!")
    if(foreach){
        x
    }else{
        ss <- countFreq_Weighted(x=x,uniqx = obj$gamma$uniqueLabels,w=w)
        class(ss) <- "ssCat"
        ss
    }
}

#' @title Update a "CatDirichlet" object with sample sufficient statistics
#' @description
#' For the model structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' update alpha by adding the information of newly observed samples x. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object, the prior parameters in this object will be updated after running this function.
#'
#' @seealso \code{\link{CatDirichlet}},\code{\link{posteriorDiscard.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param ss Sufficient statistics of x. In Categorical-Dirichlet case the sufficient statistic of sample x can be either x itself, of an "ssCat" object generated by the function sufficientStatistics.CatDirichlet().
#' @param w Sample weights, default NULL.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return None. the gamma stored in "obj" will be updated based on "ss".
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=rep(1,26),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' w <- runif(20)
#' posterior(obj=obj,ss=x)
#' obj
#' posteriorDiscard(obj=obj,ss=x)
#' obj
#' ## weighted sample
#' posterior(obj=obj,ss=x,w=w)
#' obj
#' posteriorDiscard(obj=obj,ss=x,w=w)
#' obj
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
posterior.CatDirichlet <- function(obj,ss,w=NULL,...){
    if(missing(ss)) stop("'ss' must be specified")
    if(.is(ss,"ssCat")){
        posterior_bySufficientStatistics.CatDirichlet(obj=obj,ss=ss)
        invisible(return())
    }
    if(!is.vector(ss)) ss <- as.vector(ss)
    idx <- match(ss,obj$gamma$uniqueLabels,nomatch = NA)
    if(anyNA(idx)) stop("Detect un-recorded label!")
    if(!is.null(w)){
        if(!is.vector(w)) w <- as.vector(w)
        if(length(ss)!=length(w)) stop("length of 'ss' and 'w' don't match!")
        if(length(ss)==1L){
            obj$gamma$alpha[idx] <- obj$gamma$alpha[idx]+w
        }else{
            for(i in 1L:length(ss)) obj$gamma$alpha[idx[i]] <- obj$gamma$alpha[idx[i]]+w[i]
        }
    }else{
        if(length(ss)==1L){
            obj$gamma$alpha[idx] <- obj$gamma$alpha[idx]+1
        }else{
            for(id in idx) obj$gamma$alpha[id] <- obj$gamma$alpha[id]+1
        }
    }
}

#' @title Update a "CatDirichlet" object with sample sufficient statistics
#' @description Update a "CatDirichlet" object with sample sufficient statistics
#' @param obj A "CatDirichlet" object.
#' @param ss Sufficient statistics of x. In Categorical-Dirichlet case the sufficient statistic of sample x can be either x itself, of an "ssCat" object generated by the function sufficientStatistics.CatDirichlet().
#' @param ... Additional arguments to be passed to other inherited types.
#' @return None. the gamma stored in "obj" will be updated based on "ss".
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
posterior_bySufficientStatistics.CatDirichlet <- function(obj,ss,...){
    if(missing(ss)) stop("'ss' must be specified")
    if(!.is(ss,"ssCat")) stop("'ss' must be of class 'ssCat', you need to use sufficientStatistics() to generate 'ssCat' objects")

    if(length(ss)!=length(obj$gamma$alpha)) stop("length 'ss' and dirichlet parameters don't match")
    obj$gamma$alpha <- obj$gamma$alpha + as.numeric(ss)
}

#' @title Update a "CatDirichlet" object with sample sufficient statistics
#' @description
#' Contrary to posterior(), this function will update alpha by removing the information of observed samples x for the model structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object, the prior parameters in this object will be updated after running this function.
#'
#' @seealso \code{\link{CatDirichlet}},\code{\link{posterior.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param ss Sufficient statistics of x. In Categorical-Dirichlet case the sufficient statistic of sample x can be either x itself, of an "ssCat" object generated by the function sufficientStatistics.CatDirichlet().
#' @param w Sample weights,default NULL.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return None. the prior parameters stored in "obj" will be updated with the information in "ss".
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=rep(1,26),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' w <- runif(20)
#' posterior(obj=obj,ss=x)
#' obj
#' posteriorDiscard(obj=obj,ss=x)
#' obj
#' ## weighted sample
#' posterior(obj=obj,ss=x,w=w)
#' obj
#' posteriorDiscard(obj=obj,ss=x,w=w)
#' obj
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
posteriorDiscard.CatDirichlet <- function(obj,ss,w=NULL,...){
    if(missing(ss)) stop("'ss' must be specified")
    if(.is(ss,"ssCat")){
        posteriorDiscard_bySufficientStatistics.CatDirichlet(obj = obj,ss = ss)
        invisible(return())
    }
    if(!is.vector(ss)) ss <- as.vector(ss)
    idx <- match(ss,obj$gamma$uniqueLabels,nomatch = NA)
    if(anyNA(idx)) stop("Detect un-recorded label!")
    if(!is.null(w)){
        if(!is.vector(w)) w <- as.vector(w)
        if(length(ss)!=length(w)) stop("length of 'ss' and 'w' don't match!")
        if(length(ss)==1L){
            obj$gamma$alpha[idx] <- obj$gamma$alpha[idx]-w
        }else{
            for(i in 1L:length(ss)) obj$gamma$alpha[idx[i]] <- obj$gamma$alpha[idx[i]]-w[i]
        }
    }else{
        if(length(ss)==1L){
            obj$gamma$alpha[idx] <- obj$gamma$alpha[idx]-1
        }else{
            for(id in idx) obj$gamma$alpha[id] <- obj$gamma$alpha[id]-1
        }
    }

}

#' @title Update the prior Dirichlet distribution with sample sufficient statistics
#' @seealso \code{\link{posteriorDiscard}}
#' @param obj A "CatDirichlet" object.
#' @param ss Sufficient statistics of x. In Categorical-Dirichlet case the sufficient statistic of sample x can be either x itself, of an "ssCat" object generated by the function sufficientStatistics.CatDirichlet().
#' @param ... Additional arguments to be passed to other inherited types.
#' @return None. the gamma stored in "obj" will be updated based on "ss".
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
posteriorDiscard_bySufficientStatistics.CatDirichlet <- function(obj,ss,...){
    if(missing(ss)) stop("'ss' must be specified")
    if(!.is(ss,"ssCat")) stop("'ss' must be of class 'ssCat', you need to use sufficientStatistics() to generate 'ssCat' objects")
    if(length(ss)!=length(obj$gamma$alpha)) stop("length 'ss' and dirichlet parameters don't match")
    obj$gamma$alpha <- obj$gamma$alpha - as.numeric(ss)
}

#' @title MAP estimate of a "CatDirichlet" object
#' @description
#' Generate the MAP estimate of "pi" in following Categorical-Dirichlet structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' MAP is pi_MAP = argmax p(pi|alpha,x).
#' @seealso \code{\link{CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return A numeric vector, the MAP estimate of "pi".
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=rep(1,26),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' w <- runif(20)
#' posterior(obj=obj,ss=x,w=w)
#' MAP(obj)
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
MAP.CatDirichlet <- function(obj,...){
    tmp <- obj$gamma$alpha-1
    tmp/sum(tmp)
}

#' @title MPE of a "CatDirichlet" object
#' @description
#' Generate the MPE of "pi" in following Categorical-Dirichlet structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' MPE is pi_MPE = E(pi|alpha,x), E() is the expectation function.
#' @seealso \code{\link{CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return A numeric vector, the MPE of "pi".
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=rep(1,26),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' w <- runif(20)
#' posterior(obj=obj,ss=x,w=w)
#' MPE(obj)
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
MPE.CatDirichlet <- function(obj,...){
    obj$gamma$alpha/sum(obj$gamma$alpha)
}

#' @title Density function of the posterior distribution of a "CatDirichlet" object
#' @description
#' Generate the the density value of the posterior distribution of the following structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' Posterior density is the density function of Dir(pi|alpha).
#' @seealso \code{\link{CatDirichlet}}, \code{\link{rPosterior.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param pi matrix or a numeric vector. When pi is a matrix, each row is an observation. When pi is a vector, it will be treated as only one observation.
#' @param LOG Return the log density if set to "TRUE".
#' @param ... Additional arguments to be passed to other inherited types.
#' @return numeric vector, the posterior densities for each row of pi.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26),uniqueLabels = letters))
#' dPosterior(obj = obj,pi = runif(26))
#' dPosterior(obj = obj,pi = matrix(runif(26*10),nrow = 10))
dPosterior.CatDirichlet <- function(obj,pi,LOG=TRUE,...){
    if(is.vector(pi)) pi <- matrix(pi,nrow=1)
    if(ncol(pi)!=length(obj$gamma$alpha)) stop("Dimensions of pi and obj$gamma$alpha don't match!")
    dDir(x=pi,alpha = obj$gamma$alpha,LOG = LOG)
}

#' @title Generate ramdom samples from the posterior distribution of a "CatDirichlet" object
#' @description
#' Generate random samples from the posterior distribution of the following structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' Posterior distribution is Dir(pi|alpha).
#' @seealso \code{\link{CatDirichlet}}, \code{\link{dPosterior.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param n integer, the number of samples to be generated.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return A matrix, each row is a sample of pi.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=rep(1,26),uniqueLabels = letters))
#' rPosterior(obj = obj,n=3)
rPosterior.CatDirichlet <- function(obj,n=1,...){
    rDir(n=n,alpha = obj$gamma$alpha)
}

#' @title Marginal likelihood of a "CatDirichlet" object
#' @description
#' Generate the marginal likelihood of the following model structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' Marginal likelihood is the likelihood of x|alpha.
#' @seealso \code{\link{CatDirichlet}}, \code{\link{marginalLikelihood_bySufficientStatistics.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param x numeric/integer/character vector, observed Categorical samples.
#' @param LOG Return the log density if set to "TRUE".
#' @param ... Additional arguments to be passed to other inherited types.
#' @return numeric, the marginal likelihood.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26,1,2),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' marginalLikelihood(obj=obj,x=x,LOG = TRUE) #marginal likelihood
#' ss <- sufficientStatistics(obj = obj,x=x)
#' marginalLikelihood_bySufficientStatistics(obj=obj,ss = ss,LOG = TRUE)
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
marginalLikelihood.CatDirichlet <- function(obj,x,LOG=TRUE,...){
    if(missing(x)) stop("'x' must be specified")
    if(!is.vector(x)) x <- as.vector(x)
    ss <- countFreq(x=x,uniqx = obj$gamma$uniqueLabels)
    class(ss) <- "ssCat"
    marginalLikelihood_bySufficientStatistics.CatDirichlet(obj=obj,ss=ss,LOG = LOG)
}

#' @title Marginal likelihood of a "CatDirichlet" object, using sufficient statistics
#' @description
#' Generate the marginal likelihood of a set of observations of the following model structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' Marginal likelihood is the likelihood of x|alpha
#' @seealso \code{\link{CatDirichlet}}, \code{\link{marginalLikelihood.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param ss Sufficient statistics of x. In Categorical-Dirichlet case the sufficient statistic of sample x can be either x itself, of an "ssCat" object generated by the function sufficientStatistics.CatDirichlet().
#' @param LOG Return the log density if set to "TRUE".
#' @param ... Additional arguments to be passed to other inherited types.
#' @return numeric, the marginal likelihood.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26,1,2),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' marginalLikelihood(obj=obj,x=x,LOG = TRUE) #marginal likelihood
#' ss <- sufficientStatistics(obj = obj,x=x)
#' marginalLikelihood_bySufficientStatistics(obj=obj,ss = ss,LOG = TRUE)
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
marginalLikelihood_bySufficientStatistics.CatDirichlet <- function(obj,ss,LOG=TRUE,...){
    if(missing(ss)) stop("'ss' must be specified")
    if(!.is(ss,"ssCat")){
        ss <- sufficientStatistics.CatDirichlet(obj = obj,x=ss,foreach = FALSE)
    }
    if(length(ss)!=length(obj$gamma$alpha)) stop("length 'ss' and dirichlet parameters don't match")
    a <- obj$gamma$alpha+as.numeric(ss)
    aa <- sum(a)
    aa0 <- sum(obj$gamma$alpha)
    logp <- lgamma(aa0) - lgamma(aa) + sum(lgamma(a)-lgamma(obj$gamma$alpha))
    if(!LOG) logp <- exp(logp)
    logp
}

#' @title Posterior predictive density function of a "CatDirichlet" object
#' @description
#' Generate the the density value of the posterior predictive distribution of the following structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object. \cr
#' Posterior predictive is a distribution of x|alpha.
#' @seealso \code{\link{CatDirichlet}}, \code{\link{dPosteriorPredictive.CatDirichlet}}, \code{\link{marginalLikelihood.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param x numeric/integer/character vector, observed Categorical samples.
#' @param LOG Return the log density if set to "TRUE".
#' @param ... Additional arguments to be passed to other inherited types.
#' @return A numeric vector, the posterior predictive density.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26,1,2),uniqueLabels = letters))
#' x <- sample(letters,size = 20,replace = TRUE)
#' ## res1 and res2 should provide the same result
#' res1 <- dPosteriorPredictive(obj = obj,x=x,LOG = TRUE)
#' res2 <- numeric(length(x))
#' for(i in seq_along(x)) res2[i] <- marginalLikelihood(obj=obj,x=x[i],LOG = TRUE)
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
dPosteriorPredictive.CatDirichlet <- function(obj,x,LOG=TRUE,...){
    if(missing(x)) stop("'x' must be specified")
    if(!is.vector(x)) x <- as.vector(x)
    probs <- obj$gamma$alpha/sum(obj$gamma$alpha)
    out <- probs[match(x,obj$gamma$uniqueLabels)]
    if(LOG) out <- log(out)
    out
}

#' @title Generate random samples from the posterior predictive distribution of a "CatDirichlet" object
#' @description
#' Generate random samples from the posterior predictive distribution of the following structure:
#'      \deqn{pi|alpha \sim Dir(alpha)}
#'      \deqn{x|pi \sim Categorical(pi)}
#' Where Dir() is the Dirichlet distribution, Categorical() is the Categorical distribution. See \code{?dDir} and \code{dCategorical} for the definitions of these distribution. \cr
#' The model structure and prior parameters are stored in a "CatDirichlet" object \cr
#' posterior predictive is a distribution of x|alpha
#' @seealso \code{\link{CatDirichlet}}, \code{\link{dPosteriorPredictive.CatDirichlet}}
#' @param obj A "CatDirichlet" object.
#' @param n integer, number of samples.
#' @param ... Additional arguments to be passed to other inherited types.
#' @return A vector of the same type as obj$gamma$uniqueLabels.
#' @export
#' @examples
#' obj <- CatDirichlet(gamma=list(alpha=runif(26,1,2),uniqueLabels = letters))
#' rPosteriorPredictive(obj=obj,n=200)
#' @references Murphy, Kevin P. Machine learning: a probabilistic perspective. MIT press, 2012.
rPosteriorPredictive.CatDirichlet <- function(obj,n,...){
    if(missing(n)) stop("'n' must be specified")
    n <- as.integer(n)
    obj$gamma$uniqueLabels[sample.int(n=length(obj$gamma$uniqueLabels), size = n, replace = TRUE,prob = obj$gamma$alpha/sum(obj$gamma$alpha))]
}


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

GaussBackward <- function(A) {
  n <- nrow(A)
  m <- ncol(A)
  x <- vector()
  for(i in 1:n){
    c <- 0
    t <- 1
    for(j in (m-i):(m-1)){
      if((j) == (m-1)){
        break
      }
      c <- c + (x[i-t] * A[(n+1)-i,j+1])
      t <- t + 1
    }
    x[i] <- A[(n+1)-i,m] - c
  }
  print(A)
  for (i in n:1) {
    print(x[i])
  }
}


fatorial <- function(n) {
  res = 1
  for(i in 1:n) {
    res = res*i
  }
  return(res)
}
#fatorial(5)
#res = 1
#i = 1
#res = res*1 = 1 (1)
#i = 2
#res = res*2 = 2 (1x2)
#i = 3
#res = res*3 = 6 (1x2x3)
#i = 4
#res = res*4 = 24 (1x2x3x4)
#i = 5
#res = res*5 = 120 (1x2x3x4x5)


mu <- pi
sigmaSq <- (1.3)^3

n <- 10
M <- 10000

svar <- function(x){
  n <- length(x)
  xb <- mean(x)
  sv <- sum((x-xb)^2)/n
  return(sv)
}

data.sets <- matrix(rnorm(n = n*M, mean = mu, sd = sqrt(sigmaSq)), ncol = n, nrow = M)

xbars <- apply(data.sets, 1, mean)
sbars <- apply(data.sets, 1, svar)

par(mfrow=c(1, 2))

hist(xbars, probability = TRUE, main = "Média amostral", xlab = expression(bar(X[n])))
curve(dnorm(x, mean = mu, sd = sqrt(sigmaSq/n)), min(xbars), max(xbars), lwd = 2, add = TRUE)

hist(sbars, probability = TRUE, main = "Variância amostral", xlab = expression(bar(S[n]^2)))
curve(dgamma(x, shape = (n-1)/2, rate = n/(2*sigmaSq) ), min(sbars), max(sbars), lwd = 2, add = TRUE)


#Suppose the mean weight of King Penguins found in an Antarctic colony
#last year was 15.4 kg. In a sample of 35 penguins same time this year in
#the same colony, the mean penguin weight is 14.6 kg. Assume the sample
#standard deviation is 2.5 kg. At .05 significance level, can we reject
#the null hypothesis that the mean penguin weight does not differ from last
#year?

xbar = 14.6

mu0 =15.4

s = 2.5

n = 35

t = (xbar-mu0)/(s/(sqrt(n)))

t #-1.89

#valores criticos
alpha = .05
t.half.aplha = qt(1-alpha,df = n-1)

#se rechaza la hipotesis
c(-t.half.aplha,t.half.aplha)

#pvalue

pval = 2*pt(t,df=n-1)

pval #0.0668

Parcial/1. Prueba de hipotesis/TwoTailedMeanUknownVariance.r


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

rm(list = ls())

observed <- c(1.0, 2.3, 4.2, 7.1, 10.4)

(k <- length(observed))
# 5

(lambda.hat <- 1 / mean(observed))
# 0.2

test <- ks.test(observed, pexp, rate = 1 / mean(observed))

(D <- test$statistic[[1]])
# 0.181269246922018

(criticvalue <- quantile(replicate(1000, ks.test(rexp(k, lambda.hat), pexp, rate = lambda.hat)$statistic), 0.95))
# 95%: 0.56811734613071

D > criticvalue
# FALSE (H0 no refused)


## 2. The Mean ##

distribution  <-  c(0,2,3,3,3,4,13)
mean  <-  sum(distribution) / length(distribution)
center  <-  FALSE

values_above  <-  distribution[distribution > mean]
values_below  <-  distribution[distribution < mean]

distances_above <- values_above - mean
distances_below <- mean - values_below

equal_distances  <-  sum(distances_above) == sum(distances_below)

## 3. Generating a distribution ##

set.seed(1)
distribution <- sample.int(100, size=10)
ndistribution <- replicate(n=50, expr=sample.int(25, size=5))

## 4. The Mean as a Balance Point ##

set.seed(1)

checkDist <- function(){
    distribution <- sample.int(1000, size=10)
    mean  <-  sum(distribution) / length(distribution)
    round(sum(distribution - mean)) == 0
}

equal_distances <- sum(replicate(n=5000, expr=checkDist()))

## 5. Defining the Mean Algebraically ##

one  <-  FALSE # we don't use the symbol mu for the sample mean
two  <-  FALSE # Should be N = 8, not n = 8
three  <-  FALSE # x-bar denotes the sample mean, not the population mean

## 6. An Alternative Definition ##

distribution_1  <-  c(42, 24, 32, 11)
distribution_2  <-  c(102, 32, 74, 15, 38, 45, 22)
distribution_3  <-  c(3, 12, 7, 2, 15, 1, 21)
compute_mean <- function(distribution) {
    N <- length(distribution)
    sum_of_the_distribution = 0
    for ( i in 1:N) {
        sum_of_the_distribution <- sum_of_the_distribution + distribution[i]
    }

    sum_of_the_distribution / N
}

mean_1  <-  compute_mean(distribution_1)
mean_2  <-  compute_mean(distribution_2)
mean_3  <-  compute_mean(distribution_3)

## 7. Introducing the Data ##

library(readr)
houses  <-  read_tsv('AmesHousing_1.txt')

one  <-  TRUE # every column that describes years is measured on an interval scale
two  <-  FALSE # `SalePrice` is measured on a ratio scale
three  <-  TRUE # The data set has less values than the initial one with 3970 rows which we don't know either whether it represents a population

## 8. Mean House Prices ##

compute_mean <- function(distribution) {
    N <- length(distribution)
    sum_of_the_distribution = 0
    for ( i in 1:N) {
        sum_of_the_distribution <- sum_of_the_distribution + distribution[i]
    }

    sum_of_the_distribution / N
}
computed_mean  <-  compute_mean(houses$SalePrice)
r_mean  <-  mean(houses$SalePrice)
means_are_equal  <-  (computed_mean == r_mean)

## 9. Challenge: Estimating the Population Mean ##

library(tibble)
library(ggplot2)
library(purrr)

set.seed(4)

parameter  <-  mean(houses$SalePrice)

sample_sizes  <-  seq(5, by=29, length.out=100)

sampling_errors <- map_dbl(sample_sizes,
                           function(x) parameter - mean(sample(houses$SalePrice,
                                                               size=x)) )

df <- tibble(x = sample_sizes, y = sampling_errors)

ggplot(data = df, aes(x = sample_sizes, y = sampling_errors)) +
    geom_point(size=2) +
    geom_hline(yintercept = 0) +
    geom_vline(xintercept = 2930) +
    labs(x = "Sample size",
         y = "Sampling error")

## 10. Estimates from Low-Sized Samples ##

library(tibble)
library(ggplot2)
set.seed(1)
mean_points <- replicate(n = 10000,
                         expr = mean(sample(houses$SalePrice,
                                            size = 100)))

ggplot(data = tibble(mean_points), aes(x = mean_points)) +
    geom_histogram(bins = 100,
                   position = "identity",
                   alpha = 0.5) +
    geom_vline(aes(xintercept = mean(houses$SalePrice))) +
    xlab("Sample mean") +
    ylab("Frequency") +
    xlim(0, 500000)

## 12. The Sample Mean as an Unbiased Estimator ##

population  <-  c(3, 7, 2)
library(purrr)

samples  <-  list(c(3, 7),
                  c(3, 2),
                  c(7, 2),
                  c(7, 3),
                  c(2, 3),
                  c(2, 7))

sample_means <- map_dbl(samples, function(x) mean(x))

population_mean  <-  mean(population)

mean_of_sample_means  <-  mean(sample_means)

unbiased  <-  (population_mean == mean_of_sample_means)

Data Analyst in R/Step 5 - Probability and Statistics/2. Statistics Intermediate in R Averages and Variability/1. The Mean.r


library(ggplot2)

# change these parameters if you want
max = 100
num_samples = 100

# generate 100 samples from 0 to 100
samples <- max * runif(num_samples)

# my power mean function
powermean <- function(samples, d) {
    if (d == 0) {
        exp(sum(log(samples)) / length(samples))
    } else {
        (sum(samples ^ d) / length(samples)) ^ (1 / d)
    }
}

# x axis goes from -10 to 5 skipping 0
d <- c(seq(-10,-0.01,by = 0.01), seq(0.01,10,by = 0.01))

# calculate all the power means
y <- sapply(d, function(d) powermean(samples, d))

myPlot <- ggplot() +
    geom_line(aes(x = d, y = y), color = "#56B4E9") +
    geom_point(size = 5,
               aes(x = -1, y = powermean(samples, -1),color = "#E69F00")) +
    geom_point(size = 5,
               aes(x = -0, y = powermean(samples, 0), color = "#009E73")) +
    geom_point(size = 5,
               aes(x = 1, y = powermean(samples, 1), color = "#F0E442")) +
    geom_point(size = 5,
               aes(x = 2, y = powermean(samples, 2), color = "#0072B2")) +
    scale_color_manual(values = c("#E69F00","#009E73","#F0E442","#0072B2"),
                       breaks = c("#E69F00", "#009E73", "#F0E442", "#0072B2"),
                       labels = c("harmonic",
                                  "geometric",
                                  "arithmetic",
                                  "quadratic")) +
    theme(axis.title.x = element_blank()) +
    theme(axis.title.y = element_blank()) +
    theme(legend.title = element_blank())

# ...profit!
plot(myPlot)


# spočítání pravděpodobnosti P(A) - věta o úplné pravděpodobnosti
uplna_pravdepodobnost = function(P_B, P_AB)
{   # uvažujeme P_B jako vektor hodnot P(B_i) a P_BA jako vektor hodnot P(A|B_i)
    P_A = 0
    for (i in 1:length(P_B))
    {
        P_A = P_A + P_B[i]*P_AB[i]
    }
    return(P_A)
}

# * Bayesova věta ####
# $P(B_k|A)=\frac{P(B_k)P(A|B_k)}{\sum_{i=1}^{n}P(B_i)P(A|B_i)}$

# spočítání podmíněné pravděpodobnosti P(B_k|A) - Bayesova věta
bayes = function(P_B, P_AB, k)
{   # uvažujeme P_B jako vektor hodnot P(B_i), P_BA jako vektor hodnot P(A|B_i)
    P_A = uplna_pravdepodobnost(P_B, P_AB)
    P_BkA = P_B[k]*P_AB[k]/P_A
    return(P_BkA)
}

souhrn=function(x,p){
  EX = sum(x*p)
  EX2 = sum(x*x*p)
  DX = EX2-EX^2
  sigma.X = sqrt(DX)
  # zápis výsledků do tabulky
  tab = rbind(EX, DX, sigma.X)
  tab.popis = c("str. hodnota","rozptyl","smer. odchylka")
  rownames(tab) = tab.popis
  return(tab)
}

# 1A
#       A   B   C
# spok  70  85  55
# nesp  30  15  45
# clk   30  38  32

0.3*0.3+0.15*0.38+0.45*0.32

# 1B
p = c(0.7,0.85,0.55)
c = c(0.3,0.38,0.32)
bayes(c, p, 2)

# 2A
xvalue = c(-2,1,3)
yvalue = c(0,1)
zero = c(1/3,1/6,0)
one = c(1/6,1/6,1/6)
sum(zero,one)

# 2B marginální pravděpodobnostní a distribuční funkce
# x -2  1   3
# p 3/6 2/6 1/6
x = c(zero[1]+one[1],zero[2]+one[2],zero[3]+one[3])
x
y = c(zero[1]+zero[2]+zero[3],one[1]+one[2]+one[3])
y

# 2C
# stř. hodnota =
sum(xvalue*x)
sum(yvalue*y)

# směr. odchylka
sqrt(sum(xvalue*xvalue*x)-sum(xvalue*x)^2)
sqrt(sum(yvalue*yvalue*y)-sum(yvalue*y)^2)

souhrn(xvalue,x)
souhrn(yvalue,y)

# 2D sdružená dist. funkce
# F(0,5;1) = 1/3

# 3A pravděpodobnostní funkce

x = seq(from = -1, to = 150, by = 1) # body na ose x
FX = dexp(x,1/45)
plot(x, FX, type='l', main="Distribucni funkce")

# 3B P(x > 68) = 1-P(x<68)
1-pexp(68,1/45)

# 3C z 30 baterií bude alespoň polovina s výdrží nad 68 měsíců
n = 30
p = 1-pexp(68,1/45)
1-pbinom(15,n,p)

# 3D 40 náhodně vybraných baterií bude průměrna výdrž větší než 43 měsíců

n = 40
sigma = 45
x = n*43
mi = n*sigma
rozptyl = n*sigma**2
1 - pnorm(x,mi,sqrt(rozptyl))


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

rm(list = ls())

la <- 10
lb <- 5
mu1 <- 3 / 60
mu2 <- 4 / 60

(Q <- matrix(c(-(la + lb),                 la,            lb,                0,
                    1/mu1, -(1/mu1 + lb + la),             0,          lb + la,
                    1/mu2,                  0, -(1/mu2 + la),               la,
                        0,              1/mu2,         1/mu1, -(1/mu1 + 1/mu2)),
             4, 4, byrow = TRUE))
# -15	 10  	5	  0
#  20	-35	  0	 15
#  15	  0	-25	 10
#   0	 15	 20	-35

(A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q))))
# -15	 10   5	1
#  20	-35	  0	1
#  15	  0	-25	1
#   0	 15	 20	1

(stationary <- solve(A)[nrow(A), ])
# 0.461538461538462 0.192307692307692 0.205128205128205 0.141025641025641

(la * (1 - (stationary[4])))
# 8.58974358974359

lb * (1 - (stationary[3] + stationary[4]))
# 3.26923076923077


'''
Suppose the food label on a cookie bag states that there is at most 2 grams of saturated fat in a single cookie.
In a sample of 35 cookies, it is found that the mean amount of saturated fat per cookie is 2.1 grams.Assume that
the population standard deviation is 0.25 grams. At .05 significance level, can we reject the
claim on food label?
'''

xbar=2.1
mu0=2
sigma = 0.25

n = 35

z = (xbar-mu0)/(sigma/sqrt(n))
z #2.2366

alpha = 0.05

z.alpha = qnorm(1-alpha)
z.alpha #1.644

#se rechaza la hipotesis

#pvalue
pvalue = pnorm(z,lower.tail = FALSE)

Parcial/1. Prueba de hipotesis/UpperTailMeanKnownVariance.r


# Example : 2   Chapter : 4.2     Page No: 209
# Find the projection matrix onto the line

projection_matrix<-function(a){
  a<-matrix(c(a),ncol=1)
  P<-a%*%t(a)
  temp<-t(a)%*%a
  temp<-1/temp
  t<-temp[1,1]
  P<-t*P
  return(P)
}
a<-c(1,2,2)
P<-projection_matrix(a)
print("The projection matrix is ")
print(P)
#The  answer may slightly vary due to  rounding off values


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])) {
    cat("\rPoint", i, "of", 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)
}

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

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

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

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

result <- kNN(iris, z, 6)

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

1 - Nearest neighbors algorithm/knn-map.r


K = 5;
L = 6;

# 1. I.
n = K*20;
u = runif(n = n, min = 0, max = 1);
x = qexp(u, rate = L);

# 1. II.
hist(x = u, freq = FALSE);
hist(x = x, freq = FALSE);

xWidth = max(x) - min(x);
xGrid = seq(min(x) - 0.2 * xWidth, max(x) + 0.2 * xWidth, length = 30);
lines(xGrid, dexp(xGrid, rate = L), col='red', lw = 2, lty = 2);

# !. III.
plot(ecdf(x), verticals=TRUE, do.points = FALSE, main = "Empiricka distribucni funkce");
lines(xGrid, pexp(xGrid, rate = L), col='red', lw = 2, lty = 2);

# 1. IV.
y = rexp(1000, rate = L)
qqplot(x, y); abline(0,1, col='red', lwd=2);

# 1. V.

# 1. VI.
# H_0 data maji distribuci ~ exp(rate = L)
# H_a data nemaji tuto distribuci
# significance level = 0.05

prob.exp <- dexp(c(1:n), rate = L)
aaa=chisq.test(x, p=prob.exp, rescale.p = TRUE)

ret = ks.test(x, 'pexp', rate = L)$p.value
if(ret <= 0.05) {
  print('H_0 Rejected -> x doesn\'t have the exp distribution.');
} else {
  print("H_0 Can't be rejected, data may be exponential.");
}

return

# 2. I.
lambda = function(t) { 100 + 50/exp((t - 420)^2/(3600*L)) + 100/exp((L*(t - 480 - 30*L)^2)/360000)};

# 2. II.
t = 0;
i = 0;
totalArrivals = K*10;
arrivals = numeric(totalArrivals);
for(i in 1:totalArrivals) {
  t = t + rexp(1, rate = lambda(t));
  arrivals[i] = t;
}
yGrid = numeric(totalArrivals);
plot(arrivals, yGrid, type='p');

# 2. III.
totalTime = 24*60;
arrivals = numeric(totalTime);
while(t < totalTime) {
  t = t + rexp(1, rate = lambda(t));
  minute = t %/% 1;
  arrivals[minute] = arrivals[minute] + 1;
}
arrivals[totalTime] = arrivals[totalTime - 1];

xGrid = c(1:totalTime);
plot(xGrid, arrivals, type='l', col="grey");
curve(lambda, 1, totalTime, col='red', add=TRUE);

# 2. IV.
# Diskuze kvality dat

# 3. I.
ratio_courier = K/(K+L);
ratio_state = 1-ratio_courier;

# 3. II.
arrivals_courier = numeric(totalTime);
arrivals_state = numeric(totalTime);
for (i in (1:totalTime)) {
  arrivals_courier[i] = ratio_courier * arrivals[i];
  arrivals_state[i] = ratio_state * arrivals[i];
}

# 3. III.
lambda_courier = function(t) { lambda(t) * ratio_courier };
lambda_state = function(t) { lambda(t) * ratio_state };

plot(xGrid, arrivals_courier, type='l', col="grey");
curve(lambda_courier, 1, totalTime, col='red', add=TRUE);

plot(xGrid, arrivals_state, type='l', col="grey");
curve(lambda_state, 1, totalTime, col='red', add=TRUE);