#!/usr/bin/env Rscript

### For data analysis, the typical data matrix is organized with
### rows containing the responses of a particular subject and the
### columns representing different variables.

data = matrix(seq(1:24), ncol = 4)
### dim() 返回维度list, S: subject, V: variable
### 行列标题名
rownames(data) = paste("S", seq(1, dim(data)[1]), sep = "")
colnames(data) = paste("V", seq(1, dim(data)[2]), sep = "")

### t()转置
t(data)

v = 1:4

### 结果不是期望的 ( 一列方向(columnwise)轮着加v)
data + v

### 这是我们需要的
t(t(data) + v)

### 偏差分数(deviation scores): 每个数减去列向量的均值(colMeans)
### scale = TRUE(The default for scale is to convert a matrix to standard scores)
scale(x = data, scale = FALSE)
scale(x = data, scale = TRUE)

### 矩阵相加
x = c(1, 2, 3, 4)
###
x + x
### todo: 错误
# x %+% t(x)

### 标量 (内积)
### x %*% x = sum(x * x)
x %*% x
sum(x * x)

### 矩阵 (×乘: 外积)
x %*% t(x)

### 求colMeans, 可以使用one vector
# rownum = dim(data)[1]
one = rep(1, dim(data)[1])
t(one)

# data.mean = colMeans()
data.means = (t(one) %*% data) / dim(data)[1]
colMeans(data)

# 偏差分数(deviation scores): == scale
data.diff = data - one %*% data.means
data.cen = scale(data, scale=FALSE)

### 随机矩阵
set.seed(42)
## 从data里面的数据随机取
data1 = matrix(sample(data), ncol = 4)

### 协方差
data1.means = (t(one) %*% data1) / dim(data1)[1]
data1.diff = data1 - one %*% data1.means
data1.cov = (t(data1.diff) %*% data1.diff) / (dim(data1)[1] - 1)
### 下面两行 ==
round(data1.cov, 2)
round(cov(data1), 2)

diag(data1.cov)

#########
x = matrix(c(1,2,3,4), ncol=2)

### 每个元素对应位置上相乘(纯相乘, 没有加的操作)
###   1  2   1 3      1*1  2*3
###        *     --->
###   3  4   2 4      3*2  4*4
t(x)*x

### 矩阵相乘%*%: 有乘的操作和加的操作
t(x)%*%x
### 交叉乘积（cross product）：crossprod(X，Y)等同于t(X) %*% y，crossprod(X)等价于crossprod(X, X)；
### == t(x)%*%x
crossprod(x)

### 外积: 把矩阵分成多个向量分别计算
x%o%x

###
install.packages("LoopAnalyst")
library("LoopAnalyst")

make.adjoint(x)


############
## Funções auxiliares
# Exemplo 9.1.18 De Groot
Lambda <- function(y, n, theta0, log = FALSE){
  l1 <- y * (log(n*theta0)-log(y))
  if(y==0) l1 <- 0
  l2 <- (n-y)*(log(n*(1-theta0))-log(n-y))
  if(y==n) l2 <- 0
  ans <- l1 + l2
  if(!log) ans <- exp(ans)
  return(ans)
}
Lambda <- Vectorize(Lambda)
#
findSet <- function(tab, level = alpha0){
  K <- nrow(tab)
  set <- NA
  accpr <- 0
  for(i in 1:K){
    accpr.tent <- accpr + tab$Pr[i]
    if(accpr.tent < level){
      accpr <- accpr.tent
      set <- c(set, tab$y[i])
    }else{
      next
    }
  }
  set <- na.omit(set)
  return(
    list(
      confidence_set = as.vector(set),
      test_size = accpr
    )
  )
}

############
sample.size <- 10
p0 <- 0.01
alpha0 <- 1/5

# LRT: razão de verossimilhanças

tabProb <- data.frame(y = 0:sample.size,
                      Lambda = Lambda(y = 0:sample.size,
                                      n = sample.size,
                                      theta0 = p0),
                      Pr = dbinom(x = 0:sample.size,
                                  size = sample.size, prob = p0))
round(tabProb, 3)

plot(0:sample.size, Lambda(y = 0:sample.size,
                 n = sample.size,
                 theta0 = p0), xlab = expression(y),
     ylab = expression(Lambda(y)), type = "b")

ConjuntoRejeicao <- findSet(tab = tabProb)
ConjuntoRejeicao

TabRejeicao <-
tabProb[match(ConjuntoRejeicao$confidence_set, tabProb$y), ]

TabRejeicao[which.max(TabRejeicao$Lambda),]

######

simula_e_testa <- function(N, theta0){
  Y <- rbinom(n = 1, size = N, prob = theta0)
  ttab <- data.frame(y = 0:N,
                     Lambda = Lambda(0:N, n = N, theta0 = theta0),
                     Pr = dbinom(x = 0:N, size = N, prob = theta0))
  test.set <- findSet(tab = ttab)
  the.test <- Y %in% test.set$confidence_set
  return(
    list(
      res = the.test,
      attained.size = test.set$test_size
    )
  )
}

M <- 10000
results <- sizes <- rep(NA, M)
for(i in 1:M){
  temp <- simula_e_testa(N = sample.size,
                         theta0 = p0)
  results[i] <- temp$res
  sizes[i] <- temp$attained.siz
}
mean(results)
mean(sizes)


mle <- function(x) max(x)/2 # W1
unbiased <- function(x) mle(x) * (2*n+2)/(2*n +1) # W2, unbiased
f_M <- function(t) n/theta * (t/theta - 1)^(n-1)
f_M <- Vectorize(f_M)
####
theta <- pi^2/6
n <- 2
M <- 10000
####
data.sets <- matrix(runif(n = n*M, min = theta, max = 2*theta),
                    ncol = n, nrow = M)

W1 <- apply(data.sets, 1, mle)
hist(W1, probability = TRUE)
mean(W1)
(2*n +1)/(2*(n+1)) * theta ## the actual E[W1]
theta
var(W1)
( VarW1 <- theta^2/4 * ((4*n^2 + 8*n + 2)/(n^2 + 3*n + 2) - ((2*n +1)/(n+1))^2) )
( biasW1 <- (1-(2*n +1)/(2*n+2))* theta )
VarW1 + biasW1^2 ## MSE W1

W2 <- apply(data.sets, 1, unbiased)
hist(W2, probability = TRUE)
mean(W2)
theta
var(W2) ## MSE W2
## E[W1] = c* theta => W2 = W1/c => Var(W2) = Var(W1)/c^2
## c = 1-biasW1/theta
(1-biasW1/theta)^-2 *  VarW1

# ### Extra
# eccdf <- function(x)
# {
#   x <- sort(x)
#   n <- length(x)
#   if (n < 1)
#     stop("'x' must have 1 or more non-missing values")
#   vals <- sort(unique(x))
#   rval <- approxfun(vals, 1-cumsum(tabulate(match(x, vals)))/n, #[CHANGED]
#                     method = "constant", yleft = 1, yright = 0, f = 0, ties = "ordered")
#   class(rval) <- c("eccdf", "stepfun", class(rval)) #[CHANGED]
#   attr(rval, "call") <- sys.call()
#   rval
# }
#
# Ff2 <- function(y)  1- (y/theta - 1)^n
#
# Ms <- apply(data.sets, 1, max)
# mean(Ms)
# plot(eccdf(Ms))
# curve(Ff2, theta, 2*theta, lwd = 2, col = 2, lty = 2, add = TRUE)
#
#
# (2*n + 1)/(n + 1) * theta
# n/(n + 1)* theta
#
# var(Ms)


# Example : 1   Chapter : 6.2     Page No: 299
# Diagonilizing a Matrix and Power of matrix computed from power of its diagonal matrix
A<-matrix(c(1,0,5,6),ncol=2)
lambda<-eigen(A)$values
S<-eigen(A)$vectors
S<-round(S)
S1<-solve(S)
Diag_matrix<-round(S1%*%A%*%S)
print("Diagonal Matrix is ")
print(Diag_matrix)
A2<-A%*%A
print("The square of matrix")
print(A2)
print("The Power of matrix can also be computed from its diagonal matrix as follows")
A2_diag<-S%*%Diag_matrix%*%Diag_matrix%*%S1
print("The square of matrix computed from its diagonal matrix")
print(A2_diag)
#The  answer may slightly vary due to  rounding off values
#The answers provided in the text book may vary because of the computation process
#Both answers are correct , here it is taken -Ax+b=0 , In the text book it is considered as Ax-b=0


k <- 31
mu <- 6
std <- 0.22
n <- 1000000
v <- c()

for(i in 1:n){
    rand_draw <- rnorm(k, mean = mu, sd = std)
    bool <- ifelse(rand_draw > 6, 1, 0)
    bool <- sum(bool) >= ceiling(0.52*k)
    v <- c(v, bool)
}
print(sum(v)/n) #part 2

# https://www.reddit.com/r/AskStatistics/comments/cewvps/normal_distribution_help/
# I'm not sure where to begin with this problem; am I able to calculate this by hand, or am I supposed to use R-commander or something? Thanks.

# The weights of cans of Ocean brand tuna are supposed to have a net weight of 6.0 ounces. The manufacturer tells you that the net weight is actually a Normal random variable with a mean of 6 ounces and a standard deviation of 0.22 ounces. Suppose that you draw a random sample of 31 such cans.

# Part i) Using the information about the distribution of the net weight given by the manufacturer, find the probability that the mean weight of the sample is less than 5.98 ounces. (Please carry answers to at least six decimal places in intermediate steps. Give your final answer to the nearest three decimal places).

# Probability (as a proportion) = ?

# Part ii) Using the Normal approximation, which of the following is the probability that more than 52 % of the sampled cans are overweight (i.e., the net weight exceeds 6 ounces)?

# A. 0.4119B. 0.5881C. 0.987D. 0.013E. 0.4557

pnorm(5.98, mean = mu, sd = std) #part 1


# Example : 4.3B   Chapter : 4.3     Page No: 226
# Fit a Parabola
solution<-function(A,b){
  ATA<-t(A)%*%A
  ATb<-t(A)%*%b
  xhat<-solve(ATA,ATb)
  return(xhat)
}
fit_parabola<-function(D){
  num_of_points<-nrow(D)
  t<-c()
  for(i in 1:num_of_points){
    t<-c(t,1)
  }
  t<-c(t,D[,1])
  t<-c(t,D[,1]*D[,1])
  A<-matrix(c(t),ncol=3)
  b<-D[,2]
  b<-matrix(c(b),ncol=1)
  x<-solution(A,b)# The system has no solution, we need to find the best solution
  return(x)
}
t<-c(-2,-1,0,1,2)
b<-c(0,0,1,0,0)
Data<-matrix(c(t,b),ncol=2)
x<-fit_parabola(Data)
C<-x[1]
D<-x[2]
E<-x[3]
print(paste("The best Parabola that fitt in is b= ",C,"+",D,"t+",E,"t2"))
#The  answer may slightly vary due to  rounding off values.


is_in <- function(x, l, u){
  below <- x >= l
  above <- x <= u
  result <- as.logical(below * above)
  return(result)
}

get_ci <- function(x, gamma = 0.95){
  n <- length(x)
  cc <- qt(p = (1+gamma)/2, df = n-1)
  x_bar <- mean(x)
  sigma_prime <- sqrt(var(x))
  Z <- cc*sigma_prime/sqrt(n)
  A <- x_bar - Z
  B <- x_bar + Z
  return(
    data.frame(xbar = x_bar, lwr = A, upr = B)
  )
}

get_ci_fixedVar <- function(x, v, gamma = 0.95){
  n <- length(x)
  zz <- qnorm(p = (1+gamma)/2)
  x_bar <- mean(x)
  Z <- zz*sqrt(v/n)
  A <- x_bar - Z
  B <- x_bar + Z
  return(
    data.frame(xbar = x_bar, lwr = A, upr = B)
  )
}
#####
mu <- 42
sigma_sq <- 30^2
n <-  5# 919
M <- 5000

amostras <- matrix(rnorm(n*M, mean = mu,
                         sd = sqrt(sigma_sq)),
                   ncol = n, nrow = M)

hist(amostras[1, ])
get_ci(amostras[1, ])

intervalos <- data.frame(mean = rep(NA, M),
                         L = rep(NA, M),
                         U = rep(NA, M),
                         contem = rep(NA, M))

for( i in 1:M){
  intervalos[i, 1:3] <- get_ci(amostras[i, ])
  intervalos$contem[i] <- is_in(x = mu,
                             l = intervalos[i, 2],
                             u = intervalos[i, 3])
}
intervalos <- data.frame(amostra = 1:M, intervalos)

tail(intervalos)

mean(intervalos$contem)

######## Variancia conhecida

intervalos.vc <- data.frame(mean = rep(NA, M),
                         L = rep(NA, M),
                         U = rep(NA, M),
                         contem = rep(NA, M))

for( i in 1:M){
  intervalos.vc[i, 1:3] <- get_ci_fixedVar(amostras[i, ], v = sigma_sq)
  intervalos.vc$contem[i] <- is_in(x = mu,
                                l = intervalos.vc[i, 2],
                                u = intervalos.vc[i, 3])
}
intervalos.vc <- data.frame(amostra = 1:M, intervalos.vc)

tail(intervalos.vc)
mean(intervalos.vc$contem)

##### Plots
library(ggplot2)

p1 <- ggplot() +
  geom_pointrange(data = intervalos,
                  mapping = aes(x = amostra, y = mean,
                                ymin = L, ymax = U, colour = contem)) +
  geom_hline(yintercept = mu, linetype = "longdash") +
  ggtitle("Variância desconhecida") +
  theme_bw(base_size = 20)

p2 <- ggplot() +
  geom_pointrange(data = intervalos.vc,
                  mapping = aes(x = amostra, y = mean,
                                ymin = L, ymax = U, colour = contem)) +
  geom_hline(yintercept = mu, linetype = "longdash") +
  ggtitle("Variância conhecida") +
  theme_bw(base_size = 20)

p1
p2
# gridExtra::grid.arrange(p1, p2, ncol=2)

larguras.desc <- intervalos$U-intervalos$L
larguras.vc <- intervalos.vc$U-intervalos.vc$L

hist(larguras.desc, probability = TRUE)
abline(v = larguras.vc[1], lwd = 3, lty = 2)

mean(larguras.desc)
larguras.vc[1]


# Example : 4.2A   Chapter : 4.2     Page No: 213
# Projection onto the line and onto the plane

projection_line<-function(a,b){
  p<-((sum(a*b))/(sum(a*a)))*a
  e<-b-p
  print("The projection vector is ")
  print(p)
  print("The error vector is ")
  print(e)
}

projection_plane<-function(A,b){
  b<-matrix(c(b),ncol=1)
  ATA<-t(A)%*%A
  ATA1<-solve(ATA)
  P<-A%*%ATA1
  P<-P%*%t(A)
  p<-P%*%b
  e<-b-p
  print("The projection vector is ")
  print(p)
  print("The error vector is ")
  print(e)
}

b<-c(3,4,4)
a<-c(2,2,1)
projection_line(a,b)
A<-matrix(c(a,1,0,0),ncol=2)
projection_plane(A,b)
#The  answer may slightly vary due to  rounding off values


# Idea behind the KS test for this problem:
# The KS test is a hypothesis test used to determine if a sample of
# data came from a specific probability distribution,
# though theoretically this test only works for continuous distributions.
# The test works by comparing the CDF for a
# given reference distribution to the empirical CDF for the sample of data.
# In this setting, under the null hypothesis of misses occurring at random,
# the notes (locations) of the misses can be
# modeled with a discrete uniform distribution.

ks=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

  misses = which(song==1) # determines the locations/indices of misses and stores those in the vector "misses"
                          # which(song==1) returns a vector indicating which on which notes (indices) a miss occurs

  n_misses = length(misses) # number of misses in a song (basically the sample size for the sample being tested)

 # empirical cdf is really just number of misses at or before the current miss on note i divided by the total number of misses

 e_cdf = 1:n_misses/n_misses # a vector holding the empirical cdf evaluated at each miss (each index in misses)
   # Note that for the first miss (entry in misses) the e_cdf is 1/n_misses, it is 2/n_misses for the second,..., n_misses/n_misses=1 for the last

 # the reference cdf for a discrete uniform is F(x) = x/(# of possible values); here that will be the length of the song

 n = length(song)

 r_cdf = misses/n  # a vector that stores the reference cdf evaluated at the location of each miss

 # to calculate the KS test statistic subtract the empirical and reference cdfs for each note (and take the absolute value of that difference)
 # the test stat is the largest one of these absolute differences
 ks_ts = max(abs(e_cdf-r_cdf))

 return(ks_ts)  # return the KS test statistic

}

# Hypothesis test based on the KS test method
ks_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 = ks(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] = ks(song_tmp)
	}

	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)
ks(songA)
ks_test(songA,5000)

songB = c(0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,0,0)
ks(songB)
ks_test(songB,5000)


N <- 30
true_beta <- c(10, -3, 0, 8, 0, 0, 0, 0, 0)

x <- runif(N, -2, 2)
X <- cbind(rep(1, N), x, x^2, x^3, x^4, x^5, x^6, x^7, x^8)
matplot(X, t='l')

sigma <- 10
eps <- rnorm(N, mean = 0, sd = sigma)
y <- X %*% true_beta + eps
plot(y,t='l')

model <- lm(y~., data=data.frame(X[,2:ncol(X)]))
beta_hat <- model$coefficients

plot( beta_hat, t='o', col=2, pch='x')
lines(true_beta, t='o', col=1)

# Prior precision
dimension <- length(true_beta)
lambda <- 0.1*diag(0.1, dimension, dimension)

# Posterior covariance
posterior_sigma <- sigma^2 * solve(t(X) %*% X + sigma^2 * lambda)
posterior_beta  <- sigma^(-2) * as.vector(posterior_sigma %*% (t(X) %*% y))

t <- seq(-2,2,0.01)
T <- cbind(rep(1, N), t, t^2, t^3, t^4, t^5, t^6, t^7, t^8)
plot(x,y, xlim=c(-2,2), ylim=range(y, T%*%true_beta))
lines(t,T%*%true_beta, col='black', lwd=3)
lines(t,T%*%beta_hat,  col='blue',  lwd=3)
lines(t,T%*%posterior_beta, col='red', lwd=3)
legend('topleft', c('True function', 'OLS estimate', 'Bayesian estimate'), col=c('black','blue','red'), lwd=3)

pred_sigma <- sqrt(sigma^2 + apply((T%*%posterior_sigma)*T, MARGIN=1, FUN=sum))
upper_bound <- T%*%posterior_beta + qnorm(0.95)*pred_sigma
lower_bound <- T%*%posterior_beta - qnorm(0.95)*pred_sigma

plot(c(0,0),xlim=c(-2,2), ylim=range(y,lower_bound,upper_bound),col='white')
polygon( c(t,rev(t)), c(upper_bound,rev(lower_bound)), col='grey', border=NA)
points(x,y)
lines(t,T%*%true_beta, col='black', lwd=3)
lines(t,T%*%beta_hat,  col='blue',  lwd=3)
lines(t,T%*%posterior_beta, col='red', lwd=3)
legend('topleft', c('True function', 'OLS estimate', 'Bayesian estimate'), col=c('black','blue','red'), lwd=3)


# Suppose we are giving two students a multiple-choice exam with 40 questions,
# where each question has four choices. We don't know how much the students
# have studied for this exam, but we think that they will do better than just
# guessing randomly.
# 1) What are the parameters of interest?
# 2) What is our likelihood?
# 3) What prior should we use?
# 4) What is the prior probability P(theta>.25)? P(theta>.5)? P(theta>.8)?
# 5) Suppose the first student gets 33 questions right. What is the posterior
#    distribution for theta1? P(theta1>.25)? P(theta1>.5)? P(theta1>.8)?
#    What is a 95% posterior credible interval for theta1?
# 6) Suppose the second student gets 24 questions right. What is the posterior
#    distribution for theta2? P(theta2>.25)? P(theta2>.5)? P(theta2>.8)?
#    What is a 95% posterior credible interval for theta2?
# 7) What is the posterior probability that theta1>theta2, i.e., that the
#    first student has a better chance of getting a question right than
#    the second student?

############
# Solutions:

# 1) Parameters of interest are theta1=true probability the first student
#    will answer a question correctly, and theta2=true probability the second
#    student will answer a question correctly.

# 2) Likelihood is Binomial(40, theta), if we assume that each question is
#    independent and that the probability a student gets each question right
#    is the same for all questions for that student.

# 3) The conjugate prior is a beta prior. Plot the density with dbeta.
theta=seq(from=0,to=1,by=.01)
plot(theta,dbeta(theta,1,1),type="l")
plot(theta,dbeta(theta,4,2),type="l")
plot(theta,dbeta(theta,8,4),type="l")

# 4) Find probabilities using the pbeta function.
1-pbeta(.25,8,4)
1-pbeta(.5,8,4)
1-pbeta(.8,8,4)

# 5) Posterior is Beta(8+33,4+40-33) = Beta(41,11)
41/(41+11)  # posterior mean
33/40       # MLE

lines(theta,dbeta(theta,41,11))

# plot posterior first to get the right scale on the y-axis
plot(theta,dbeta(theta,41,11),type="l")
lines(theta,dbeta(theta,8,4),lty=2)
# plot likelihood
lines(theta,dbinom(33,size=40,p=theta),lty=3)
# plot scaled likelihood
lines(theta,44*dbinom(33,size=40,p=theta),lty=3)

# posterior probabilities
1-pbeta(.25,41,11)
1-pbeta(.5,41,11)
1-pbeta(.8,41,11)

# equal-tailed 95% credible interval
qbeta(.025,41,11)
qbeta(.975,41,11)

# 6) Posterior is Beta(8+24,4+40-24) = Beta(32,20)
32/(32+20)  # posterior mean
24/40       # MLE

plot(theta,dbeta(theta,32,20),type="l")
lines(theta,dbeta(theta,8,4),lty=2)
lines(theta,44*dbinom(24,size=40,p=theta),lty=3)

1-pbeta(.25,32,20)
1-pbeta(.5,32,20)
1-pbeta(.8,32,20)

qbeta(.025,32,20)
qbeta(.975,32,20)

# 7) Estimate by simulation: draw 1,000 samples from each and see how often
#    we observe theta1>theta2

theta1=rbeta(1000,41,11)
theta2=rbeta(1000,32,20)
mean(theta1>theta2)

# Note for other distributions:
# dgamma,pgamma,qgamma,rgamma
# dnorm,pnorm,qnorm,rnorm


1.Test Scores
  i) Use the appropriate R functions to answer the following questions:

	 1)What are the observational units in this study?

        df_score <- read.csv("scores.csv", header = TRUE, sep = ",")

		df_score %>% select(Score)

	 2)Identify the variables mentioned in the narrative paragraph and determine which are categorical and quantitative?

	 	"Section" column is the Categorial varibal ein the score.csv file

		> df_score %>% select(Section)

		"Score" and "Count" column is the quantitative .

		> df_score %>% select(Score, Count)

	 3) Create one variable to hold a subset of your data set that contains only the Regular Section and one variable for the Sports Section.

     	> library(dplyr)
        > Regular_data <- filter(df_score,Section=="Regular")
        > Regular_data

		> Sports_data <- filter(df_score,Section=="Sports")
		> Sports_data

	4) Use the Plot function to plot each Sections scores and the number of students achieving that score. Use additional
	   Plot Arguments to label the graph and give each axis an appropriate label. Once you have produced your Plots answer
	   the following questions:

		   > plot(Sports_data$Score, Sports_data$Count, type = "p", xlab = 'Score', ylab ="No of students")
           > plot(Regular_data$Score, Regular_data$Count, type = "p", xlab = 'Score', ylab ="No of students")

		    a)Comparing and contrasting the point distributions between the two section, looking at both tendency and consistency:
			  Can you say that one section tended to score more points than the other? Justify and explain your answer.

		      Yes, In the regular section most of the Students scored more than 290 and only 20 students are below 280 where as "Sports"
			  students scores started at 200 and 70 students scores are below or equal to 250 , so obviously Regular section students are
			  tend to Score more points

			b) Did every student in one section score more points than every student in the other section? If not,
  			   explain what a statistical tendency means in this context.

		       No,

 			   In statistics, the central tendency is the descriptive summary of a data set. Through the single value from the dataset,
			   it reflects the centre of the data distribution. Moreover, it does not provide information regarding individual data from the
			   dataset,where it gives a summary of the dataset. Generally, the central tendency of a dataset can be defined using Mean, Median
			   and Mode measures in statistics.

               Following is the Mean values of data set given

			   > mean(Sports_data$Score)
                 [1] 307.3684
               > mean(Regular_data$Score)
                 [1] 327.6316

			   Following is the Medina values of given data set

			   > median(Regular_data$Score)
                 [1] 325
               > median(Sports_data$Score)
                 [1] 315

			   Follwoing is the Mode of the data set

                 > v <- c(Sports_data$Score)
                 > v1 <- c(Regular_data$Score)

                 > getmode <- function(v) {
                   +    uniqv <- unique(v)
                   +    uniqv[which.max(tabulate(match(v, uniqv)))]
                   + }

                 > getmode(v)
                   [1] 200
                 > getmode(v1)
				   [1] 305

				c. What could be one additional variable that was not mentioned in the narrative that could be
 				   influencing the point distributions between the two sections?

				   Gender varibale is missing , which can influence the distribution.

2) We interact with a few datasets in this course, one you are already familiar with, the 2014 American Community Survey and the
   second is a Housing dataset, that provides real estate transactions recorded from 1964 to 2016.  For this exercise, you need
   to start practicing some data transformation steps – which will carry into next week, as you learn some additional methods.
   For this week, using either dataset (or one of your own – although I will let you know ahead of time that the Housing dataset
   is used for a later assignment, so not a bad idea for you to get more comfortable with now!), perform the following data
   transformations:

    a) Use the apply function on a variable in your dataset

	  took Housing data set for R functions

		> library("readxl")
		>
		> housing_data <- read_excel("week-7-housing.xlsx")

		> apply(X=housing_data[c(2)], MARGIN=2 , FUN=sum, n.rm = TRUE)
		  Sale Price
		  8500391150
    b) Use the aggregate function on a variable in your dataset

        > aggregate(housing_data$"Sale Price", list(housing_data$"Sale Date"), FUN=sum)

	c) Use the plyr function on a variable in your dataset – more specifically, I want to see you split some data, perform a modification to the data, and then bring it back together

	   > hs_500 <- slice(housing_data, 1:500)
       > hs_500

       > hs_500[1,2] <- 1000
	   > hs_500

       > hs_rest <- slice(housing_data, 501:12865)
	   > bind_rows(hs_200603, hs_rest)

	 d) Check distributions of the data

	   > plot(housing_data$`Sale Date`,housing_data$`Sale Price`,type = "l", xlab = 'Sale Date', ylab ="Amount")

     e) Identify if there are any outliers

        using summary we can find the ouliners

        summary(housing_data)
     f)  add at least two columns
	    > housing_data <- cbind(housing_data,"City")
	    > housing_data <- cbind(housing_data,"ZIP")
        > summary(housing_data)


#
# University: Universidad de Valladolid
# Degree: Grado en Estadística
# Subject: Análisis de Datos
# Year: 2017/18
# Teacher: Miguel Alejandro Fernández Temprano
# Author: Sergio García Prado (garciparedes.me)
# Name: Análisis de Correspondencias - Práctica 01
#
#

rm(list = ls())

library(ggplot2)
library(ca)

# 1.	Construir la matriz

N <- t(matrix(
  c(20,20,20,
    40,10,40,
    20,10,40),
  ncol=3
))
print(N)

# 2.	Construir las matrices F, Dr, Dc y las matrices de puntos fila y columna.

F <- N / sum(N)
print(F)

Dr <- diag(rowSums(N) / sum(N))
Dc <- diag(colSums(N) / sum(N))
print(Dr)
print(Dc)

Pr <- solve(Dr) %*% F
Pc <- solve(Dc) %*% t(F)
print(Pr)
print(Pc)

# 3. Calcular las distancias chi cuadrado entre los tres puntos fila

d_chi_square <- function(x, y) (t(x - y) %*% solve(Dc) %*% (x - y))[1,1]
D <- c(
  d_chi_square(Pr[1,],Pr[2,]),
  d_chi_square(Pr[1,],Pr[3,]),
  d_chi_square(Pr[2,],Pr[3,])
)
print(D)

# 4. Calcular el valor del estadístico chi cuadrado

chi_value <- sum(
  (N - (rowSums(N) %*% t(colSums(N))) / sum(N)) ^ 2 /
  ((rowSums(N) %*% t(colSums(N))) / sum(N))
)
print(chi_value)

pval <- pchisq(chi_value, df=4, lower.tail=FALSE)
print(pval)

# 5. Calcular la inercia total como la suma ponderada de las distancias chi
# cuadrado al centro de gravedad de los puntos fila y comprobar que es el
# estadístico chi cuadrado dividido por n

Gc <- colSums(N) / sum(N)
Gr <- rowSums(N) / sum(N)
print(Gc)
print(Gr)

diag(t(t(Pr) - Gc) %*% solve(Dc) %*% t(t(t(Pr)-Gc))) %*% Gr
G <- (diag(t(t(Pr) - Gc) %*% solve(Dc) %*% t(t(t(Pr)-Gc))) %*% Gr)[1,1]
print(G)

# 6. Construir la matriz a diagonalizar, diagonalizarla calculando los
# autovalores y autovectores unitarios

X <- t(F) %*% solve(Dr) %*% F %*% solve(Dc)
print(X)
X_eigenvec_1 <- eigen(X)$vectors
X_eigenval <- eigen(X)$values

print(X_eigenval)
norm <- diag(t(X_eigenvec_1) %*% solve(Dc) %*% X_eigenvec_1)
X_eigenvec <- t(t(X_eigenvec_1)/sqrt(norm))
print(X_eigenvec)

# 7. Calcular los factores y las proyecciones de los puntos fila sobre los ejes

fact <- solve(Dc) %*% X_eigenvec
print(fact)

Proyec_r <- Pr %*% fact
print(Proyec_r)

# 8. Calcular las distancias euclídeas entre las proyecciones y compararlas con
# las del punto 3

d_euclidean <- function(x, y) sum( (x / rowSums(F) - y / rowSums(F))^2)
print(d_euclidean(Pr[2,], Pr[3,]))
print(d_chi_square(Pr[2,], Pr[3,]))

# 9. Calcular los factores y las proyecciones de los puntos columna sobre los
# ejes

Proyec_c = t(sqrt(X_eigenval) * t(fact))

# 10. Efectuar una representación conjunta de las proyecciones de filas y
# columnas

Proyec_r_df <- as.data.frame(Proyec_r[,2:3])
Proyec_c_df <- as.data.frame(Proyec_c[,2:3])
rownames(Proyec_r_df)<-c("J","ME","M")
rownames(Proyec_c_df)<-c("A","B","C")
Proyec_df<-rbind(Proyec_r_df,Proyec_c_df)

ggplot(data = Proyec_df, aes(x = V1, y = V2, label=rownames(Proyec_df))) +
  geom_text(colour = "red", size = 6)

#
# Comprobación de resultados con libreria CA
#

N_f <- as.data.frame.matrix(N)
colnames(N_f) <- c("c1", "c2", "c3")
rownames(N_f) <- c("r1", "r2", "r3")

fit <- ca(N_f)
summary(fit)
plot(fit)


#' Generates data from `K` multivariate normal data populations, where each
#' population (class) has a covariance matrix consisting of block-diagonal
#' autocorrelation matrices.
#'
#' This function generates `K` multivariate normal data sets, where each
#' class is generated with a constant mean vector and a covariance matrix
#' consisting of block-diagonal autocorrelation matrices. The data are returned
#' as a single matrix `x` along with a vector of class labels `y` that
#' indicates class membership.
#'
#' For simplicity, we assume that a class mean vector is constant for each
#' feature. That is, we assume that the mean vector of the \eqn{k}th class is
#' \eqn{c_k * j_p}, where \eqn{j_p} is a \eqn{p \times 1} vector of ones and
#' \eqn{c_k} is a real scalar.
#'
#' The \eqn{k}th class covariance matrix is defined as
#' \deqn{\Sigma_k = \Sigma^{(\rho)} \oplus \Sigma^{(-\rho)} \oplus \ldots
#' \oplus \Sigma^{(\rho)},} where \eqn{\oplus} denotes the direct sum and the
#' \eqn{(i,j)}th entry of \eqn{\Sigma^{(\rho)}} is
#' \deqn{\Sigma_{ij}^{(\rho)} = \{ \rho^{|i - j|} \}.}
#'
#' The matrix \eqn{\Sigma^{(\rho)}} is referred to as a block. Its dimensions
#' are provided in the `block_size` argument, and the number of blocks are
#' specified in the `num_blocks` argument.
#'
#' Each matrix \eqn{\Sigma_k} is generated by the
#' [cov_block_autocorrelation()] function.
#'
#' The number of classes `K` is determined with lazy evaluation as the
#' length of `n`.
#'
#' The number of features `p` is computed as \code{block_size * num_blocks}.
#'
#' @importFrom mvtnorm rmvnorm
#' @export
#' @param n vector of the sample sizes of each class. The length of `n`
#' determines the number of classes `K`.
#' @param mu matrix containing the mean vectors for each class. Expected to have
#' `p` rows and `K` columns.
#' @param num_blocks the number of block matrices. See details.
#' @param block_size the dimensions of the square block matrix. See details.
#' @param rho vector of the values of the autocorrelation parameter for each
#' class covariance matrix. Must equal the length of `n` (i.e., equal to
#' `K`).
#' @param sigma2 vector of the variance coefficients for each class covariance
#' matrix. Must equal the length of `n` (i.e., equal to `K`).
#' @return named list with elements:
#' \itemize{
#'   \item `x`: matrix of observations with `n` rows and `p`
#' columns
#'   \item `y`: vector of class labels that indicates class membership for
#' each observation (row) in `x`.
#' }
#' @examples
#' # Generates data from K = 3 classes.
#' means <- matrix(rep(1:3, each=9), ncol=3)
#' data <- generate_blockdiag(n = c(15, 15, 15), block_size = 3, num_blocks = 3,
#' rho = seq(.1, .9, length = 3), mu = means)
#' data$x
#' data$y
#'
#' # Generates data from K = 4 classes. Notice that we use specify a variance.
#' means <- matrix(rep(1:4, each=9), ncol=4)
#' data <- generate_blockdiag(n = c(15, 15, 15, 20), block_size = 3, num_blocks = 3,
#' rho = seq(.1, .9, length = 4), mu = means)
#' data$x
#' data$y
generate_blockdiag <- function(n, mu, num_blocks, block_size, rho,
                               sigma2 = rep(1, K)) {
  n <- as.integer(n)
  block_size <- as.integer(block_size)
  num_blocks <- as.integer(num_blocks)
  p <- block_size * num_blocks
  rho <- as.numeric(rho)
  mu <- as.matrix(mu)

  K <- length(n)

  if (length(rho) != K) {
    rlang::abort("The length of 'rho' must equal the length of 'n'.")
  } else if(nrow(mu) != p) {
    rlang::abort("The matrix 'mu' must have 'p' rows.")
  } else if(ncol(mu) != K) {
    rlang::abort("The matrix 'mu' must have 'K' columns.")
  }

  x <- lapply(seq_len(K), function(k) {
    if (n[k] > 0) {
      rmvnorm(n = n[k], mean = mu[, k],
              sigma = cov_block_autocorrelation(num_blocks = num_blocks,
              block_size = block_size, rho = rho[k], sigma2 = sigma2[k]))
    }
  })
  x <- do.call(rbind, x)
  y <- factor(rep(seq_along(n), n))

  list(x = x, y = y)
}

#' Generates a \eqn{p \times p} block-diagonal covariance matrix with
#' autocorrelated blocks.
#'
#' This function generates a \eqn{p \times p} covariance matrix with
#' autocorrelated blocks. The autocorrelation parameter is `rho`.
#' There are `num_blocks` blocks each with size, `block_size`.
#' The variance, `sigma2`, is constant for each feature and defaulted to 1.
#'
#' The autocorrelated covariance matrix is defined as:
#' \deqn{\Sigma = \Sigma^{(\rho)} \oplus \Sigma^{(-\rho)} \oplus \ldots \oplus
#' \Sigma^{(\rho)},} where \eqn{\oplus} denotes the direct sum and the
#' \eqn{(i,j)}th entry of \eqn{\Sigma^{(\rho)}} is \deqn{\Sigma_{ij}^{(\rho)} =
#' \{ \rho^{|i - j|} \}.}
#'
#' The matrix \eqn{\Sigma^{(\rho)}} is the autocorrelated block discussed above.
#'
#' The value of `rho` must be such that \eqn{|\rho| < 1} to ensure that
#' the covariance matrix is positive definite.
#'
#' The size of the resulting matrix is \eqn{p \times p}, where
#' `p = num_blocks * block_size`.
#'
#' @export
#' @importFrom bdsmatrix bdsmatrix
#' @param num_blocks the number of blocks in the covariance matrix
#' @param block_size the size of each square block within the covariance matrix
#' @param rho the autocorrelation parameter. Must be less than 1 in absolute
#' value.
#' @param sigma2 the variance of each feature
#' @return autocorrelated covariance matrix
cov_block_autocorrelation <- function(num_blocks, block_size, rho, sigma2 = 1) {
  cov_block <- cov_autocorrelation(p = block_size, rho = rho, sigma2 = sigma2)
  cov_block <- as.vector(cov_block)
  as.matrix(bdsmatrix(blocksize = rep(block_size, num_blocks),
                      blocks = replicate(num_blocks, cov_block)))
}

#' Generates a \eqn{p \times p} autocorrelated covariance matrix
#'
#' This function generates a \eqn{p \times p} autocorrelated covariance matrix
#' with autocorrelation parameter `rho`. The variance `sigma2` is
#' constant for each feature and defaulted to 1.
#'
#' The autocorrelated covariance matrix is defined as:
#' The \eqn{(i,j)}th entry of the autocorrelated covariance matrix is defined as:
#' \eqn{\rho^{|i - j|}}.
#'
#' The value of `rho` must be such that \eqn{|\rho| < 1} to ensure that
#' the covariance matrix is positive definite.
#'
#' @export
#' @param p the size of the covariance matrix
#' @param rho the autocorrelation parameter. Must be less than 1 in absolute
#' value.
#' @param sigma2 the variance of each feature
#' @return autocorrelated covariance matrix
cov_autocorrelation <- function(p, rho, sigma2 = 1) {
  p <- as.integer(p)
  rho <- as.numeric(rho)
  sigma2 <- as.numeric(sigma2)

  if (abs(rho) >= 1) {
    rlang::abort("The value of 'rho' must be between (1 - p)^(-1) and 1, exclusively.")
  }
  if (sigma2 <= 0) {
    rlang::abort("The value of 'sigma2' must be positive.")
  }
  x <- diag(p)
  sigma2 * rho^abs(row(x) - col(x))
}


library(quantmod)
library(m537)
library(m537tools)
library(MCMCpack)
library(bayesm)

library(parallel);
library(future.apply);

prmdf = getfinwdat()
ns = dim(prmdf)[1]
s = 10;
n = (ns - s);
prmdfn = prmdf[1:n,,drop = F]; # this is used for estimation
prmdff = prmdf[(n+1):ns,,drop = F]
dim(prmdff)

thetamcapm = MCMCregressg(prmibm~prmsp500-1,
                    data = prmdfn);
summarymcmc(thetamcapm,header = T)

sigm = m537::sigma(thetamcapm);
summarymcmc(sigm);

set.seed(1);
n = 500;
Sigma = matrix(.7,nr = 5,nc = 5);
diag(Sigma) = rep(1,5);
L = t(chol(Sigma))
X = L%*%matrix(rnorm(2500),nr = 5,nc = n);
X = t(X);
colnames(X) = paste("x",1:5,sep = "")
beta = c(.5,.6,0,0,0);
y = as.matrix(1 + X %*% beta + rnorm(n));
colnames(y) = "y"
simdatdf = cbind(y,X)
simdatdf = as.data.frame(simdatdf)

modelfrmls = makemodelformulas(yname = "y",
                               xnames = colnames(X))

outls = future_mapply("MCMCregressg",
                      modelfrm = modelfrmls,
                      MoreArgs = list(data = simdatdf),
                      SIMPLIFY = FALSE)
logmarg = logmarglik(outls);
maxmod = which.max(logmarg)
cat("model with the largest marg lik","\n")
modelfrmls[[maxmod]]

ff3frm = prmibm~prmsp500+hml+smb-1;
thetamfft = MCMCregresst(modelfrm = ff3frm,
                    data = prmdfn,
                    nu = 2.1);
summarymcmc(thetamfft)

nug = seq(from = 2.1,
          to = 3.0,
          by = .10)
nug = as.matrix(nug);

outls = future_mapply("MCMCregresst",
                      nu = nug,
                      MoreArgs = list(
                        modelfrm = ff3frm,
                        data = prmdfn),
                      SIMPLIFY = FALSE
)

A = cbind(nug,t(logmarglik(outls)))
colnames(A) = c("nu","logmarg")
print(A)

## Changing multiple arguments

## Prediction
## Sampling the future

fftpredict = predictregresst(thetamfft,
                               prmdff)

## Code for sampling the future

Xf = model.matrix(ff3frm,data = prmdff)
k = dim(Xf)[2]
betam = as.matrix(thetamfft[,1:k])
s2m = thetamfft[,(k+1)]
s = dim(Xf)[1]
m = dim(betam)[1];
nu = attr(thetamfft,"nu");
yfm = matrix(0,nr = m,nc = s)
for (g in 1:m) {
    betag = t(betam[g,,drop = F]);
    s2g = s2m[g];
    tau2g = (nu-2)*s2g/nu;
    prmf = Xf %*% betag + sqrt(tau2g)*rt(s,nu);
    yfm[g,] = prmf;
}

## Predictive likelihood

nt = attr(thetamfft,"trainsize")
thetamfftns = MCMCregresst(ff3frm,data = prmdf,   # ns for n+s
                     trainsize = nt,
                     nu = 2.4)

thetamfft = MCMCregresst(ff3frm,data = prmdfn,  # data up to n
                    nu = 2.4)

diff = logmarglik(thetamfftns) - logmarglik(thetamfft)
diff = as.numeric(diff)
diff

## Change-point regression

library(MCMCpack);

priorff3ls = trainpriorregg(ff3frm,prmdfn);
B0p = solve(priorff3ls$B0_);
B0p = (B0p + t(B0p))/2;

outchange1 = MCMCregressChange(ff3frm,data = prmdfn[(nt+1):n,],
                               m = 1,
                               b0 = priorff3ls$beta0_,
                               B0 = B0p,
                               sigma.mu = priorff3ls$s20_,
                               sigma.var = priorff3ls$s2v_,
                               marginal.likelihood = "Chib95")

probstates1 = as.data.frame(attr(outchange1,"prob.state"))
rnames = rownames(prmdfn)

dts = as.Date(rnames[(nt+1):n])
colnames(probstates1) = c("ps1","ps2")

ggtsplot(probstates1,dts,y = c("ps1","ps2"));

Markov Chain Monte Carlo method applications/regression_review.r


delta_donald <- function(x){
  x[1]
}
#
delta_huguinho <- function(x){
  kH <- (n+3)/(2*n + 2)
  (1/kH)*min(x)
}
#
delta_zezinho <- function(x){
  kZ <- (3*n+1)/(2*n + 2)
  (1/kZ) * max(x)
}
#
delta_luisinho <- function(x){
  (min(x) + max(x))/2
}
#
computa_vies_qdd <- function(deltas, theta){
  (mean(deltas) - theta)^2
}
computa_eqm <- function(deltas, theta){
  mean((deltas-theta)^2)
}
#
theta.vdd <- 10
n <- 30
M <- 1e5
amostras <- matrix(NA, ncol = n, nrow = M)
for (j in 1:M){
  amostras[j, ] <- runif(n = n, min = theta.vdd/2, max = (3/2)*theta.vdd)
}

Ds <- apply(amostras, 1, delta_donald)
Hs <- apply(amostras, 1, delta_huguinho)
Zs <- apply(amostras, 1, delta_zezinho)
Ls <- apply(amostras, 1, delta_luisinho)

par(mfrow = c(2, 2))
hist(Ds, probability = TRUE, main = "Pato Donald",
     xlab = expression(delta[D]))
abline(v = theta.vdd, lwd = 3, lty = 2)
hist(Hs, probability = TRUE, main = "Huguinho",
     xlab = expression(delta[UH]))
abline(v = theta.vdd, lwd = 3, lty = 2)
hist(Zs, probability = TRUE, main = "Zezinho",
     xlab = expression(delta[UZ]))
abline(v = theta.vdd, lwd = 3, lty = 2)
hist(Ls, probability = TRUE, main = "Luisinho",
     xlab = expression(delta[L]))
abline(v = theta.vdd, lwd = 3, lty = 2)

###
#### Variância
# Donald
var(Ds)
theta.vdd^2/12
# Huguinho
var(Hs)
(4*n)/((n+3)^2*(n+2)) * theta.vdd^2
# Zezinho
var(Zs)
(4*n)/((3*n+1)^2*(n+2)) * theta.vdd^2
# Luisinho
var(Ls)
1/(2*(n+1)*(n+2)) * theta.vdd^2

#### Viés
# Donald
computa_vies_qdd(Ds, theta.vdd)
# Huguinho
computa_vies_qdd(Hs, theta.vdd)
# Zezinho
computa_vies_qdd(Zs, theta.vdd)
# Luisinho
computa_vies_qdd(Ls, theta.vdd)

#### EQM
# Donald
computa_eqm(Ds, theta.vdd)
theta.vdd^2/3
# Huguinho
computa_eqm(Hs, theta.vdd)
(4*n)/((n+3)^2*(n+2)) * theta.vdd^2
# Zezinho
computa_eqm(Zs, theta.vdd)
(4*n)/((3*n+1)^2*(n+2)) * theta.vdd^2
# Luisinho
computa_eqm(Ls, theta.vdd)
1/(2*(n+1)*(n+2)) * theta.vdd^2

#### Agora, o Tio Patinhas

var_alpha <- function(x){
  a <- (n+3)/(2*n + 2)
  b <-  (3*n+1)/(2*n + 2)
  gamma <- theta.vdd^2 /( (n+1)^2*(n+2))
  obj <- (n*x^2)/b^2+(2*(1-x)*x)/(a*b)+(n*(1-x)^2)/a^2
  return(gamma*obj)
}

par(mfrow = c(1, 1))
curve(var_alpha)

alpha_opt <- function(n){
  a <- (n+3)/(2*n + 2)
  b <-  (3*n+1)/(2*n + 2)
  (b^2*n-a*b)/((b^2+a^2)*n-2*a*b)
}
alpha.opt <- alpha_opt(n)

alpha.numopt <- optimise(var_alpha, interval = c(0, 1))

alpha.numopt$minimum
alpha.opt
(1/2) * (n/(n^2-n+1))

delta_patinhas <- function(x, w){
    (1-w)*delta_huguinho(x) + w*delta_zezinho(x)
}

Ps <- apply(amostras, 1,
            function(x) delta_patinhas(x = x, w = alpha.opt))

computa_eqm(Ps, theta.vdd)
var(Ps)
var_alpha(alpha.opt)
var_alpha(alpha.numopt$minimum)
2/((5*n+3)*(n+2))*theta.vdd^2

computa_vies_qdd(Ps, theta.vdd)

par(mfrow = c(1, 2))
hist(Zs, probability = TRUE, main = "Zezinho",
     xlab = expression(delta[UZ]))
abline(v = theta.vdd, lwd = 3, lty = 2)
hist(Ps, probability = TRUE, main = "Tio Patinhas",
     xlab = expression(delta[P]))
abline(v = theta.vdd, lwd = 3, lty = 2)

###
## Comparando todo mundo em relação ao EQM
# Donald
theta.vdd^2/3
# Huguinho
(4*n)/((n+3)^2*(n+2)) * theta.vdd^2
# Zezinho
(4*n)/((3*n+1)^2*(n+2)) * theta.vdd^2
# Luisinho
1/(2*(n+1)*(n+2)) * theta.vdd^2
# Tio Patinhas
2/((5*n+3)*(n+2))*theta.vdd^2


#########################################################################
## Problema Amostre 12 variaveis aleatorias independentes uniforme(0, 1)
## Defina x_bar = soma(X)/12
## Quanto vale Pr(|x_bar - 0.5| < 0.1)?
## Para a solução exata, notar que a soma de n v.a.s U(0, 1) tem
### distribuição Irwin-Hall (https://en.wikipedia.org/wiki/Irwin%E2%80%93Hall_distribution)
### e que Pr(|X - 1/2| < 0.1) = Pr(0.4 < X < 0.6) = Pr(X<0.6)-Pr(X<0.4).
#########################################################################
## Funcoes auxiliares
IW_cdf <- function(x, n){
  if(x > n) return(1)
  ks <- 0:floor(x)
  vals <- sapply(ks, function(k) (-1)^k * choose(n, k) * (x-k)^n)
  S <- sum(vals)
  ans <- exp(log(S)-lfactorial(n))
  return(ans)
}
IW_cdf <- Vectorize(IW_cdf)
######################
## Usando TCL
aproximacao.normal <- pnorm(1.2)-pnorm(-1.2)

## Usando Monte Carlo
M <- 1E6
amostras <- matrix(NA, nrow = M, ncol = 12)
for(i in 1:M) amostras[i, ] <- runif(12)

medias <- apply(amostras, 1, mean)

aproximacao.monte.carlo <- mean(abs(medias-0.5) < 0.1)

## Exato
curve(IW_cdf(x, n = 12), 0, 12)
abline(v = 0.4 * 12, lwd = 2, lty = 2)
abline(v = 0.6 * 12, lwd = 2, lty = 2)

exato <- IW_cdf(0.6*12, n = 12)-IW_cdf(0.4*12, n = 12)

#### Comparando
aproximacao.normal
aproximacao.monte.carlo
exato

aproximacao.normal - exato
aproximacao.monte.carlo - exato


### 主成分分析の例
### - Nutritional and Marketing Information on US Cereals

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

## データの読み込み ("MASS::UScereal"を用いる)
data(UScereal) # データの読み込み

## データの内容を確認
help(UScereal)     # 内容の詳細を表示
## print(UScereal)    # 全データの表示
head(UScereal,n=5) # 最初の5個を表示
tail(UScereal,n=5) # 最後の5個を表示

## 解析に使う変数だけ取り出しデータを整理しておく
idx <- which(sapply(UScereal,is.numeric)) # 量的変数のindexを取得
idx <- idx[names(idx)!="shelf"]           # "shelf"を取り除く

## データの散布図: 図(a)
ggscatmat(UScereal, columns=idx, color="mfr", alpha=.8)
## ## ggpairsでの例
## ggpairs(UScereal, columns=idx, lower=list(mapping=aes(colour=mfr)))

## 主成分分析 (データの正規化(scale.=TRUE)による違いを見る)
model1 <- prcomp(~ ., data=dplyr::select(UScereal,idx), scale.=FALSE)
model2 <- prcomp(~ ., data=dplyr::select(UScereal,idx), scale.=TRUE)

## 寄与率の違いを表示
summary(model1)
summary(model2)
## 寄与率 (正規化なし): 図(b)
plot(model1, col="lightblue", main="PCA without scaling")
## 寄与率 (正規化あり): 図(c)
plot(model2, col="lightblue", main="PCA with scaling")

## biplotによる表示
## 主成分得点 (正規化なし): 図(d)
autoplot(model1, data=UScereal,
         colour="mfr", shape=19, size="calories", alpha=.2,
         label=TRUE, label.size=4,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.size=6,
         loadings.label.colour="blue",
         main="PCA without scaling")
## 主成分得点 (正規化あり): 図(e)
autoplot(model2, data=UScereal,
         colour="mfr", shape=19, size="calories", alpha=.2,
         label=TRUE, label.size=4,
         loadings=TRUE, loadings.colour="blue",
         loadings.label=TRUE, loadings.label.size=6,
         loadings.label.colour="blue",
         main="PCA with scaling")
## 主成分得点 (中心部拡大): 図(f)
autoplot(model2, data=UScereal, colour="mfr", shape=FALSE,
         label=TRUE, label.size=4,
         xlim=c(-.15,.15), ylim=c(-.15,.15),
         main="PCA (zoomed)")
## ## optionの例
## autoplot(model2, data=UScereal,
##          colour="mfr", shape=19, size="calories",
##          frame=TRUE, frame.type="norm", label=FALSE,
##          loadings=TRUE, loadings.colour="blue",
##          loadings.label=TRUE, loadings.label.size=5,
##          loadings.label.colour="blue",
##          main="PCA with oval frames")


##' @title
##' Negative log loss, also known as logarithmic loss or cross-entropy loss.
##'
##'
##' @description
##'
##' Log loss is an effective metric for measuring the performance of a
##' classification model where the prediction output is a probability value
##' between 0 and 1.
##'
##' Log loss quantifies the accuracy of a classifier by penalizing false
##' classifications. A perfect model would have a log loss of 0. Log loss
##' increases as the predicted probability diverges from the actual label. This
##' is the cost function used in logistic regression and neural networks.
##'
##' \code{mtr_log_loss} computes the elementwise log loss between two numeric
##' vectors. While \code{mtr_mean_log_loss} computes the average log loss
##' between two numeric vectors
##'
##'
##' @note
##' The logarithm used is the natural logarithm (base-e)
##'
##'
##' @param actual \code{[numeric]} Ground truth binary numeric vector containing
##'     1 for the positive class and 0 for the negative class.
##' @param predicted \code{[numeric]} A vector of estimated probabilities.
##' @param eps \code{[numeric]} In case of predicted probability is equal zero
##'     or one, log loss is undefined, so probabilities are clipped to max(eps,
##'     min(1 - eps, p)). The default value of eps is 1e-15.
##' @return A numeric vector output
##' @name logloss
##' @seealso \code{\link{mtr_brier_score}}
##' @author An Chu
##' @include helper-functions.r
##' @examples
##'
##' ## log loss for scalar inputs, see how log loss is converging to zero
##' mtr_log_loss(1, 0.1)
##' mtr_log_loss(1, 0.5)
##' mtr_log_loss(1, 0.9)
##' mtr_log_loss(1, 1)
##'
##' ## sample data
##' act <- c(0, 1, 1, 0, 0)
##' pred <- c(0.12, 0.45, 0.9, 0.3, 0.4)
##'
##' ## log loss vector
##' mtr_log_loss(act, pred)
##' mtr_cross_entropy(act, pred)
##'
##' ## mean log loss
##' mtr_mean_log_loss(act, pred)
##' mtr_mean_cross_entropy(act, pred)
##'
##'
##' @export
mtr_log_loss <- function(actual, predicted, eps = 1e-15) {

    check_equal_length(actual, predicted)
    check_binary(actual)

    predicted <- clip(predicted, mi = eps, ma = 1 - eps)

    logloss <- (-1) * (actual * log(predicted) + (1 - actual) * log(1 - predicted))

    logloss
}

##' @rdname logloss
##' @export
mtr_cross_entropy <- mtr_log_loss

##' @rdname logloss
##' @export
mtr_mean_log_loss <- function(actual, predicted, eps = 1e-15) {

    logloss <- mtr_log_loss(actual, predicted, eps = eps)

    mean(logloss)
}

##' @rdname logloss
##' @export
mtr_mean_cross_entropy <- mtr_mean_log_loss


# Packages used  : pracma
# To install pracma,type following in command line while connected to internet
# install.packages("pracma")
# package can be included by command " library(pracma) "
# for more information about pracma visit https://cran.r-project.org/web/packages/pracma/index.html

# Example : 4.1B   Chapter : 4.1     Page No: 201
# Null space Basis of a plane subspace
library(pracma)
nullspacebasis <- function(A){
  R<-rref(A)
  m<-nrow(A)
  n<-ncol(A)
  pivotcol<-c() #vector to store the column numbers of pivot columns
  freecol<-c()  #vector to store the column numbers of free columns
  i<-1
  j<-1

  # to find which columns are pivot and which are free
  while(i<=m & j<=n){
    if(R[i,j]==1){
      pivotcol<-c(pivotcol,j)
      i<-i+1
      j<-j+1
    }
    else{
      j<-j+1
    }
  }
  y<-length(pivotcol)
  freecol<-c(1:n)
  freecol<-freecol[!freecol%in%pivotcol]
  x<-length(freecol)
  N<-c()
  #find the basis for null space based on Row reduced echelon form of given matrix
  if(y==n){
    return(N)
  }
  for(i in 1:x){
    temp<-c(1:n)
    for(j in 1:x){
      temp[freecol[j]]<-0
    }
    temp[freecol[i]]<-1
    temp[freecol[i]]
    for(j in 1:y){
      temp[pivotcol[j]]<-R[j,freecol[i]]*-1
    }
    N<-c(N,temp)
  }
  N<-matrix(N,nrow=n,ncol=x)
  #Basis for the nullspace of given matrix
  return(N)
}

A<-matrix(c(1,-3,-4),ncol=3)
print("Given Plane x-3y-4z=0 is a null space of following 1*3 matrix")
print(A)
#to make matrix copatible for our function
A<-rbind(A,c(0,0,0),c(0,0,0))
N<-nullspacebasis(A)
print("SPecial solutions or nullspace basis of given plane subspace is")
print(N)
A<-A[-c(2,3),]
print("Row space is ")
print(A)
temp<-cbind(N,c(1,-3,-4))
x<-c(1,1,-1)
print("vector 6,4,5 is split into vn + vs as 1 of each vector in nullspace basis and -1 of rowspace basis")
v<-temp%*%x
print(v)


pizza <- read.table('Frozen_Pizza.txt',sep = '\t', header = TRUE)
# response var(y) = sales, predictor var(x) = price;
# Fit reg model for four cities, baltimore, chicago, dallas, denver
par(mfrow=c(2,2))

1.
plot(pizza$Baltimore.Volume~pizza$Baltimore.Price,xlab = 'Price', ylab = 'Sales')
imod_baltimore <- lm(Baltimore.Price~Baltimore.Volume, data = pizza)
summary(imod_baltimore)
abline(imod_baltimore) # R-square = 0.4992
title('Baltimore scatterplot')

plot(pizza$Chicago.Volume~pizza$Chicago.Price,xlab = 'Price', ylab = 'Sales')
imod_chicago <- lm(Chicago.Price~Chicago.Volume, data = pizza)
summary(imod_chicago)
abline(imod_chicago) #R-square = 0.7565
title('Chicago scatterplot')

plot(pizza$Dallas.Volume~pizza$Dallas.Price,xlab = 'Price', ylab = 'Sales')
imod_dallas <- lm(Dallas.Price~Dallas.Volume, data = pizza)
summary(imod_dallas)
abline(imod_dallas) #R-square = 0.2823
title('Dallas scatterplot')

plot(pizza$Denver.Volume~pizza$Denver.Price,xlab = 'Price', ylab = 'Sales')
imod_denver <- lm(Denver.Price~, data = pizza)
summary(imod_denver)
abline(imod_denver) #R-Square = 0.5924
title('Denver scatterplot')

2.
# Baltimore
#Time series
par(mfrow=c(2,2))
plot(pizza$Week,imod_baltimore$residuals,xlab='Weeks',ylab='Residuals')
title('Baltimore Time Series'); abline(0,0)
# residual plot of fitted values
plot(imod_baltimore$fitted.values,imod_baltimore$residuals,xlab = 'Fitted Values', ylab = 'Residuals')
title('Baltimore Residual Plot Fitted Values'); abline(0,0)
# QQ plot
qqnorm(imod_baltimore$residuals);qqline(imod_baltimore$residuals)

# Chicago
# Time Series
par(mfrow=c(2,2))
plot(pizza$Week,imod_chicago$residuals,xlab='Weeks',ylab='Residuals')
title('Chicago Time Series'); abline(0,0)
# Residual Plot of Fitted Values
plot(imod_chicago$fitted.values,imod_chicago$residuals,xlab = 'Fitted Values', ylab = 'Residuals')
title('Chicago Residual Plot Fitted Values'); abline(0,0)
# QQ plot
qqnorm(imod_chicago$residuals);qqline(imod_chicago$residuals)

#Dallas
#Time Series
par(mfrow=c(2,2))
plot(pizza$Week,imod_dallas$residuals,xlab='Weeks',ylab='Residuals')
title('Dallas Time Series'); abline(0,0)
#Residual plot
plot(imod_dallas$fitted.values,imod_dallas$residuals,xlab = 'Fitted Values', ylab = 'Residuals')
title('Dallas Residual Plot Fitted Values'); abline(0,0)
#QQ plot
qqnorm(imod_dallas$residuals);qqline(imod_dallas$residuals)

#Denver
# Time Series
par(mfrow=c(2,2))
plot(pizza$Week,imod_denver$residuals,xlab='Weeks',ylab='Residuals')
title('Denver Time Series'); abline(0,0)
# Residual Plot
plot(imod_denver$fitted.values,imod_denver$residuals,xlab = 'Fitted Values', ylab = 'Residuals')
title('Denver Residual Plot Fitted Values'); abline(0,0)
#QQ plot
qqnorm(imod_denver$residuals);qqline(imod_denver$residuals)
3.
# Focus on denver and show and interpt an 90% confidence interval
plot(pizza$Dallas.Volume~pizza$Dallas.Price,xlab = 'Price', ylab = 'Sales')
imod_dallas <- lm(Dallas.Volume~Dallas.Price, data = pizza)
summary(imod_dallas)
abline(imod_dallas) #R-square = 0.2823
title('Dallas scatterplot')
confint(imod_dallas,level=0.90) # CI = (-40655.79, -26398.58) a decrease!
# By the confidence interval alone, we cant say signifigance

4.
# H0: beta0 = 0; HA: beta0 != 0;
summary(imod_dallas) # reject H0 bc p-value (almost 0) is less than alpha (.1)

5.
range(pizza$Dallas.Price) #range is between 2.21 and 3.05

new1 <- data.frame(Dallas.Price = c(2.50))
new2 <- data.frame(Dallas.Price = c(3.00))

predict(imod_dallas,newdata = new1, interval = 'confidence', level = 0.95)
# predicted mean = 55729.47, CI = (54063.14,57395.79)
predict(imod_dallas,newdata = new2, interval = 'confidence', level = 0.95)
# predicted mean = 33965.87, CI = (35464.31, 42467.44)

# No we cant estimate the mean if price = 3.50 becuase it is out of the sample range

6.

new3 <- data.frame(Dallas.Price = c(2.99))

predict(imod_dallas,newdata = new3, interval = 'prediction', level = 0.95)
# predicted mean = 39301.15, Prediction interval = (22425.65, 56176.65)
# No resulting prediction is not useful becuase it is too wide of a prediction


# pull N numbers from a normal distribution
rnorm(10)
rnorm(10, mean = 100, sd = 25)
myRand <- rnorm(20)
dnorm(myRand)

# build a density curve for N points in the normal dist
require(ggplot2)
myRand <- rnorm(50000)
myRandDensity <- dnorm(myRand)
ggplot(data.frame(x=myRand, y=myRandDensity)) +
    aes(x=x,y=y) +
    geom_point() +
    labs(x="Random numbers", y="Density")

# cumulative probability distribution is P of x or less
pnorm(myRand)
pnorm(c(3,0,3))
pnorm(c(-1,0,1))
# if not left tail but interval, diff the Ps
pnorm(1)-pnorm(0)

# binomial dist
rbinom(n = 5, size = 10, prob = 0.4)
#hist it
myBinomData <- rbinom(10000, 10, 0.3)
ggplot(data.frame(Successes = myBinomData)) +
    aes(x = Successes) +
    geom_histogram(binwidth=1)

# build different binomial dists of differing sizes, then combine into
# a single data frame

myBinom10 <- data.frame(Successes=rbinom(10000, 10, 0.3), Size=10)
myBinom100 <- data.frame(Successes=rbinom(10000, 100, 0.3), Size=100)
myBinom1000 <- data.frame(Successes=rbinom(10000, 1000, 0.3), Size=1000)
myBinom10000 <- data.frame(Successes=rbinom(10000, 10000, 0.3), Size=10000)
myBinomAll <- rbind(myBinom10, myBinom100, myBinom1000, myBinom10000)

ggplot(myBinomAll) +
    aes(x=Successes) +
    geom_histogram(bindiwth=1) +
    facet_wrap(~Size, scales = "free")

# some functions working with the Normal dist
dbinom(x=3, size = 10, prob = 0.3)
pbinom(q = 3, size = 10,prob = 0.3)
qbinom(p = 0.4, size = 10, prob = 0.3)
# i.e., need RETURN draws
qbinom(p = c(0.2, 0.25, 0.3, 0.35, 0.5, 0.6), size = 10, prob = 0.3)

#build up differing poisson distributions
myPois1 <- rpois(n = 10000, lambda = 1)
myPois2 <- rpois(n = 10000, lambda = 2)
myPois5 <- rpois(n = 10000, lambda = 5)
myPois10 <- rpois(n = 10000, lambda = 10)
myPois20 <- rpois(n = 10000, lambda = 20)
myPoisAll <- data.frame(Lambda.1=myPois1,
                   Lambda.2=myPois2,
                   Lambda.5=myPois5,
                   Lambda.10=myPois10,
                   Lambda.20=myPois20)

ggplot(myPoisAll) +
    aes(x=Draws) +
    geom_histogram(binwidth=1) +
    facet_wrap(~Mean, scales = "free")

require(reshape2)
myPoisAll <- melt(data = myPoisAll, variable.name = "Lambda", value.name = "x")
# lets extract the x from Lambda.x and make it cleaner to read
require(stringr)
myPoisAll$Lambda <- str_extract(string = myPoisAll$Lambda, pattern = "\\d+")
# need to cast Lanmda vector as a Factor to use nicely in ggplot
myPoisAll$Lambda <- as.factor(as.numeric(myPoisAll$Lambda))
# build a plot
ggplot(myPoisAll) +
    aes(x=x) +
    geom_density(aes(group=Lambda, color=Lambda, fill=Lambda), adjust=4, alpha=1/2) +
    scale_color_discrete() +
    scale_fill_discrete() +
    ggtitle("Probability Mass Function")

#9.2
x <- sample(x = 1:100, size = 100, replace = TRUE)
first <- sample(x=1:50, size = 5, replace=FALSE)
second <- sample(x=1:15, size=1, replace=FALSE)
xNA <- x
xNA[sample(x=1:100, size=20, replace=FALSE)] <- NA
mean(xNA, na.rm = TRUE)
var(xNA, na.rm = TRUE)
sd(xNA, na.rm = TRUE)
summary(x)
quantile(x, probs = c(0.25, 0.75))

# correlations using sample data
cor(economics$pce, economics$psavert)
myEconCor <- cor(economics[, c(2,4:6)])
myEconCorMelted <- melt(data = myEconCor, varnames = c("x", "y"), value.name = "Correlations")
#now order the result for plotting
myEconCorMeltedOrdered <- myEconCorMelted[order(myEconCorMelted$Correlations), ]

#now plot as a heat map
require(scales)
ggplot(myEconCorMeltedOrdered) +
    aes(x=x, y=y) +
    geom_tile(aes(fill=Correlations)) +
    scale_fill_gradient2(low=muted("red"), mid="white", high="steelblue",
                         guide=guide_colorbar(ticks = FALSE, barheight = 12),
                         limits=c(-1,1)) +
    theme_minimal() +
    labs(x=NULL, y=NULL) +
    ggtitle("Correlation Heat Map of Economic Factors")

# t-test
data("tips", package="reshape2")
# 1-sample t-test first. testing for equal to, not greater/less than
t.test(tips$tip, alternative="two.sided", mu=2.5)
randT <- rt(30000, df=NROW(tips)-1)
tipTTest <- t.test(tips$tip, alternative="two.sided", mu=2.5)

ggplot(data.frame(x=randT)) +
    geom_density(aes(x=x), fill="grey", color="grey") +
    geom_vline(xintercept=tipTTest$statistic) +
    geom_vline(xintercept=mean(randT) + c(-2,2)*sd(randT), linetype=2)

#result shows mu is far from center of distribution

# 1 sided to show if less or more than
t.test(tips$tip, alternative="greater", mu=2.5)

# compare tips of females to males
aggregate(tip~sex, data=tips, mean)

#to t test effectively between two groups, need to have the variance equal, so lets test
aggregate(tip~sex, data=tips, var)
#appears different, but lets test for normally distributed
shapiro.test(tips$tip)
# shows with low p value NOT normally distributed as a whole
shapiro.test(tips$tip[tips$sex == "Female"])
shapiro.test(tips$tip[tips$sex == "Male"])
# low p values show subsets are both not normally distributed, so normal test wont work.
# still let's plot and visualize
ggplot(tips, aes(x=tip, fill=sex)) +
    geom_histogram(binwidth=0.5, alpha=1/2)
# both are skewed. Thus, parametric test will not work. Need to use non-parametric test
ansari.test(tip~sex, tips)
#high p values mean we can use this test
t.test(tip~sex, data=tips, var.equal=TRUE)
# p value above threshold, so tips between the sexes are roughly equivalent
# let's visualize
library(plyr)
tipSummary <- ddply(tips, "sex", summarize,
                    tip.mean=mean(tip), tip.sd=sd(tip),
                    Lower=tip.mean - 2*tip.sd/sqrt(NROW(tip)),
                    Upper=tip.mean + 2*tip.sd/sqrt(NROW(tip)))
ggplot(tipSummary, aes(x=tip.mean, y=sex)) +
    geom_point() +
    geom_errorbarh(aes(xmin=Lower, xmax=Upper), height=.2)
#paired t test
library(UsingR)
#have data set of father and son variables
t.test(father.son$fheight, father.son$sheight, paired=TRUE)
# results show low pvalues, so little difference between paired observations
#what about more than two samples? Need Anova

#want to test whether tips vary by day
tipAnova <- aov(tip ~ day -1, tips)
tipIntercept <- aov(tip ~ day, tips)
tipAnova$coefficients
tipIntercept$coefficients
# we have an intercept != 0, so can only compute on N-1 values
# look at summary to see what is p value for anova
summary(tipAnova)
# let's visualize
tipsByDay <- ddply(tips, "day", summarise,
                   tip.mean=mean(tip), tip.sd=sd(tip),
                   Length=NROW(tip),
                   tfrac=qt(p=.9, df=Length-1),
                   Lower=tip.mean - tfrac*tip.sd/sqrt(Length),
                   Upper=tip.mean + tfrac*tip.sd/sqrt(Length))

ggplot(tipsByDay, aes(x=tip.mean, y=day)) +
    geom_point() +
    geom_errorbarh(aes(xmin=Lower, xmax=Upper), height=.3)
# see the non-overlapping confidence intervals


## 2. Observed Data vs Expected Data ##

female_diff <- (10771 - 16280.5) / 16280.5
male_diff <- (21790 - 16280.5) / 16280.5

## 3. Dealing With Cancellation ##

female_diff_sq <- (10771 - 16280.5)^2 / 16280.5
male_diff_sq <- (21790 - 16280.5)^2 / 16280.5
squared_diff_sum <- female_diff_sq + male_diff_sq

## 5. Developing a null hypothesis ##

pvalue <- 1 - pchisq(3728, 1)
reject_null <- TRUE

## 6. Importance of sample size ##

pvalue <- 1 - pchisq(1.8, 1)
reject_null <- FALSE

## 7. Considering More Categories ##

race_chisq <- 0
observed <- c(27816, 3124, 1039, 311, 271)
expected <- c(26146.5, 3939.9, 944.3, 260.5, 1269.8)

for (i in 1:length(observed)) {
    E <- expected[i]
    O <- observed[i]
    race_chisq <- race_chisq + ((O - E)^2/E)
}

## 8. Adjusting The Distribution Under The Null ##

pvalue <- 1 - pchisq(785, 4)

Data Analyst in R/Step 5 - Probability and Statistics/5. Hypothesis Testing in R/3. Categorical Data and The Chi-Squared Test.r


## 1. The Importance of Counting ##

n_outcomes <- 6 * 6

p_six_six <- 1 / n_outcomes
p_five_five <- 1 / n_outcomes
p_not_five_five <- 1 - p_five_five

## 2. Extending The Rule of Product ##

total_outcomes <- 6 * 6 * 6 * 52
p_666_ace_diamonds <- 1 / total_outcomes
p_no_666_ace_diamonds <- 1 - p_666_ace_diamonds

## 3. A More Concrete Example ##

total_outcomes_4_pin <- 10^4 # 10 multiplied by itself 4 times
p_crack_4 <- 1 / total_outcomes_4_pin

total_outcomes_6_pin <- 10^6 # 10 multiplied by itself 6 times
p_crack_6 <- 1/total_outcomes_6_pin

## 4. With Replacement vs Without Replacement ##

size_num_4 <- 10 * 9 * 8 * 7
size_num_6 <- 10 * 9 * 8 * 7 * 6 * 5

## 5. Permutations ##

factorial <- function(n) {
    final_product <- 1
    for (i in 1:n) {
        final_product = final_product * i
    }
    return(final_product)
}

permutations_1 <- factorial(6) # because there are 6 letters
permutations_2 <- factorial(52)

## 6. More About Permutations ##

factorial <- function(n) {
    final_product <- 1
    for (i in 1:n) {
        final_product = final_product * i
    }
    return(final_product)
}
permutation <- function(n, k) {
    return(factorial(n) / factorial(n - k))
}

perm_3_52 <- permutation(52,3)
perm_4_20 <- permutation(20, 4)

## 7. Sometimes Order Doesn't Matter ##

factorial <- function(n) {
    final_product <- 1
    for (i in 1:n) {
        final_product <- final_product * i
    }
    return(final_product)
}

permutation <- function(n, k) {
    return(factorial(n) / factorial(n - k))
}
c <- permutation(52, 5) / factorial(5)
p_aces_7 <- 1/c

c_lottery <- permutation(49,6) / factorial(6)
p_big_prize <- 1/c_lottery

## 8. Combination Notation ##

factorial <- function(n) {
    final_product <- 1
    for (i in 1:n) {
        final_product <- final_product * i
    }
    return(final_product)
}
combination <- function(n, k) {
    return(factorial(n)/(factorial(n - k) * factorial(k)))
}

c_18 <- combination(34, 18)

p_Y <- 1/c_18
p_non_Y <- 1 - p_Y

Data Analyst in R/Step 5 - Probability and Statistics/3. Probability Fundamentals in R/4. Permutations and Combinations.r


fib_recurse <- function(n)
{
  if (n <= 1)
  {
    return(n)
  }
  else
  {
    return(fib_recurse(n-1) + fib_recurse(n-2))
  }
}

# taking input from user
nterms = as.integer(readline(prompt='Enter a positive integer: '))
while(nterms < 0)
{
  print('Cannot accept negative numbers ...')
  nterms = as.integer(readline(prompt='Enter a positive integer: '))
}

print('The Fibonacci sequence:')
for (i in 0:(nterms - 1))
{
  print(fib_recurse(i))
}


library(dslabs)
data(murders)

# 1. Remake the temperature data frame, adding a line that converts the temperature from Fahrenheit to Celsius.

fahrenheit <- c(35, 88, 42, 84, 81, 30)
celsius <- (5/9) * (fahrenheit - 32)
city <- c("Beijing", "Lagos", "Paris", "Rio de Janeiro",
          "San Juan", "Toronto")
city_temps <- data.frame(name = city, temperature = celsius)
city_temps

# 2. The Basel Problem: the sum of 1 + 1/2² + 1/3² + ... + 1/100² equals to aproximately π²/6

range <- (1:100)
basel <- sum(1/(range^2))
basel

# 3. Compute the per 100,000 murder rate for each state and store it in the object murder_rate. Then compute the average murder rate for the US using the function mean. What is the average?

population <- murders$population
total <- murders$total
murder_rate <- (total / population) * 100000
avg_murder_rate = mean(murder_rate)
avg_murder_rate

# Now we can build a data frame with state and murder rate, from lowest to highest

states <- murders$state
index <- order(murder_rate)
murder_df = data.frame(state = states[index], murder_rate = murder_rate[index])
murder_df

 # We can do the same, but ordering highest to lowest (in this case that's more convenient!)

index <- order(murder_rate, decreasing=TRUE)
murder_df = data.frame(state = states[index], murder_rate = murder_rate[index])
murder_df


heat_loss <- c(86,80,77 , 78,84,75 ,33,38,43)
temperature <- c(81,81,81,79,79,79,38,38,38)

# Apply the lm() function.
relation <- lm(heat_loss~temperature)

aov(relation)

SSPexp=134
SSresidual=894.5 #calculated in 11.10
SSlack=SSresidual-SSPexp

MSPexp=SSPexp/6
MSlack=SSlack/1
# test statistic
F=MSlack/MSPexp
print(F)
alpha=0.05

fvalue=qf(1-alpha,df1 = 1,df2 = 6)
if(F>fvalue){
  print(" we reject H0 and conclude that there is significant lack of fit for a linear regression model")
}else{
  print("we  do not reject H0 and conclude that there is no significant lack of fit for a linear regression model")
}


##### Chapter 6: Regression Methods -------------------

#### Part 1: Linear Regression -------------------

## Understanding regression ----
## Example: Space Shuttle Launch Data ----
launch <- read.csv("challenger.csv")

# estimate beta manually
b <- cov(launch$temperature, launch$distress_ct) / var(launch$temperature)
b

# estimate alpha manually
a <- mean(launch$distress_ct) - b * mean(launch$temperature)
a

# calculate the correlation of launch data
r <- cov(launch$temperature, launch$distress_ct) /
       (sd(launch$temperature) * sd(launch$distress_ct))
r
cor(launch$temperature, launch$distress_ct)

# computing the slope using correlation
r * (sd(launch$distress_ct) / sd(launch$temperature))

# confirming the regression line using the lm function (not in text)
model <- lm(distress_ct ~ temperature, data = launch)
model
summary(model)

# creating a simple multiple regression function
reg <- function(y, x) {
  x <- as.matrix(x)
  x <- cbind(Intercept = 1, x)
  b <- solve(t(x) %*% x) %*% t(x) %*% y
  colnames(b) <- "estimate"
  print(b)
}

# examine the launch data
str(launch)

# test regression model with simple linear regression
reg(y = launch$distress_ct, x = launch[2])

# use regression model with multiple regression
reg(y = launch$distress_ct, x = launch[2:4])

# confirming the multiple regression result using the lm function (not in text)
model <- lm(distress_ct ~ temperature + pressure + launch_id, data = launch)
model

## Example: Predicting Medical Expenses ----
## Step 2: Exploring and preparing the data ----
insurance <- read.csv("insurance.csv", stringsAsFactors = TRUE)
str(insurance)

# summarize the charges variable
summary(insurance$expenses)

# histogram of insurance charges
hist(insurance$expenses)

# table of region
table(insurance$region)

# exploring relationships among features: correlation matrix
cor(insurance[c("age", "bmi", "children", "expenses")])

# visualing relationships among features: scatterplot matrix
pairs(insurance[c("age", "bmi", "children", "expenses")])

# more informative scatterplot matrix
library(psych)
pairs.panels(insurance[c("age", "bmi", "children", "expenses")])

## Step 3: Training a model on the data ----
ins_model <- lm(expenses ~ age + children + bmi + sex + smoker + region,
                data = insurance)
ins_model <- lm(expenses ~ ., data = insurance) # this is equivalent to above

# see the estimated beta coefficients
ins_model

## Step 4: Evaluating model performance ----
# see more detail about the estimated beta coefficients
summary(ins_model)

## Step 5: Improving model performance ----

# add a higher-order "age" term
insurance$age2 <- insurance$age^2

# add an indicator for BMI >= 30
insurance$bmi30 <- ifelse(insurance$bmi >= 30, 1, 0)

# create final model
ins_model2 <- lm(expenses ~ age + age2 + children + bmi + sex +
                   bmi30*smoker + region, data = insurance)

summary(ins_model2)

#### Part 2: Regression Trees and Model Trees -------------------

## Understanding regression trees and model trees ----
## Example: Calculating SDR ----
# set up the data
tee <- c(1, 1, 1, 2, 2, 3, 4, 5, 5, 6, 6, 7, 7, 7, 7)
at1 <- c(1, 1, 1, 2, 2, 3, 4, 5, 5)
at2 <- c(6, 6, 7, 7, 7, 7)
bt1 <- c(1, 1, 1, 2, 2, 3, 4)
bt2 <- c(5, 5, 6, 6, 7, 7, 7, 7)

# compute the SDR
sdr_a <- sd(tee) - (length(at1) / length(tee) * sd(at1) + length(at2) / length(tee) * sd(at2))
sdr_b <- sd(tee) - (length(bt1) / length(tee) * sd(bt1) + length(bt2) / length(tee) * sd(bt2))

# compare the SDR for each split
sdr_a
sdr_b

## Example: Estimating Wine Quality ----
## Step 2: Exploring and preparing the data ----
wine <- read.csv("whitewines.csv")

# examine the wine data
str(wine)

# the distribution of quality ratings
hist(wine$quality)

# summary statistics of the wine data
summary(wine)

wine_train <- wine[1:3750, ]
wine_test <- wine[3751:4898, ]

## Step 3: Training a model on the data ----
# regression tree using rpart
library(rpart)
m.rpart <- rpart(quality ~ ., data = wine_train)

# get basic information about the tree
m.rpart

# get more detailed information about the tree
summary(m.rpart)

# use the rpart.plot package to create a visualization
library(rpart.plot)

# a basic decision tree diagram
rpart.plot(m.rpart, digits = 3)

# a few adjustments to the diagram
rpart.plot(m.rpart, digits = 4, fallen.leaves = TRUE, type = 3, extra = 101)

## Step 4: Evaluate model performance ----

# generate predictions for the testing dataset
p.rpart <- predict(m.rpart, wine_test)

# compare the distribution of predicted values vs. actual values
summary(p.rpart)
summary(wine_test$quality)

# compare the correlation
cor(p.rpart, wine_test$quality)

# function to calculate the mean absolute error
MAE <- function(actual, predicted) {
  mean(abs(actual - predicted))
}

# mean absolute error between predicted and actual values
MAE(p.rpart, wine_test$quality)

# mean absolute error between actual values and mean value
mean(wine_train$quality) # result = 5.87
MAE(5.87, wine_test$quality)

## Step 5: Improving model performance ----
# train a M5' Model Tree
library(RWeka)
m.m5p <- M5P(quality ~ ., data = wine_train)

# display the tree
m.m5p

# get a summary of the model's performance
summary(m.m5p)

# generate predictions for the model
p.m5p <- predict(m.m5p, wine_test)

# summary statistics about the predictions
summary(p.m5p)

# correlation between the predicted and true values
cor(p.m5p, wine_test$quality)

# mean absolute error of predicted and true values
# (uses a custom function defined above)
MAE(wine_test$quality, p.m5p)


#estimae sigma^2 and mu

#mu: Normal
#sigma: Inverse Gamma

updateMu = function(n, yBar, sig2, mu_0, sig2_0){
    sig2_1 = 1.0 / (n / sig2 + 1.0 / sig2_0)
    mu_1 = sig2_1 * (n * yBar / sig2 + mu_0 / sig2_0)
    rnorm(n=1, mean=mu_1, sd=sqrt(sig2_1))
}

updateSig2 = function(n, y, nu, nu_0, beta_0){
    nu_1 = nu_0 + n / 2.0
    sumSq = sum( (y-nu)^2)
    beta_1 = beta_0 + sumSq / 2.0
    outGamma = rgamma(n=1, shape=nu_1, rate=beta_1)
    1.0 / outGamma # inverse must be down manually
}

gibbs = function(y, nIter, init, prior){
    yBar = mean(y)
    n = length(y)

    muOut = numeric(nIter)
    sig2Out = numeric(nIter)

    muNow = init$mu

    # Gibs sampler
    for (i in 1:nIter){
        sig2Now = updateSig2(n=n, y=y, nu=muNow, nu_0=prior$nu_0, beta_0=prior$beta_0)
        muNow = updateMu(n=n, yBar=yBar, sig2=sig2Now, mu_0=prior$mu_0, sig2_0=prior$sig2_0)

        sig2Out[i] = sig2Now
        muOut[i] = muNow
    }
    cbind(mu=muOut, sig2=sig2Out)
}

#y =  c(1.2, 1.4, -0.5, 0.3, 0.9, 2.3, 1.0, 0.1, 1.3, 1.9)
y = c(-0.2, -1.5, -5.3, 0.3, -0.8, -2.2)
n = length(y)
yBar = mean(y)

prior = list()

prior$mu_0 = 1.0
prior$sig2_0 = 1.0 #variance, prior confidence in mean
prior$n_0 = 2.0
prior$s2_0 = 1.0
prior$nu_0 = prior$n_0 / 2.0
prior$beta_0 = prior$n_0 * prior$s2_0 / 2.0

hist(y, freq=FALSE, xlim=c(-1.0,3.0))
curve(dnorm(x=x, mean=prior$mu_0, sd=sqrt(prior$sig2_0)), lty=2, add=TRUE)
points(y, rep(0,n), pch=1)
points(yBar, 0, pch=19)

set.seed(53)

init = list()
init$mu = 0.0

post = gibbs(y=y,nIter=5000,init=init,prior=prior)
head(post)
tail(post)

library("coda")
plot(as.mcmc(post))

mean(post[,1])


yi=c(0,1,2,3,4,5,6,7)
ni=c(6,23,29,31,27,13,8,13)
n=sum(ni)
ybar=sum(yi*ni)/sum(ni)
print(ybar)
# ybar value in book is calculated wrong
# The Poisson probabilities
Pyi=c(dpois(0,ybar),dpois(1,ybar),dpois(2,ybar),dpois(3,ybar),dpois(4,ybar),dpois(5,ybar),dpois(6,ybar),dpois(7,ybar))
print(Pyi)
# Expected cell count
Ei=n*Pyi
print(Ei)

# test statistic
i=1
X2=0
while(i<9){
  X2=X2+(((ni[i]-Ei[i])^2)/Ei[i])
  i=i+1
}
print(X2) # ans in book is calculate wrong
df=6

pvalue=pchisq(X2,df,lower.tail = FALSE)
print(pvalue)
# as p-value <=.01 model is   Poisson model provides an Unacceptable fit to data


library(dplyr)
library(sjmisc)
library(sjPlot)
library(ggplot2)
library(car)

data(iris)

names(iris)

newiris <- select(iris,c( "Species" ,"Sepal.Length"))

### summarise dataframe

summary(newiris)

### plot numerical variable only histogram

ggplot(newiris) +
  aes(x = Sepal.Length ) + geom_histogram()

### plot numerical variable only dotplot (similar to hist)

ggplot(newiris) +
  aes(x = Sepal.Length ) + geom_dotplot()

### plot numerical variable for each category

ggplot(newiris) +
  aes(x = Species, y = Sepal.Length, color = Species) +
  geom_jitter() +
  theme(legend.position = "none")

# Boxplot
boxplot(Sepal.Length ~ Species,
        data = newiris
)

###### ANOVA

result_aov <- aov(Sepal.Length ~ Species,data = newiris)

# histogram of residuals (to check visually for normality of errors)
hist(result_aov$residuals)

# QQ-plot

qqPlot(result_aov$residuals,
       # id = FALSE to remove point identification
       id = FALSE )

#Kolmogorov-Smirnoff test of normality

ks.test(result_aov$residuals,
        "pnorm", mean=mean(result_aov$residuals),
        sd=sd(result_aov$residuals))

#   Homogeneity of variances Levene test
#The null and alternative hypothesis for both tests are:

#H0: variances are equal
#H1: at least one variance is different

leveneTest(Sepal.Length ~ Species,data = newiris)

#   Homogeneity of variances plot (RESIDUALS VS FITTED)
plot(result_aov, which = 1)

summary(result_aov)

library("report") # Load the package every time you start R

report(result_aov)


setwd('/home/g/Documents/AdminInfo/LAB07')
library(scales)

estudiantes <- read.csv('data-conversion.csv')
View(estudiantes)

estudiantes$Income.rescaled <- rescale(estudiantes$Income)
View(estudiantes)

(estudiantes$Income - min(estudiantes$Income))/ (max(estudiantes$Income)- min(estudiantes$Income))

rescale(estudiantes$Income, to = c(0,100))

rescalar.cols <- function(df, cols){
  nombres <- names(df)
  for (col in cols){
    nombre <- paste(nombres[col], 'rescaled', sep = '.')
    df[nombre] <- rescale(df[,col])
  }
  cat(paste("Hemos reescalado ", length(cols), " variable(s)"))
  df
}

estudiantes <- rescalar.cols(estudiantes, c(1,4))
View(estudiantes)

casas <- read.csv("BostonHousing.csv")

View(casas)

casas.z <- scale(casas)
View(casas.z)

casas.mean <- scale(casas, center = TRUE, scale = FALSE)

View(casas.mean)

casas.sd <- scale(casas, center = FALSE, scale = TRUE)

View(casas.sd)

normalizar.cols <- function(df, cols){
  nombres <- names(df)
  for (col in cols){
    nombre <- paste(nombres[col], "z", sep = ".")
    df[nombre]<- scale(df[,col])
  }
  cat(paste("Hemos normalizado ", length(cols), " variable(s)"))
  df
}

casas <- normalizar.cols(casas, c(1,3,5:8))
View(casas)


si=c(.1204,.1269,.1196,.1249,.1265)
# data fom example 9.3
Fmax=max(si)^2/min(si)^2
print(Fmax)
# four test statistic
SSC1=.2097 # these value are computed in 9.3
SSC2=.1297
SSC3=.0037
SSC4=.0217
MSError=.0153
F1=SSC1/MSError
F2=SSC2/MSError
F3=SSC3/MSError
F4=SSC4/MSError

print(F1)
print(F2)
print(F3)
print(F4)

alpha=0.05
df1=1
df2=25
F_0.05_1_25=qf(1-alpha,df1,df2)
print(F_0.05_1_25)

# we conclude that contrasts l1 and l2 were significantly
#different from zero but contrasts l3 and l4 were not significantly different from zero.


#Calculate the likelihood ratio----
n<-10 #set total trials
x<-8#set successes
H0 <- .5 #specify one hypothesis you want to compare with the likihood ratio
H1 <- .5 #specify another hypothesis you want to compare with the likihood ratio (you can use 1/20, or 0.05)
dbinom(x,n,H0)/dbinom(x,n,H1) #Returns the likelihood ratio of H0 over H1
dbinom(x,n,H1)/dbinom(x,n,H0) #Returns the likelihood ratio of H1 over H0

theta<- seq(0,1,len=100) #create theta variable, from 0 to 1
like <- dbinom(x,n,theta)
#png(file="LikRatio.png",width=4000,height=3000, , units = "px", res = 900)
plot(theta,like,type='l',xlab=expression(theta), ylab='Likelihood', lwd=2)
points(H0,dbinom(x,n,H0))
points(H1,dbinom(x,n,H1))
segments(H0, dbinom(x,n,H0), x/n, dbinom(x,n,H0), lty=2, lwd=2)
segments(H1, dbinom(x,n,H1), x/n, dbinom(x,n,H1), lty=2, lwd=2)
segments(x/n, dbinom(x,n,H0), x/n, dbinom(x,n,H1), lwd=2)
title(paste('Likelihood Ratio H0/H1:',round(dbinom(x,n,H0)/dbinom(x,n,H1),digits=2)," Likelihood Ratio H1/H0:",round(dbinom(x,n,H1)/dbinom(x,n,H0),digits=2)))
#dev.off()

#? Daniel Lakens, 2016.
# This work is licensed under a Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License. https://creativecommons.org/licenses/by-nc-sa/4.0/


#!/usr/bin/env Rscript

v = read.table("res/Billianaires.TXT", sep=",", header=T, na.strings="-")
w = v[v[,6]=="United States"|v[,6]=="China"|v[,6]=="Japan",]
w[,6] = as.character(w[,6])

# eg.1 位置统计量(location statistic)
w1 = w[w[,6]=="China", ]
w2 = w[w[,6]=="United States", ]
w3 = w[w[,6]=="Japan", ]

mean(w1$Age, na.rm=T)
mean(w2$Age, na.rm=T)
mean(w3$Age, na.rm=T)

median(w1$Age, na.rm=T)
median(w2$Age, na.rm=T)
median(w3$Age, na.rm=T)

quantile(v$Age, .25, na.rm=T)
quantile(v$Age, .75, na.rm=T)

# 众数mode (样本中出现的条目最多的)
z = table(v$Age)
modeAge = max(z)
z[which(z == modeAge)]

# which.min(w1$Age)

# eg.2 尺度统计量(scale statistic)
# 极差(Range)
paste("China Age range: ",
      max(w1$Age), " - ",
      min(w1$Age), " = ",
      max(w1$Age) - min(w1$Age))
print(diff(range(w1$Age)))

paste("United States Age range: ",
      max(w2$Age), " - ",
      min(w2$Age), " = ",
      max(w2$Age) - min(w2$Age))
print(diff(range(w2$Age)))

paste("Japan Age range: ",
      max(w3$Age), " - ",
      min(w3$Age), " = ",
      max(w3$Age) - min(w3$Age))
print(diff(range(w3$Age)))

# 四分位间距/极差 (interquantile range)
paste("China Age interquantile  range: ",
      quantile(w1$Age, .75), " - ",
      quantile(w1$Age, .25), " = ",
      quantile(w1$Age, .75) - quantile(w1$Age, .25))
print(diff(quantile(w1$Age, c(.25, .75))))

paste("United States Age interquantile range: ",
      quantile(w2$Age, .75), " - ",
      quantile(w2$Age, .25), " = ",
      quantile(w2$Age, .75) - quantile(w2$Age, .25))
print(diff(quantile(w2$Age, c(.25, .75))))

paste("Japan Age interquantile range: ",
      quantile(w3$Age, .75), " - ",
      quantile(w3$Age, .25), " = ",
      quantile(w3$Age, .75) - quantile(w3$Age, .25))
print(diff(quantile(w3$Age, c(.25, .75))))

# 方差, 标准差, 标准得分
paste("sd(w1), var(w1): ", sd(w1$Age), var(w1$Age))
paste("sd(w2), var(w2): ", sd(w2$Age), var(w2$Age))
paste("sd(w3), var(w3): ", sd(w3$Age), var(w3$Age))
print(scale(w1))


## 1. Individual Values ##

library(readr)
# Heads up that the following instruction can generate a column specification warnings, you can ignore that.
# These warnings are related to that `readr` has misguidedly guessed the type of values in the column `Pool QC`.
# To avoid this warning we can manually specify the type of this column the `col_types` parameter.
houses  <-  read_tsv('AmesHousing_1.txt', col_types = cols(`Pool QC` = col_character()))

standard_deviation <- function(vector) {
    distances  <-  (vector - mean(vector))**2
    sqrt(sum(distances) / length(distances) )
}

st_dev  <-  standard_deviation(houses$SalePrice)
mean  <-  mean(houses$SalePrice)

library(ggplot2)
#ggplot(data = houses,
#    aes(x = SalePrice)) +
#    geom_density(alpha = 0.1,
#                 color='blue',
#                 fill='blue') +
#    geom_vline(aes(xintercept = mean,
#                   color = 'Mean'),
#               size = 1.2 ) +
#    geom_vline(aes(xintercept = 220000,
#                   color = '220,000'),
#               size = 1.2 ) +
#    geom_vline(aes(xintercept = mean+st_dev,
#                   color = 'Standard deviation'),
#               size = 1.2 ) +
#    scale_y_continuous(labels = scales::comma) +
#    scale_x_continuous(labels = scales::comma,
#                       lim = c(min(houses$SalePrice),
#                               max(houses$SalePrice))) +
#    scale_colour_manual(values = c("Mean"="black",
#                                   "220,000"="red",
#                                   "Standard deviation"="orange"),
#                        name = "") +
#    theme_bw() +
#    theme(legend.position='top') +
#    xlab("Sale Price") +
#    ylab("Density")
very_expensive  <-  FALSE

## 2. Number of Standard Deviations ##

standard_deviation <- function(vector) {
    distances  <-  (vector - mean(vector))**2
    sqrt(sum(distances) / length(distances) )
}
distance  <-  220000 - mean(houses$SalePrice)
st_devs_away  <-  distance / standard_deviation(houses$SalePrice)

## 3. Z-scores ##

min_val  <-  min(houses$SalePrice)
mean_val  <-  mean(houses$SalePrice)
max_val  <-  max(houses$SalePrice)

standard_deviation <- function(vector) {
    distances  <-  (vector - mean(vector))**2
    sqrt(sum(distances) / length(distances) )
}
z_score <- function(value, vector, bessel = FALSE) {
    mean  <-  mean(vector)

    st_dev <- ifelse(!bessel, sd(vector), standard_deviation(vector))

    (value - mean) / st_dev
}

min_z  <-  z_score(min_val, houses$SalePrice)
mean_z  <-  z_score(mean_val, houses$SalePrice)
max_z  <-  z_score(max_val, houses$SalePrice)

## 4. Locating Values in Different Distributions ##

standard_deviation <- function(vector) {
    distances  <-  (vector - mean(vector))**2
    sqrt(sum(distances) / length(distances) )
}

z_score <- function(value, vector, bessel = FALSE) {
    mean  <-  mean(vector)

    st_dev <- ifelse(!bessel, sd(vector), standard_deviation(vector))

    (value - mean) / st_dev
}

target_neighborhoods <- c('NAmes', 'CollgCr', 'OldTown', 'Edwards', 'Somerst')
# Filter only the interesting locations from the dataset
# Group by neighborhood and find the z-score for 200000 for every location
# Sort the result by zcore
library(dplyr)
houses %>%
    filter(Neighborhood %in% target_neighborhoods) %>%
    group_by(Neighborhood) %>%
    summarise(zscore = abs(z_score(200000, SalePrice))) %>%
    ungroup() %>%
    arrange(zscore)

# Find the location with the z-score closest to 0
best_investment  <-  'College Creek'

## 5. Transforming Distributions ##

standard_deviation <- function(vector) {
    distances  <-  (vector - mean(vector))**2
    sqrt(sum(distances) / length(distances) )
}

library(dplyr)
houses <- houses %>%
    mutate(z_prices = (SalePrice - mean(SalePrice)) / standard_deviation(SalePrice))
z_mean_price  <-  mean(houses$z_prices)
z_stdev_price  <-  standard_deviation(houses$z_prices)

# Transforming 'Lot Area'
houses <- houses %>%
    mutate(z_area = (`Lot Area` - mean(`Lot Area`)) / standard_deviation(`Lot Area`))

z_mean_area  <-  mean(houses$z_area)
z_stdev_area  <-  standard_deviation(houses$z_area)

## 6. The Standard Distribution ##

population  <-  c(0, 8, 0, 8)

standard_deviation <- function(vector) {
    distances  <-  (vector - mean(vector))**2
    sqrt(sum(distances) / length(distances) )
}
mean_pop  <-  mean(population)
stdev_pop  <-  standard_deviation(population)

standardized_pop  <-  (population - mean_pop) / stdev_pop

mean_z  <-  mean(standardized_pop)
stdev_z  <-  standard_deviation(standardized_pop)

## 7. Standardizing Samples ##

sample  <-  c(0, 8, 0, 8)

x_bar  <-  mean(sample)
s  <-  sd(sample)

standardized_sample  <-  (sample - x_bar) / s
stdev_sample  <-  sd(standardized_sample)

## 8. Using Standardization for Comparisons ##

standard_deviation <- function(vector) {
  distances  <-  (vector - mean(vector))**2
  sqrt(sum(distances) / length(distances) )
}

houses <- houses %>%
  mutate(index_1 = SalePrice/ 100000 + 37) %>%
  mutate(index_1 = replace(index_1,  row_number() %% 2 != 0, NA_real_) ) %>%
  mutate(index_2 = SalePrice/ 90000 - 2.8) %>%
  mutate(index_2 = replace(index_2,  row_number() %% 2 == 0, NA_real_) )

mean_index_1  <-  mean(houses$index_1, na.rm = T)
mean_index_2  <-  mean(houses$index_2, na.rm = T)

sd_index_1  <-  standard_deviation(na.omit(houses$index_1))
sd_index_2  <-  standard_deviation(na.omit(houses$index_2))
houses <- houses %>%
  mutate(z_1 = (index_1 - mean_index_1) / sd_index_1 ) %>%
  mutate(z_2 = (index_2 - mean_index_2) / sd_index_2 )

head(houses %>% select(z_1, z_2), 2)

better  <-  'first'

## 9. Converting Back from Z-scores ##

houses_merged <- bind_rows(houses_1,houses_2) %>%
    mutate(z_1 = tidyr::replace_na(z_1,0)) %>%
    mutate(z_2 = tidyr::replace_na(z_2,0)) %>%
    mutate(z_merged = z_1 +  z_2)
mean  <-  50
st_dev  <-  10
houses_merged <- houses_merged %>%
    mutate(transformed = z_merged * st_dev + mean)

mean_transformed  <-  mean(houses_merged$transformed)
stdev_transformed  <-  standard_deviation(houses_merged$transformed)

Data Analyst in R/Step 5 - Probability and Statistics/2. Statistics Intermediate in R Averages and Variability/5. Z-scores.r


#pontos
x1 = c(0,1,2,3)
y1 = c(2,-2,2,0)
plot (x1,y1,"b", main="Pontos")

#bezier
t = seq(0,1,0.01)

x2 = ((1-t)^3 * x1[1] + 3*t*(1-t)^2 * x1[2] + 3*t^2 * (1-t)*x1[3] + t^3*x1[4])
y2 = ((1-t)^3 * y1[1] + 3*t*(1-t)^2 * y1[2] + 3*t^2 * (1-t)*y1[3] + t^3*y1[4])

plot(x2, y2,type="l",xlim=c(0,3), ylim=c(-2,2), main="Bezier")

plot (x1,y1,type="b",xlim=c(0,3), ylim=c(-2,2),col="blue", main="Pontos+Bezier")
lines (x2,y2, type="l", col="red")

#pesos
p1 = (1-t)^3
p2 = 3*t*(1-t)^2
p3 = 3*t^2*(1-t)
p4 = t^3

plot(t, p1, "l", c(0,1), c(0,1), col="cyan", main="Pesos")
lines(t, p2, "l", col="orange")
lines(t, p3, "l", col="green")
lines(t, p4, "l", col="red")


### 多次元尺度構成法の例
### - 人工データによる計量的・非計量的方法の比較

## パッケージの読み込み
require(MASS)
require(lattice)

## 3次元データの作成 (格子状に作成してサンプルする)
## 3次元空間内に2次元の曲面を埋め込む
s <- seq(0, 1.5*pi, length=1000)
mydata <- do.call('rbind',
                  lapply(s, function(t){
                      data.frame(
                          X=seq(sin(t), -sin(t), length=100),
                          Y=seq(cos(t), -cos(t), length=100),
                          Z=t)}
                      )
                  )
mydata$class <- rep(1:8, each=100*1000/8)
mydata <- mydata[sample(nrow(mydata),400),]

## 人工データの視覚化: 図(a-d)
for (i in seq(20,80,by=20)) {
    print(cloud(Z ~ X + Y, data=mydata, groups=class,
                screen=list(z=i, x=-80),distance=.6))
}

## ユークリッド距離の計算
dst <- dist(mydata[,1:3])

## 計量的方法: 図(e)
plot(cmdscale(dst),col=rainbow(8)[mydata$class],
     xlab="axis 1", ylab="axis 2",
     main="Torgerson's MDS")
## 曲面のねじれのため一部の構造がつぶれている

## 非計量的方法: 図(f)
plot(isoMDS(dst)$points,col=rainbow(8)[mydata$class],
     xlab="axis 1", ylab="axis 2",
     main="Kruskal's MDS")
## 曲面を平面上に引き伸ばした尺度が構成されている


bioclite("multtest")
library(multtest)
data(golub)

##Principal component analysis
eigen(cor(golub))$values[1:5]
p<-ncol(data);n<-row(data);nboot<-1000
eigenvalues <- array(dim=c(nboot,p))
for (i in 1:nboot){dat.star <-data[sample(1:n,replace=TRUE),]
eigenvalues[i,] <- eigen(cor(dat.star))$values}
for (j in 1:p) print(quantile(eigenvalues[,j],c(0.025,0.975)))
for (j in 1:5) cat(j,as.numeric(quantile(eigenvalues[,j], + c(0.025,0.975))),"\n" )
sum(eigen(cor(golub))$values[1:2])/38*100
eigen(cor(golub))$vec[,1:2]
pca < princomp(golub, center = TRUE, cor=TRUE, scores=TRUE)
o < order(pca$scores[,2])
golub.gnames[o[1:10],2]
golub.gnames[o[3041:3051],2]

##correlation
corgol<- apply(golub, 1, function(x) cor(x,golub.cl))
o <- order(corgol)
golub.gnames[o[3041:3051],2]

##K-means
data <- data.frame(golub[ccnd3,],golub[zyxin,],golub[829,],golub[808,],golub[2670,])
cl <- kmeans(data, 2,nstart = 10)
cl
fit<-kmeans(data, 2,nstart = 10)
fit$cluster
fit$centers
aggregate(data,by=list(fit$cluster),FUN=mean)
plot(data, col = cl$cluster)
require(cluster)
fit<-pam(x=data,k=8)
fit$clustering
fit$medoids
summary(fit)

##hierarchial clustering
d<-dist(data,method="euclidean")
fit<-hclust(d,method = "ward.D")
plot(fit)
groups<-cutree(fit,k=8)
rect.hclust(fit,k=8,border="red")

##correlation plot visualization
require(corrplot)
corrplot(cor(data[1:2]))

## biplot
biplot(princomp(data,cor=TRUE),pc.biplot=TRUE,cex=0.5,expand=0.8)

##Linear Discriminant Analysis
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,2:11])
> ratio<-2/3
> set.seed(111)
> learnind<-sample(length(golubY), size=floor(ratio*length(golubY)))
> ldaresult<-ldaCMA(X=golubX, y=golubY, learnind=learnind)
> show(ldaresult)
binary Classification with linear discriminant analysis
number of predictions: 13
> ftable(ldaresult)
number of missclassifications:  5
missclassification rate:  0.385
sensitivity: 0.167
specificity: 1
    predicted
true 0 1
   0 7 0
   1 5 1
> plot(ldaresult)

##Quadratic Discriminant Analysis:
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,2:11])
> ratio<-2/3
> set.seed(112)
> learnind<-sample(length(golubY), size=floor(ratio*length(golubY)))
> qdaresult<-qdaCMA(X=golubX,y=golubY,learnind=learnind)
> show(qdaresult)
binary Classification with quadratic discriminant analysis
number of predictions: 13
> ftable(qdaresult)
number of missclassifications:  3
missclassification rate:  0.231
sensitivity: 0
specificity: 0.833
    predicted
true  0  1
   0 10  2
   1  1  0
> plot(qdaresult)

##Diagonal Discriminant Analysis:
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,-1])
> ratio<-2/3
> set.seed(111)
> learnind<-sample(length(golubY), size=floor(ratio*length(golubY)))
> dldaresult<-dldaCMA(X=golubX,y=golubY,learnind=learnind)
> show(dldaresult)
binary Classification with diagonal discriminant analysis
number of predictions: 13
> ftable(dldaresult)
number of missclassifications:  0
missclassification rate:  0
sensitivity: 1
specificity: 1
    predicted
true 0 1
   0 7 0
   1 0 6
> plot(dldaresult)

##Shrunken Centroids Discriminant Analysis
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,-1])
> set.seed(111)
> learnind<-sample(length(golubY), size=floor(2/3*length(golubY)))
> scdaresult<-scdaCMA(X=golubX,y=golubY,learnind=learnind)
> show(scdaresult)
binary Classification with shrunken centroids discriminant analysis
number of predictions: 13
> ftable(scdaresult)
number of missclassifications:  0
missclassification rate:  0
sensitivity: 1
specificity: 1
    predicted
true 0 1
   0 7 0
   1 0 6
> plot(scdaresult)

##Shrinkage Linear Discriminant Analysis:
> library(sda)
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,-1])
> ratio<-2/3
> set.seed(111)
> learnind<-sample(length(golubY), size=floor(ratio*length(golubY)))
> result<-shrinkldaCMA(X=golubX,y=golubY,learnind=learnind)
> show(result)
binary Classification with shrinkage linear discriminant analysis
number of predictions: 13
> ftable(result)
number of missclassifications:  4
missclassification rate:  0.308
sensitivity: 0.333
specificity: 1
    predicted
true 0 1
   0 7 0
   1 4 2
> plot(result)

##Fisher’s Linear Discriminant Analysis
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,2:11])
> ratio<-2/3
> set.seed(111)
> learnind<-sample(length(golubY), size=floor(ratio*length(golubY)))
> fdaresult<-fdaCMA(X=golubX,y=golubY,learnind=learnind,comp=1,plot=TRUE)
> show(fdaresult)
binary Classification with Fisher's linear discriminant
number of predictions: 13
> ftable(fdaresult)
number of missclassifications:  5
missclassification rate:  0.385
sensitivity: 0.5
specificity: 0.714
    predicted
true 0 1
   0 5 2
   1 3 3
> plot(fdaresult)

## Flexible Discriminant Analysis
> data(golub)
> golubY<-golub[,1]
> golubX<-as.matrix(golub[,2:11])
> ratio<-2/3
> set.seed(111)
> learnind<-sample(length(golubY), size=floor(ratio*length(golubY)))
> result<-flexdaCMA(X=golubX,y=golubY,learnind=learnind,comp=1)
> show(result)
binary Classification with flexible discriminant analysis
number of predictions: 13
> ftable(result)
number of missclassifications:  5
missclassification rate:  0.385
sensitivity: 0.5
specificity: 0.714
    predicted
true 0 1
   0 5 2
   1 3 3
> plot(result)


## Are x,y inside Sierpinski carpet (and where)? (1-yes, 0-no)
inSC <- function(x, y) {
  while(TRUE) {
    if(!x||!y) {return(1)}
    if(x%%3==1&&y%%3==1) {return(0)}
    x=x%/%3; y=y%/%3;
  } return(0);
}
## Plotting Sierpinski carpet fractal. aev 4/1/17
## ord - order, fn - file name, ttl - plot title, clr - color
pSierpinskiC <- function(ord, fn="", ttl="", clr="navy") {
  m=640; abbr="SCR"; dftt="Sierpinski carpet fractal";
  n=3^ord-1; M <- matrix(c(0), ncol=n, nrow=n, byrow=TRUE);
  cat(" *** START", abbr, date(), "\n");
  if(fn=="") {pf=paste0(abbr,"o", ord)} else {pf=paste0(fn, ".png")};
  if(ttl!="") {dftt=ttl}; ttl=paste0(dftt,", order ", ord);
  cat(" *** Plot file:", pf,".png", "title:", ttl, "\n");
  for(i in 0:n) {
    for(j in 0:n) {if(inSC(i,j)) {M[i,j]=1}
  }}
  plotmat(M, pf, clr, ttl);
  cat(" *** END", abbr, date(), "\n");
}
## Executing:
pSierpinskiC(5);


###################################################################################################
# Project:                 GV300 - LABa02 sessions - Problem Set 2 answers                        #
#                                                                                #
# University:              University of Essex                                                    #
#                                                                                #
# Programmer:              Lorenzo Crippa                                                         #
#                                                                                #
###################################################################################################

# exercise 6
y <- 0:7 # the number of successful applications in 7 countries can go from 0 to 7
mass.function <- dbinom(y, size = 7, prob = 0.3) # probabilities associated with each value of x

# check:
sum(mass.function) # 1, ok

df <- data.frame(y, prob=mass.function) # turn the values into a data frame

plot(df$y, df$prob, type = "l", frame = F, ylab = "probability", xlab = "y",
     main = "Probability mass function")

# Expected value is the mean: n*p:
mean <- 7*0.3 # 2.1

# variance is n*p*(1-p):
var <- 7*0.3*0.7 # 1.47

############
# GV300: Problem set 2, exercise 7

# draw 1000 random observations from a binomial distribution with n = 7 and p = 0.3

obs <- rbinom(1000, size = 7, p = 0.3)

hist(obs, probability = T)
lines(df$y, df$prob, col = "red")

mean(obs) # 2.205, very close to 2.1
var(obs) # 1.49, very close to 1.47
############


### 多次元尺度構成法の例
### - おむすびに関するアンケートデータ

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

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

## データの内容を表示
## print(raw)    # 全データの表示
head(raw,n=4) # 最初の4県を表示
tail(raw,n=4) # 最後の4県を表示

## 非計量的多次元尺度構成法: 図(a)
dst <- dist(sqrt(raw)) # Hellinger距離
mds <- isoMDS(dst)     # 2次元のユークリッド座標を構成
## cmdscaleとは異なり，座標はpointsに，評価値はstressに収められている
plot(mds$points,type='n',xlab="axis 1",ylab="axis 2")
text(mds$points,labels=rownames(mds$points),cex=.8)

## Shepard ダイアグラム: 図(b)
shprd <- Shepard(dst, mds$points)
plot(shprd, pch = 20, col="blue",
     xlab="Observed Dissimilarity", ylab="Estimated Distance")
lines(shprd$x, shprd$yf, type = "S", col="red", lwd=2)

## マンハッタン距離による尺度構成: 図(c)
mds <- isoMDS(dst, p=1)
plot(mds$points,type='n',main="p=1",xlab="axis 1",ylab="axis 2")
text(mds$points,labels=rownames(mds$points),cex=.8)

## 近似的な最大距離による尺度構成: 図(d)
mds <- isoMDS(dst, p=10)
plot(mds$points,type='n',main="p=10",xlab="axis 1",ylab="axis 2")
text(mds$points,labels=rownames(mds$points),cex=.8)

## 3次元尺度構成: 図(e)
mds <- isoMDS(dst, k=3)
opar <- par(mfrow=c(2,2),mar=c(4,4,1,1))
plot(mds$points[,c(1,2)],type='n',
     xlab="axis 1",ylab="axis 2", xlim=c(-2.5,2.5),asp=1)
text(mds$points[,c(1,2)],labels=rownames(mds$points),cex=.5)
plot.new()
plot(mds$points[,c(1,3)],type='n',
     xlab="axis 1",ylab="axis 3", xlim=c(-2.5,2.5),asp=1)
text(mds$points[,c(1,3)],labels=rownames(mds$points),cex=.5)
plot(mds$points[,c(2,3)],type='n',
     xlab="axis 2",ylab="axis 3", xlim=c(-2.5,2.5),asp=1)
text(mds$points[,c(2,3)],labels=rownames(mds$points),cex=.5)
par(opar)

## 3次元尺度のShepard ダイアグラム: 図(f)
shprd <- Shepard(dst, mds$points)
plot(shprd, pch = 20, col="blue",
     xlab="Observed Dissimilarity", ylab="Estimated Distance")
lines(shprd$x, shprd$yf, type = "S", col="red", lwd=2)