# two samples (group) t.test
ttest.fun <- function(theta, x, y) {
  # parameters
	mu1 <- theta[1]
	sd1 <- theta[2]
	mu2 <- theta[3]
	sd2 <- theta[4]
	nu <- theta[5]

  # no negative standard deviations, right?!
	if(sd1 <=0 | sd2 <= 0) { return(-Inf) }

  # priors
  sigma <- sd(c(x,y))
  log.prior <- dnorm(mu1, sd = sigma*1e3,  log=T) +                   # mu1 ~ N(0, sd*1e3)
               dunif(sd1, min= sigma*1e-3, max=sigma*1e3, log=T) +    # sd1 ~ unif(sd*1e-3, sd*1e3)
  				     dnorm(mu2, sd = sigma*1e3,  log=T) +                   # mu2 ~ N(0, sd*1e3)
               dunif(sd2, min= sigma*1e-3, max=sigma*1e3, log=T) +    # sd2 ~ unif(sd*1e-3, sd*1e3)
  				     dexp((nu-1), 1/29, log=T)                              # nu  ~ exp(1/29) + 1

  # likelihood
	log.like <- sum(dt({x-mu1}/sd1, df=nu, log=T) - log(sd1)) +         # x ~ T(mu1, sd1, nu) ~ t({x-mu}/sd, nu)/sd
              sum(dt({y-mu2}/sd2, df=nu, log=T) - log(sd2))           # y ~ T(mu1, sd1, nu) ~ t({x-mu}/sd, nu)/sd

  # posterior
	ll <- log.like + log.prior

	ifelse(is.na(ll) | is.nan(ll), -Inf, ll)                            # deal with the missing values
}

# one sample (group) t.test
# or two dependent (paired) t.test
ttest.1g.fun <- function(theta, x) {
  # parameters
	mu <- theta[1]
	sd <- theta[2]
	nu <- theta[3]

  # no negative standard deviations, right?!
	if(sd <=0) { return(-Inf) }

  # priors
  log.prior <- dnorm(mu, sd = sd*1e3,  log=T) +                       # mu ~ N(0, sd*1e3)
               dunif(sd, min= sd*1e-3, max=sd*1e3, log=T) +           # sd1 ~ unif(sd*1e-3, sd*1e3)
  				     dexp((nu-1), 1/29, log=T)                              # nu  ~ exp(1/29) + 1

  # likelihood
	log.like <- sum(dt({x-mu}/sd, df=nu, log=T) - log(sd))              # x ~ T(mu, sd, nu) ~ t({x-mu}/sd, nu)/sd

  # posterior
	ll <- log.like + log.prior

	ifelse(is.na(ll) | is.nan(ll), -Inf, ll)                            # deal with the missing values
}

# accuracy goes 1/sqrt(nmc),
# therefore may appropriate round(out, int(sqrt(nmc) % 10))
bayes.t.test <- function(x, y=NULL, nmc=20000, nbi=20000) {
  if(is.null(y)) {                                                   # one group
    out <- bayes::mcmc(ttest.1g.fun, c(mean(x), sd(x), 5), nmc, nbi, x=x)
    colnames(out) <- c("mu", "sd", "nu")
  } else {                                                           # two groups
    out <- bayes::mcmc(ttest.fun, c(mean(x), sd(x), mean(y), sd(y), 5), nmc, nbi, x=x, y=y)
    colnames(out) <- c("mu1", "sd1", "mu2", "sd2", "nu")
  }
  return(out)
}


# Example : 5   Chapter : 8.3     Page No: 437
# Linear Algebra in Economy
A<-matrix(c(0,1,4,0),ncol=2)
lambda<-eigen(A)$values
print("Lambda max is ")
print(lambda[1])
I<-matrix(c(1,0,0,1),ncol=2)
A1<-solve(I-A)
print(A1)
#The answers may vary due to rounding off values


expected <- function(size) {
  result <- 0
  for (i in 1:size) {
    result <- result + factorial(size) / size^i / factorial(size -i)
  }
  result
}

knuth <- function(size) {
  v <- sample(1:size, size, replace = TRUE)

  visit <- vector('logical',size)
  place <- 1
  visit[[1]] <- TRUE
  steps <- 0

  repeat {
    place <- v[[place]]
    steps <- steps + 1
    if (visit[[place]]) break
    visit[[place]] <- TRUE
  }
  steps
}

cat(" N    average    analytical     (error)\n")
cat("===  =========  ============  ==========\n")
for (num in 1:20) {
  average <- mean(replicate(1e6, knuth(num)))
  analytical <- expected(num)
  error <- abs(average/analytical-1)*100

  cat(sprintf("%3d%11.4f%14.4f  ( %4.4f%%)\n", num, round(average,4), round(analytical,4), round(error,2)))
}


get_l_a0_bernoulli <- function(y0, n0, cc, dd, a_0){
  ans <- lbeta(a_0 * y0 + cc, a_0 *(n0 -y0) + dd)-lbeta(cc, dd)
  return(ans)
}
posterior_a0_Bernoulli_2 <- function(a_0, y0, n0, y, n, cc, dd, delta, nu, log = FALSE){
  term1 <- get_l_a0_bernoulli(y0 = y0, n0 = n0, cc = cc, dd = dd, a_0 = a_0)
  term2 <- dbeta(a_0, shape1 = delta, shape2 = nu, log = TRUE)
  term3 <- lbeta(a_0 * y0 + y + cc - 1, a_0 * (n0 - y0) + dd + (n-y) - 1)
  ans <- -term1 + term2 + term3
  if(!log) ans <- exp(ans)
  return(ans)
}
post_a0_2 <- function(x) {
  posterior_a0_Bernoulli_2(a_0 = x, y0 = y_0, n0 = N_0,
                           y = y, n = N, cc = cc, dd = dd, nu = nu, delta = delta)
}
post_a0_2  <- Vectorize(post_a0_2)
post_a0_2  <- Vectorize(post_a0_2)
curve(post_a0_2)

K2 <- integrate(post_a0_2, 0, 1)$value
norm_post_a0_2 <- function(x) post_a0_2(x)/K2
norm_post_a0_2  <- Vectorize(norm_post_a0_2)
curve(norm_post_a0_2)


#Copyright (c) 2016 Riccardo Francescato
#data from example page 144
a = 4 # number of rows
b = 6 # number of columns
N = a*b
alpha = .05
RawData= c(90.3,89.2, 98.2, 93.9, 87.4, 97.9,92.5, 89.5, 90.6, 94.7, 87.0, 95.8,85.5, 90.8, 89.6, 86.2, 88.0, 93.4,82.5, 89.5, 85.6, 87.4, 78.9, 90.7)
data = matrix(RawData,# the data elements
	nrow=a,              # number of rows
	ncol=b,              # number of columns
	byrow = TRUE)        # fill matrix by rows

SStot = sum(data^2) - sum(data)^2/N
SStreat = 0
for(i in 1:a){
	SStreat = SStreat + sum(data[i,])^2
}
SStreat = SStreat *(1/b) - sum(data)^2/N
SSblock = 0
for(i in 1:b){
	SSblock = SSblock + sum(data[,i])^2
}
SSblock = SSblock *(1/a) - sum(data)^2/N
SSerr = SStot - SStreat - SSblock
MStreat = SStreat/(a-1)
MSblock = SSblock/(b-1)
MSerr = SSerr/((a-1)*(b-1))

F0 <- MStreat/MSerr
Fa <- qf(alpha,df1=a-1,df2=((a-1)*(b-1)),lower.tail=F)

if(F0 > Fa) print(paste0(" reject H0 ", F0)) else print(paste0(" Accept H0 ", F0))
cat(paste0(" Treatments  SS: ",SStreat," Df: ", a-1 ," MS: ",MStreat, " F0: ",F0,
		"\n Blocks  SS: ",SSblock," Df: ", b-1 ," MS: ",MSblock,
		"\n Error  SS: ",SSerr," Df: ", (a-1)*(b-1) ," MS: ",MSerr,
		"\n Total  SS: ",SStot," Df: ", (a*b)-1))

delivery.df = data.frame(
  Treatment = c(rep("1", b), rep("2", b), rep("3", b), rep("4", b)),
  Block = c(rep(c("1", "2", "3", "4","5","6"), a)),
  Data = RawData
)
delivery.mod1 = lm(Data ~ Treatment+Block, data = delivery.df)
anova(delivery.mod1)


rm(list = ls(all = TRUE))

library(ggplot2)

# Calculate the integral from 0 to 1 of:

# f(x) = sqrt(1 - x ^ 2)

# Case 1:
# G(x) = sqrt(1 - x ^ 2) / ((3 / 2) * (1 - x ^ 2))
# f(x) = (3 / 2) * (1 - x ^ 2)

x = seq(0, 1, by = 0.001)

f = function(x) {
  (3 / 2) * (1 - x ^ 2)}

optimize(f, c(-100, 100), maximum = TRUE)

y1 = 1.5 * dunif(x, 0, 1)
y2 = f(x)
df <- data.frame(x, y1, y2)

g <- ggplot(df, aes(x)) +
  geom_line(aes(y = y1), colour = "red") +
  geom_line(aes(y = y2), colour = "green")
g

x = seq(0, 10, by = 0.1)

hx = function(x) {
  ((3 / 2) * (1 - x ^ 2)) / dunif(x, 0, 1)
  }
y1 = hx(x)
df <- data.frame(x, y1)
g <- ggplot(df, aes(x)) +
  geom_line(aes(y = y1), colour = "blue")
g

optimize(hx, c(0, 1), maximum = TRUE)
## hx is maxed at x = 1.5

sample.x = runif(10000,0,1)
accept = c()
sample.accept = c()

for(i in 1:length(sample.x)){
  U = runif(1, 0, 1)
  if(dunif(sample.x[i], 0, 1) * (1.5) * U <= f(sample.x[i])) {
    accept[i] = 'Yes'
    sample.accept[i] = sample.x[i]
  }
  else {
    accept[i] = 'No'
    sample.accept[i] = 0
  }
}

t = data.frame(sample.x,
               accept = factor(accept, levels = c('Yes', 'No')),
               sample.accept)

t_acc = t[accept == 'Yes',]

G = function(x) {
  (sqrt(1 - x ^ 2)) / ((1.5) * (1 - x ^ 2))
}

n_acc = length(which(t$accept == 'Yes'))

I = sum(G(t_acc$sample.accept)) / n_acc
I

ff = function(x) {
  (sqrt(1 - x ^ 2))
}

Ireal = integrate(ff, 0, 1)
Ireal

# Variance
S = sqrt(sum((G(t_acc$sample.accept)
              - sum(G(t_acc$sample.accept)) / n_acc) ^ 2) / (n_acc - 1))
S

# Case 2:
# G(x) =  sqrt(1 - x ^ 2) / ((5 / 4) * (1 - x ^ 4))
# f(x) = (5 / 4) * (1 - x ^ 4)

x = seq(0, 1, by = 0.001)

f = function(x) {
  (5 / 4) * (1 - x ^ 4)
}

optimize(f, c(-100, 100), maximum = TRUE)
## f is maxed at x = 1.25

y1 = 1.25 * dunif(x, 0, 1)
y2 = f(x)
df <- data.frame(x, y1, y2)

g <- ggplot(df, aes(x)) +
  geom_line(aes(y = y1), colour = "red") +
  geom_line(aes(y = y2), colour = "green")
g

x = seq(0, 10, by = 0.1)

hx = function(x) {
  ((5 / 4) * (1 - x ^ 4)) / dunif(x, 0, 1)
}

optimize(hx, c(0, 1), maximum = TRUE)
## hx is maxed at x = 1.25

y1 = hx(x)
df <- data.frame(x, y1)
g <- ggplot(df, aes(x)) +
  geom_line(aes(y = y1), colour = "blue")
g

sample.x = runif(10000,0,1)
accept = c()
sample.accept = c()

for(i in 1:length(sample.x)){
  U = runif(1, 0, 1)
  if(dunif(sample.x[i], 0, 1) * (1.25) * U <= f(sample.x[i])) {
    accept[i] = 'Yes'
    sample.accept[i] = sample.x[i]
  }
  else {
    accept[i] = 'No'
    sample.accept[i] = 0
  }
}

t = data.frame(sample.x,
               accept = factor(accept, levels = c('Yes', 'No')),
               sample.accept)

t_acc = t[accept == 'Yes',]

G = function(x) {
  sqrt(1 - x ^ 2) / ((5 / 4) * (1 - x ^ 4))
}

n_acc = length(which(t$accept == 'Yes'))

I = sum(G(t_acc$sample.accept)) / n_acc
I

Ireal = integrate(ff, 0, 1)
Ireal

# Variance
S2 = sqrt(sum((G(t_acc$sample.accept)
              - sum(G(t_acc$sample.accept)) / n_acc) ^ 2) / (n_acc - 1))
S2

# Case 3:
# G(x) =  sqrt(1 - x ^ 2) / ((3 / 4) * (2 - 2 * x ^ 2))
# f(x) = (3 / 4) * (2 - 2 * x ^ 2)

x = seq(0, 1, by = 0.001)

f = function(x) {
  (3 / 4) * (2 - 2 * x ^ 2)
}

optimize(f, c(0, 1), maximum = TRUE)
## f is maxed at x = 1.5

y1 = 1.5 * dunif(x, 0, 1)
y2 = f(x)
df <- data.frame(x, y1, y2)

g <- ggplot(df, aes(x)) +
  geom_line(aes(y = y1), colour = "red") +
  geom_line(aes(y = y2), colour = "green")
g

x = seq(0, 10, by = 0.1)

hx = function(x) {
  ((3 / 4) * (2 - 2 * x ^ 2)) / dunif(x, 0, 1)
}

optimize(hx, c(0, 1), maximum = TRUE)
## hx is maxed at x = 1.5

y1 = hx(x)
df <- data.frame(x, y1)
g <- ggplot(df, aes(x)) +
  geom_line(aes(y = y1), colour = "blue")
g

sample.x = runif(10000,0,1)
accept = c()
sample.accept = c()

for(i in 1:length(sample.x)){
  U = runif(1, 0, 1)
  if(dunif(sample.x[i], 0, 1) * (1.5) * U <= f(sample.x[i])) {
    accept[i] = 'Yes'
    sample.accept[i] = sample.x[i]
  }
  else {
    accept[i] = 'No'
    sample.accept[i] = 0
  }
}

t = data.frame(sample.x,
               accept = factor(accept, levels = c('Yes', 'No')),
               sample.accept)

t_acc = t[accept == 'Yes',]

G = function(x) {
  sqrt(1 - x ^ 2) / ((3 / 4) * (2 - 2 * x ^ 2))
}

n_acc = length(which(t$accept == 'Yes'))

I = sum(G(t_acc$sample.accept)) / n_acc
I

Ireal = integrate(ff, 0, 1)
Ireal

# Variance
S3 = sqrt(sum((G(t_acc$sample.accept)
               - sum(G(t_acc$sample.accept)) / n_acc) ^ 2) / (n_acc - 1))
S3

S ; S2 ; S3

# Using the importance integration method, the best decomposition
# of the integral function is the one used in Case 2.


library(tidyverse)

bernstein = function(k,n){
  return(function(x){
    choose(n,k)*x^k*(1-x)^(n-k)}
  )
}

N = 5
a = sapply(0:N,function(x) bernstein(x,N))

z = sapply(a, function(f){
  t = seq(0,1,0.02)
  return(f(t))
})

zd = data.frame(t = seq(0,1,0.02),z)
gzd = gather(zd,"key","value",-1)
p = ggplot(data =gzd) +geom_line(aes(x = t,y = value, color = key))
print(p)

#---just use the dbinom to get it
t = seq(0,1,0.02)
s = sapply(t, function(p){dbinom(0:N,N,p)})
ss = data.frame(t = t, t(s))
gss = gather(ss,"key","value",-1)
p = ggplot(data =gss) +geom_line(aes(x = t,y = value, color = key))
print(p)

#pick N+1 random points
N = 3
t = seq(0,1,0.02)
s = sapply(t, function(p){dbinom(0:N,N,p)})

x = runif(N+1,max = 10)
y = runif(N+1,max = 10)
bx = matrix(x,ncol = N+1) %*% s
by = matrix(y,ncol = N+1) %*% s
plot(x,y,col = "red")
lines(x,y,col = "grey")
lines(bx,by)

#include the lower order
N = 5
t = seq(0,1,0.02)
s.list = sapply(1:N,
               function(w){
                 return(sapply(t,function(p){dbinom(0:w,w,p)}))
                 })

#x = runif(N+1,max = 10)
x = c(2.6122230, 8.9649724, 2.3694770, 8.1857733, 0.1079161, 6.3198825)
#y = runif(N+1,max = 10)
y = c(9.127837, 8.970236, 2.930961, 3.065698, 6.277990, 8.775528)

bx = matrix(x,ncol = N+1) %*% s.list[[N]]
by = matrix(y,ncol = N+1) %*% s.list[[N]]

plot(x,y,col = "red")
lines(x,y,col = "grey")
lines(bx,by)
colors = c('lightblue','pink','lightgreen')

for(k in seq(3,5)){
  bxq = matrix(x[1:k],ncol = k) %*% s.list[[k-1]]
  byq = matrix(y[1:k],ncol = k) %*% s.list[[k-1]]
  lines(bxq,byq,col = colors[k-2])
}

plot(x,y,col = "red")
colors = c('grey','lightblue','pink','lightgreen','black')

for(k in seq(2,6)){
  bxq = matrix(x[1:k],ncol = k) %*% s.list[[k-1]]
  byq = matrix(y[1:k],ncol = k) %*% s.list[[k-1]]
  lines(bxq,byq,col = colors[k-1])
}

plot(x,y,col = "red")
lines(x,y,col = "grey")
lines(bx,by)
colors = c('lightblue','pink','lightgreen')
for(k in seq(2,4)){
  for(j in 1:(N+1-k)){
    bxq = matrix(x[j:(j+k)],ncol = k+1) %*% s.list[[k]]
    byq = matrix(y[j:(j+k)],ncol = k+1) %*% s.list[[k]]
    lines(bxq,byq,col = colors[k-1] )
  }
}


days = seq(from = 1, to = 260)
type = c(1,2)
homeWork = rnorm(260, mean=10, sd=1.5)
workHome = rnorm(260, mean=10, sd=2.0)

consumption = data.frame(days, type, consumption = c(homeWork, workHome))
#write.csv(file="consumption.csv", x=consumption)

consumption = read.csv("consumption.csv")

homeWork = consumption[consumption$type == 1,]
workHome = consumption[consumption$type == 2,]

png(filename="homeWork.plot.png")
  plot(homeWork$day, homeWork$consumption)
dev.off()

png(filename="homeWork.hist.png")
  hist(homeWork$consumption)
dev.off()

png(filename="workHome.plot.png")
  plot(workHome$day, workHome$consumption)
dev.off()

png(filename="workHome.hist.png")
  hist(workHome$consumption)
dev.off()

normal.lik<-function(mu,sigma,y){
  sigma <- max(sigma, 0.0001)
  n<-length(y)
  logl <- sum(log(dnorm(y, mean = mu, sd = sigma)))/n
  return(-logl)
}
normal.lik.muvar <- function (theta,y){
  normal.lik(theta[1],theta[2],y)
}
v.normal.lik <- function (mu, sigma, y){
  mapply(function(m,s) normal.lik(m,s,y), mu, sigma)
}

library(RColorBrewer)
plotMLE <- function(data, x, y, steps = 20, levels = 10000) {
  x = seq(x[1], x[2], length= 20)
  y = seq(y[1], y[2], length= 20)
  f = function(x, y) {
    v.normal.lik(x,y,data)
  }
  z = outer(x, y, f)
  z[is.na(z)] = 0
  contour(x,y,z,col=rev(brewer.pal(11, "RdYlBu")), nlevels = levels,
    xlab="mean", ylab="standard deviation")
}

png(filename="homeWork.likelihood.png")
  plotMLE(homeWork$consumption, x=c(5,15),y=c(0,5), levels = 2000)
dev.off()
optim(c(12,4),normal.lik.muvar,y=homeWork$consumption,method="BFGS")
png(filename="homeWork.likelihood.withlines.png")
  plotMLE(homeWork$consumption, x=c(5,15),y=c(0,5), levels = 2000)
  abline(h=1.70105, lty=2)
  abline(v=10.01983, lty=2)
dev.off()

plotGaussian <- function(start = -1, end = 1, u, sigma, scale, color = "black"){
  x <- seq(start, end, length=100)
  hx <- dnorm(x, mean = u, sd = sigma)*scale
  lines(x, hx, type="l", lty=2, xlab="x value", ylab="Density", main="Gaussian", col = color)
}
plotArea <- function(u, sigma, sigmaSize, color){
  x <- seq(-4, 4, length=100)
  hx <- dnorm(x, mean = u, sd = sigma)
  l <- -(sigma*sigmaSize)
  r <- (sigma*sigmaSize)
  i <- x >= l & x <= r
  polygon(c(l,x[i],r), c(0,hx[i],0), col=color)
}

png(filename="homeWork.hist.model.png")
  plot.new()
  hist(homeWork$consumption)
  plotGaussian(5, 15, 10, 1.7, 250, "red")
dev.off()

#WORK HOME

png(filename="workHome.likelihood.png")
  plotMLE(workHome$consumption, x=c(5,15),y=c(0,5), levels = 2000)
dev.off()
optim(c(12,4),normal.lik.muvar,y=workHome$consumption,method="BFGS")
png(filename="workHome.likelihood.withlines.png")
  plotMLE(workHome$consumption, x=c(5,15),y=c(0,5), levels = 2000)
  abline(h=1.7274, lty=2)
  abline(v=9.87, lty=2)
dev.off()

# DAILY

days = seq(from = 1, to = 260)
daily = homeWork$consumption + workHome$consumption
consumption = data.frame(days, consumption = daily)
png(filename="daily.plot.png")
  plot(consumption$day, consumption$consumption)
dev.off()

optim(c(12,4),normal.lik.muvar,y=consumption$consumption,method="BFGS")

png(filename="daily.hist.png")
plot.new()
  hist(consumption$consumption)
  plotGaussian(10, 30, 19.899697, 2.421108, 270, "red")
dev.off()

png(filename="daily.hist.png")
plot.new()
  hist(consumption$consumption)
  plotGaussian(10, 30, 19.899697, 2.421108, 270, "red")
  abline(v=25, lty=2, col ="green")
dev.off()

pnorm(25, mean = 19.899697, sd = 2.421108)
pnorm(25, mean = 19.899697, sd = 2.421108, lower.tail = FALSE)


data("tips", package="reshape2")
head(tips)
unique(tips$sex)
unique(tips$day)
#t-tests
t.test(tips$tip, alternative="two.sided", mu=2.5)
require(ggplot2)
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)

t.test(tips$tip, alternative="greater", mu=2.5)

aggregate(tip ~ sex, data=tips, mean)
aggregate(tip ~ sex, data=tips, var)
#shapiro test will tell us whether the data is normally distributed
shapiro.test(tips$tip)
shapiro.test(tips$tip[tips$sex == "Female"])
shapiro.test(tips$tip[tips$sex == "Male"])
ggplot(tips, aes(x=tip, fill=sex)) + geom_histogram(binwidth=.5, alpha=1/2)

ansari.test(tip ~ sex, tips)
t.test(tip ~ sex, data=tips, var.equal=TRUE)

require(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)))
tipSummary

ggplot(tipSummary,aes(x=tip.mean, y=sex)) + geom_point() +
  geom_errorbarh(aes(xmin=Lower, xmax=Upper), height=.2)
#If you can draw a straight line through the confidence intervals of two groups, it means the groups are pretty much equal in terms of distribution

library(UsingR)
head(father.son)
t.test(father.son$fheight, father.son$sheight, paired=TRUE)
#using ANOVA when you want to test for more than one value in a field
tipAnova <- aov(tip ~ day - 1, tips) # -1 here is important to get rid of the intercept!
tipIntercept <- aov(tip ~ day, tips)
tipAnova$coefficients
tipIntercept$coefficients

summary(tipAnova)
#visualizing ANOVA
tipsByDay <- ddply(tips, "day", summarize,
                   tip.mean=mean(tip), tip.sd=sd(tip),
                   Length=NROW(tip),
                   tfrac=qt(p=.90, 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_errobarh(aes(xmin=Lower, xmax=Upper), height=.3)


## 1. Indexing Vectors by Position ##

final_scores <- c(88, 87.66667, 86, 91.33333, 84, 91, 89.33333)
stem_grades<-final_scores[1:2]
non_stem_grades<-final_scores[3:7]
avg_stem_grades<-mean(stem_grades)
avg_non_stem_grades<-mean(non_stem_grades)

## 2. Numeric and Character Data Types ##

typeof(final_scores)
math_chemistry<-c('math','chemistry')
typeof(math_chemistry)
class_names<-c('math','chemistry','writing','art','history','music','physical_education')

## 3. Naming Elements of a Vector ##

class_names <- c("math", "chemistry", "writing", "art", "history", "music", "physical_education")
final_scores <- c(88, 87.66667, 86, 91.33333, 84, 91, 89.33333)
names(final_scores)<-class_names
final_scores

## 4. Indexing Vectors Using Names ##

liberal_arts<-final_scores[c('writing','history')]
fine_arts<-final_scores[c('art','music')]
mean(liberal_arts)
mean(fine_arts)

## 5. Comparing Values And Logical Data Types ##

liberal_arts <- final_scores[c("writing", "history")]
fine_arts <- final_scores[c("art", "music")]
mean(liberal_arts)>mean(fine_arts)

## 6. Comparing Single Values Against Vectors ##

gpa<-mean(final_scores)
above_average<-final_scores>gpa
above_average

## 7. Logical Indexing ##

gpa <- mean(final_scores)
above_average <- (gpa < final_scores)
best_grades<-final_scores[above_average]
best_grades

## 8. Performing Arithmetic with Vectors ##

tests <- c(76, 89, 78, 88, 79, 93, 89)
homework <- c(85, 90, 88, 79, 88, 95, 74)
projects <- c(77, 93, 87, 90, 77, 82, 80)
johnny_scores<-(tests+homework+projects)/3
mean(johnny_scores)

## 9. Vector Recycling ##

tests <- c(76, 89, 78)
homework <- c(85, 90, 88, 79, 88, 95, 74)
projects <- c(77, 93, 87, 90, 77, 82, 80)
recycling<-tests+homework+projects

## 10. Appending Elements To A Vector ##

tests <- c(76, 89, 78)
homework <- c(85, 90, 88, 79, 88, 95, 74)
projects <- c(77, 93, 87, 90, 77, 82, 80)

class_names <- c("math", "chemistry", "writing", "art", "history", "music", "physical_education")
tests<-c(tests,89,79,93,89)
kate_grades<-(tests+homework+projects)/3
names(kate_grades)<-class_names
kate_gpa<-mean(kate_grades)
kate_low_grades<-kate_grades[(kate_gpa>kate_grades)]
kate_low_grades


# Statistics

# A. stats with geoms
# 1. Smoothing
# Amend the plot to add a smooth layer
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  geom_smooth()

# Amend the plot. Use lin. reg. smoothing; turn off std err ribbon
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  geom_smooth(method = "lm", se = FALSE)

# Amend the plot. Swap geom_smooth() for stat_smooth(). Shows that the linear model (lm) can be created with either method
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  stat_smooth(method = "lm", se = FALSE)

# 2. Grouping variables
# Using mtcars, plot mpg vs. wt, colored by fcyl
ggplot(mtcars, aes(x = wt, y = mpg, color = fcyl)) +
  # Add a point layer
  geom_point() +
  # Add a smooth lin reg stat, no ribbon
  stat_smooth(method = "lm", se = FALSE)

# Amend the plot to add another smooth layer with dummy grouping
ggplot(mtcars, aes(x = wt, y = mpg, color = fcyl)) +
  geom_point() +
  stat_smooth(method = "lm", se = FALSE) +
  stat_smooth(aes(group = 1), method = "lm", se = FALSE) # shows a dummy curve that has used all of the data points for one curve

# 3. Modifying stat_smooth
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  # Add 3 smooth LOESS stats, varying span & color. Providing span parameter relates to the number of data points that are using. Shorter
  # span will include more of the noise across the time series and could result in some overfitting
  stat_smooth(se = FALSE, span = 0.9, color = "red") +
  stat_smooth(se = FALSE, span = 0.6, color = "green") +
  stat_smooth(se = FALSE, span = 0.3, color = "blue")

# Amend the plot to color by fcyl
ggplot(mtcars, aes(x = wt, y = mpg)) +
  geom_point() +
  # Add a smooth LOESS stat, no ribbon
  stat_smooth(se = FALSE) +
  # Add a smooth lin. reg. stat, no ribbon
  stat_smooth(method = "lm", se = FALSE)

# Amend the plot
ggplot(mtcars, aes(x = wt, y = mpg, color = fcyl)) +
  geom_point() +
  # Map color to dummy variable "All"
  stat_smooth(se = FALSE, aes(color = "All")) +
  stat_smooth(method = "lm", se = FALSE)

# 4. Modufying stat_smooth 2
# Using Vocab, plot vocabulary vs. education, colored by year group
ggplot(Vocab, aes(x = education, y = vocabulary, color = year_group)) +
  # Add jittered points with transparency 0.25
  geom_jitter(alpha = 0.25) +
  # Add a smooth lin. reg. line (with ribbon)
  stat_smooth(method = "lm")

# Amend the plot
ggplot(Vocab, aes(x = education, y = vocabulary, color = year_group)) +
  geom_jitter(alpha = 0.25) +
  # Map the fill color to year_group, set the line size to 2
  stat_smooth(method = "lm", aes(fill = year_group), size = 2)

# B. stats sum and quantile
# 1. Quantiles
ggplot(Vocab, aes(x = education, y = vocabulary)) +
  geom_jitter(alpha = 0.25) +
  # Add a quantile stat, at 0.05, 0.5, and 0.95
  stat_quantile(quantiles = c(0.05, 0.5, 0.95))

# Amend the plot to color by year_group. Quantile regression helps to provide a high level overview of the data
ggplot(Vocab, aes(x = education, y = vocabulary, color = year_group)) +
  geom_jitter(alpha = 0.25) +
  stat_quantile(quantiles = c(0.05, 0.5, 0.95))

# 2. Using stat_sum()
# Replaces the overlapping data points with a size variable attribute e.g. if a large number of data points are given the same value then the
# data point will be provided a larger size relative to other data points that might be less popular

# Run this, look at the plot, then update it
ggplot(Vocab, aes(x = education, y = vocabulary)) +
  # Replace this with a sum stat
  # geom_jitter(alpha = 0.25)
  stat_sum()

ggplot(Vocab, aes(x = education, y = vocabulary)) +
  stat_sum() +
  # Add a size scale, from 1 to 10
  scale_size(range = c(1, 10))

# Amend the plot to group by education
ggplot(Vocab, aes(x = education, y = vocabulary, group = education)) +
  stat_sum(aes(size = ..prop..)) # size value of proportion of the whole dataset

# 3. stats outside geoms
# 1. Preparations
# From previous step
posn_j <- position_jitter(width = 0.2)
posn_d <- position_dodge(width = 0.1)
posn_jd <- position_jitterdodge(jitter.width = 0.2, dodge.width = 0.1)

# Create the plot base: wt vs. fcyl, colored by fam
p_wt_vs_fcyl_by_fam <- ggplot(mtcars, aes(x = fcyl, y = wt, color = fam))

# Add a point layer
p_wt_vs_fcyl_by_fam +
  geom_point()

# 2. Using position objects from preparations step
# Add jittering only
p_wt_vs_fcyl_by_fam +
  geom_point(position = posn_j)

# Add dodging only
p_wt_vs_fcyl_by_fam +
  geom_point(position = posn_d)

# Add jittering and dodging
p_wt_vs_fcyl_by_fam +
  geom_point(position = posn_jd)

# 3. Plotting variations
# mean_sdl(), calculates multiples of the standard deviation and mean_cl_normal() calculates the t-corrected 95% CI
# Arguments to the data function are passed to stat_summary()'s fun.args argument as a list.
p_wt_vs_fcyl_by_fam_jit +
  # Add a summary stat of std deviation limits
  stat_summary(fun.data = mean_sdl, fun.args = list(mult = 1), position = posn_d)

p_wt_vs_fcyl_by_fam_jit +
  # Change the geom to be an errorbar
  stat_summary(fun.data = mean_sdl, fun.args = list(mult = 1), position = posn_d, geom = "errorbar")

p_wt_vs_fcyl_by_fam_jit +
  # Add a summary stat of normal confidence limits
  stat_summary(fun.data = mean_cl_normal, fun.args = list(mult = 1), position = posn_d)


#' @include Bayesian_Bricks.r

#' @title Density function of Inverse-Gamma distribution
#' @description
#' For a random variable x, the density function of Inverse-Gamma distribution is defined as:
#'    \deqn{(rate^shape)/Gamma(shape) x^{-shape-1} exp(-rate/x)}
#' @param x numeric, positive numeric values.
#' @param shape numeric, the shape parameter of gamma distribution.
#' @param scale numeric, the scale, or inverse-scale parameter of gamma distribution. The 'rate' parameter in Gamma is the 'scale' parameter in InvGamma
#' @param LOG logical, return log density of LOG=TRUE, default TRUE.
#' @return A numeric vector, the density values.
#' @export
dInvGamma <- function(x,shape,scale,LOG=TRUE){
    logp <- shape*log(scale) - lgamma(shape)+(-shape-1)*log(x) - scale/x
    if(!LOG) logp <- exp(logp)
    logp
}

#' @title Random number generation of Inverse-Gamma distribution
#' @description
#' Generation random samples from Inverse-Gamma distribution. For a random variable x, the density function is defined as:
#'    \deqn{(rate^shape)/Gamma(shape) x^{-shape-1} exp(-rate/x)}
#' Where Gamma() is the Gamma function.
#' @param n integer, number of samples to be generated.
#' @param shape numeric, the shape parameter of gamma distribution.
#' @param scale numeric, the scale, or inverse-scale parameter of gamma distribution. The 'rate' parameter in Gamma is the 'scale' parameter in InvGamma.
#' @return A numeric vector, samples of Inverse-Gamma distribution.
#' @export
#' @import stats
rInvGamma <- function(n,shape,scale){
    1/rgamma(n=n,shape = shape,rate = scale)
}

#' @title Random generation for Wishart distribution
#' @description
#' Generate random samples from Wishart distribution. For a random matrix x, the density function of Wishart distribution is defined as:
#'     \deqn{(2^{(df p)/2} Gamma_p(df/2) |rate|^{-df/2})^{-1} |x|^{(df-p-1)/2} exp(-1/2 tr(x rate))}
#' Where x is a pxp symmetric positive definite matrix, Gamma_p() is the multivariate Gamma function of dimension p.
#' @param df numeric, the degree of freedom.
#' @param rate matrix, a symmetric positive-definite matrix, the 'rate', or 'inverse-scale' parameter. The 'rate' parameter in Wishart is the 'scale' parameter in InvWishart
#' @param scale, matrix, the inverse of rate. Only one of 'rate' and 'scale' should be non-NULL.
#' @return A symmetric positive-definite matrix.
#' @export
#' @examples
#' rate <- crossprod(matrix(rnorm(15),5,3)) #the prior inverse-scale
#' m <- matrix(0,3,3)
#' ## get 1000 samples and calculate the sample mean
#' for(i in 1:100){
#'     m <- m+rWishart(df=5,rate=rate)/100
#' }
#' ## m should roughly equal to df*inverse(rate):
#' m
#' pdsInverse(rate)*5
#' ## try generating samples with 'rate' parameter:
#' scale <- pdsInverse(rate)
#' m2 <- matrix(0,3,3)
#' for(i in 1:100){
#'     m2 <- m2+rWishart(df=5,scale=scale)/100
#' }
#' ## m2 should roughly equal df*scale:
#' m2
#' 5*scale
#' @references Smith, W. B., and R. R. Hocking. "Algorithm as 53: Wishart variate generator." Journal of the Royal Statistical Society. Series C (Applied Statistics) 21.3 (1972): 341-345.
#' @import stats
rWishart <- function(df,rate=NULL,scale=NULL){
    if(missing(df)) stop("'df' not specified!")
    if(is.null(rate) & is.null(scale)) stop("one of 'rate' or 'scale' should be non-NULL.")
    if(!is.null(rate)){
        if(!.is(rate,"matrix")){
            stop("'rate' must be a matrix!")
        }else if(nrow(rate)!=ncol(rate)){
            stop("'rate' must be a square matrix!")
        }
        if(df<nrow(rate)) stop("'df' must be greater than nrow(rate)!")
        D <- nrow(rate)                     #dimension
    }else if(!is.null(scale)){
        if(!.is(scale,"matrix")){
            stop("'scale' must be a matrix!")
        }else if(nrow(scale)!=ncol(scale)){
            stop("'scale' must be a square matrix!")
        }
        if(df<nrow(scale)) stop("'df' must be greater than nrow(rate)!")
        D <- nrow(scale)                     #dimension
    }

    A <- matrix(0,D,D)
    diag(A) <- sqrt(vapply((df+1)-1:D,function(dfchisq){
        rchisq(n=1,df = dfchisq)
    },FUN.VALUE = numeric(1)))
    if(D>1L){
        A[upper.tri(A)] <- rnorm(D*(D-1L)/2L)
    }

    if(!is.null(scale)){
        return(crossprod(A%*%chol(scale)))
    }else{
        return(crossprod(A%*%t(pdsInverse(S=rate,returnUpper = TRUE))))
    }
}

#' @title Density function of Wishart distribution
#' @description
#' For a random matrix x, the density function of Wishart distribution is defined as:
#'     \deqn{(2^{(df p)/2} Gamma_p(df/2) |rate|^{-df/2})^{-1} |x|^{(df-p-1)/2} exp(-1/2 tr(x rate))}
#' Where x is a pxp symmetric positive definite matrix, Gamma_p() is the multivariate Gamma function of dimension p.
#' @param x matrix, a symmetric positive-definite matrix.
#' @param df numeric, the degree of freedom.
#' @param rate matrix, a symmetric positive-definite matrix, the 'rate', or 'inverse-scale' parameter. The 'rate' parameter in Wishart is the 'scale' parameter in InvWishart
#' @param LOG logical, return log density of LOG=TRUE, default TRUE.
#' @return A numeric vector, the density values.
#' @export
#' @examples
#' ##generate a symmetric positive-definite matrix
#' x <- crossprod(matrix(rnorm(15),5,3))
#' rate <- crossprod(matrix(rnorm(15),5,3)) #the prior inverse-scale of x
#' dWishart(x,df = 5,rate = rate,LOG = TRUE)
#' dWishart(x,df = 5,rate = rate,LOG = FALSE)
#' @references Wishart, John. "The generalized product moment distribution in samples from a normal multivariate population." Biometrika (1928): 32-52.
#' @references MARolA, K. V., JT KBNT, and J. M. Bibly. Multivariate analysis. AcadeInic Press, Londres, 1979.
dWishart <- function(x,df,rate,LOG=TRUE){
    if(missing(df)|missing(rate)) stop("'n' or 'rate' not specified!")
    if(!.is(x,"matrix")){
        stop("'x' must be a matrix!")
    }else if(nrow(x)!=ncol(x)){
        stop("'x' must be a square matrix!")
    }
    if(!.is(rate,"matrix")){
        stop("'rate' must be a matrix!")
    }else if(nrow(rate)!=ncol(rate)){
        stop("'rate' must be a square matrix!")
    }
    if(df<nrow(rate)) stop("'df' must be greater than nrow(rate)!")
    p <- ncol(x)                        #dimension
    logp <- (df-p-1)/2 * pdsDeterminant(S=x,LOG=TRUE) - sum(diag(x%*%rate))/2 -
        ( df*p/2*log(2) + .lmvgamma(a=df/2,p=p) - df/2*pdsDeterminant(S=rate,LOG = TRUE))
    if(!LOG) logp <- exp(logp)
    logp
}

#' @title Random generation for Inverse-Wishart distribution
#' @description
#' Generate random samples from Inverse-Wishart distribution. For a random matrix x, the density function of Inverse-Wishart is defined as:
#'   \deqn{(2^{(df p)/2} Gamma_p(df/2) |scale|^{-df/2})^{-1} |x|^{(-df-p-1)/2} exp(-1/2 tr(x^{-1} scale))}
#' Where x is a pxp symmetric positive definite matrix, Gamma_p() is the multivariate Gamma function of dimension p.
#' @param df numeric, the degree of freedom.
#' @param scale matrix, a symmetric positive-definite matrix, the 'scale' parameter. The 'rate' parameter in Wishart is the 'scale' parameter in InvWishart.
#' @return A symmetric positive-definite matrix.
#' @export
#' @examples
#' scale <- crossprod(matrix(rnorm(15),5,3)) # the prior scale
#' m <- matrix(0,3,3)
#' ## get 1000 samples and calculate the sample mean
#' for(i in 1:1000){
#'     m <- m+rInvWishart(df=5,scale=scale)/1000
#' }
#' ## m should roughly equal scale/(df-p-1), p is the dimension.
#' m
#' scale/(5-3-1)
#' @references Hoff, Peter D. A first course in Bayesian statistical methods. Vol. 580. New York: Springer, 2009.
rInvWishart <- function(df,scale){
    if(missing(df)|missing(scale)) stop("'df' or 'scale' not specified!")
    if(df<nrow(scale)) stop("'df' must be greater than nrow(scale)!")
    pdsInverse(rWishart(df = df,rate = scale))      #rate in Wishart is scale in InverseWishart
}

#' @title Density function of Inverse-Wishart distribution
#' @description
#' For a random matrix x, The density function of Inverse-Wishart distribution is defined as:
#'   \deqn{(2^{(df p)/2} Gamma_p(df/2) |scale|^{-df/2})^{-1} |x|^{(-df-p-1)/2} exp(-1/2 tr(x^{-1} scale))}
#' Where x is a pxp symmetric positive definite matrix, Gamma_p() is the multivariate Gamma function of dimension p.
#' @param x matrix, a symmetric positive-definite matrix.
#' @param df numeric, the degree of freedom.
#' @param scale matrix, a symmetric positive-definite matrix, the 'scale' parameter. The 'rate' parameter in Wishart is the 'scale' parameter in InvWishart.
#' @param LOG logical, return log density of LOG=TRUE, default TRUE.
#' @return A numeric vector, the density values.
#' @export
#' @examples
#' x <- crossprod(matrix(rnorm(15),5,3)) #generate a symmetric positive-definite matrix
#' scale <- crossprod(matrix(rnorm(15),5,3)) #the prior scale of x
#' dInvWishart(x,df = 5,scale = scale,LOG = TRUE)
#' dInvWishart(x,df = 5,scale = scale,LOG = FALSE)
#' @references Wishart, John. "The generalized product moment distribution in samples from a normal multivariate population." Biometrika (1928): 32-52.
#' @references MARolA, K. V., JT KBNT, and J. M. Bibly. Multivariate analysis. AcadeInic Press, Londres, 1979.
dInvWishart <- function(x,df,scale,LOG=TRUE){
    if(!.is(x,"matrix")){
        stop("'x' must be a matrix!")
    }else if(nrow(x)!=ncol(x)){
        stop("'x' must be a square matrix!")
    }
    if(df<nrow(scale)) stop("'df' must be greater than nrow(scale)!")
    p <- ncol(x)                        #dimension
    logp <- -(df+p+1)/2 * pdsDeterminant(S=x,LOG=TRUE) - sum(diag(solve(x)%*%scale))/2 -
        ( df*p/2*log(2) + .lmvgamma(a=df/2,p=p) - df/2*pdsDeterminant(S=scale,LOG = TRUE))
    if(!LOG) logp <- exp(logp)
    logp

}


# Ranks
#
# Read the data of Meltzer

rm(list=ls())

ps <- read.table("patch1968.dat",header=T)

ps$r <- rank(-ps$pSize)

plot(r ~ pSize,data=ps)

plot(log(r)~log(pSize),data=ps)

lm0 <- lm(log(r)~log(pSize),data=ps)

coef(lm0)

abline(lm0)

# Calculate the Hurst Exponent

slope0 <- coef(lm0)[2]

2+slope0*2

# load the library car for the Durbin-Watson test
require(car)

dwt(lm0)

# Draw a grid to distinguish the break
grid()

# Split the data

ps1 <- ps[ps$logpSize<3.5,]
plot(log(r)~log(pSize),data=ps)
lm1 <- lm(log(r)~log(pSize),data=ps1)
require(car)
dwt(lm1)
abline(lm1,col="green")
coef(lm1)

ps2 <- ps[ps$logpSize>=3.5,]
lm2 <- lm(log(r)~log(pSize),data=ps2)
require(car)
dwt(lm2)
abline(lm2,col="blue")
coef(lm2)

# the library segmented

require(segmented)

ps$logr <- log(ps$r)
ps$logpSize <- log(ps$pSize)
lm0 <- lm(logr~logpSize,data=ps)
seg <- segmented(lm0, seg.Z = ~logpSize, psi=4)
summary(seg)
slope(seg)

# Function to calculate H

calcH <- function(B) { 2-2*abs(B)}

calcH(.1550) # H = 1.69

# small patches are anti-persistent

calcH(.9036) # H = 0.19

# Big patches are persistent

# where is the breakpoint in ha

calcBreak <- function(B) { 0.1*exp(B)*0.65 }

calcBreak(3.35) # 1.85 ha

# Read the data from 1985

ps <- read.table("patch1985.dat",header=T)
ps$r <- rank(-ps$pSize)
plot(r ~ pSize,data=ps)
plot(log(r)~log(pSize),data=ps)

lm0 <- lm(log(r)~log(pSize),data=ps)

coef(lm0)

abline(lm0)
require(car)
dwt(lm0)

# Exercise 2

require(segmented)

ps$logr <- log(ps$r)
ps$logpSize <- log(ps$pSize)
lm0 <- lm(logr~logpSize,data=ps)
seg <- segmented(lm0, seg.Z = ~logpSize, psi=4)
summary(seg)
slope(seg)

plot(seg,col="green",xlab="Log Patch Size",ylab="Acum Freq")
points(log(r)~log(pSize),data=ps,pch=2,cex=.5)

calcH(0.2676)
calcH(1.26)

calcBreak(2.708) # 0.97 ha

# using ggplot2

ps <- read.table("patch1985.dat",header=T)
ps$r <- rank(-ps$pSize)
ps$Year <- "1985"
ps1 <- read.table("patch1968.dat",header=T)
ps1$r <- rank(-ps1$pSize)
ps1$Year <- "1968"

ps <- rbind(ps,ps1)
#
require(ggplot2)
ggplot(data=ps,aes(x=pSize,y=r,color=Year))+geom_point()

p <- ggplot(data=ps,aes(x=log(pSize),y=log(r),color=Year))+geom_point(aes(shape=Year))

p

ps$logpSize <- log(ps$pSize)
ps1 <- ps[ps$logpSize>3.35,]

p + geom_smooth(data=ps1,method="lm")

ggsave("patch_Breaks.png",width=2)

# This suggest that the increase cattle load change the break, but not the patch process
# Los parches mas grandes se mantuvieron estables los mas chicos cambiaron


# 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 : 3.6A   Chapter : 3.6     Page No: 190
# Four Fundamental Spaces of given matrix

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)
}
l<-matrix(c(1,2,5,0,1,0,0,0,1),ncol=3)
u<-matrix(c(1,0,0,3,0,0,0,1,0,5,6,0),ncol=4)
A<-l%*%u
print("Row space Basis of A")
print(u[1,])
print(u[2,])
print("COlumn space Basis of A ")
print(l[,1])
print(l[,2])
print("Null space Basis of A")
N<-nullspacebasis(A)
print(N)
print("Null space Basis of A transpose")
NT<-nullspacebasis(t(A))
print(NT)


y<-c(.593 ,.142, .329, .691 ,.231 ,.793 ,.519 ,.392, .418 )
ybar = mean(y)
mu0 = 0.3
sigma = sd(y)
n = 9              # sample size
z = abs((ybar- mu0)/(sigma/sqrt(n)))
print(z)
p_value=2*(1-pnorm(z))
print(p_value)
alpha=0.01
if(p_value>alpha){
  print("we fail to reject H0")
  print(" data do not support the research hypothesis(insufficient evidence).")
}else{
  print("reject H0")
}


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

#valor de la hipotesis
mu0 = 15.4

#sd
sigma = 2.5

n = 35

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

z #-1.89

alpha = .05

z.half.alpha = qnorm(1-alpha/2)

c(-z.half.alpha,z.half.alpha)

#-1.96 1.96

#aceptamos la hipotesis

pval = 2*pnorm(z)
pval #pvalue para 2 colas 0.058

Parcial/1. Prueba de hipotesis/TwoTailedMeanKnownVariance.r


### 多値判別分析の例
### - Edgar Anderson's Iris Data

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

## データの読み込み ("datasets::iris"を用いる)
data(iris) # データセットの読み込み

## データの内容を確認
help(iris)  # 内容の詳細を表示
str(iris)   # データの構造を表示
## print(iris) # 全データの表示
head(iris)  # データの最初を表示
tail(iris)  # データの最後を表示

## データの散布図: 図(a)
ggpairs(iris, columns=1:4, mapping=aes(colour=Species, alpha=.5)) +
    labs(title="Edgar Anderson's Iris Data")

## 3D表示 (Sepal.Widthを除く): 図(b)
require(lattice)
cloud(Sepal.Length ~ Petal.Length * Petal.Width,
      data=iris,　groups=Species, screen=list(z=30, x=-60),
      main="Edgar Anderson's Iris Data")
## cloud(Sepal.Length ~ Petal.Length * Petal.Width | Species,
##       data=iris, screen=list(x=-90, y=70), distance=.4, zoom=.6)

## 特徴量とカテゴリによる線形判別関数の構成
model <- lda(Species ~ ., data=iris)
print(model) # 結果を表示

## 判別得点の散布図: 図(c)
### 参考 https://www.r-bloggers.com/computing-and-visualizing-lda-in-r/
mydata <- data.frame(iris,
                     lda=predict(model, newdata=iris)$x)
prop <- model$svd^2/sum(model$svd^2) # 判別の寄与率の計算
ggplot(mydata) +
    geom_point(aes(lda.LD1,lda.LD2,colour=Species)) +
    labs(x=paste0("LD1 (", round(prop[1]*100,2),"%)"),
         y=paste0("LD1 (", round(prop[2]*100,2),"%)")) +
    theme(legend.position="top")

## 主成分得点の散布図: 図(d)
autoplot(prcomp(~ . -Species, data=iris, scale.=TRUE),
         data=iris, colour="Species") +
    theme(legend.position="top")

## 訓練データと試験データによる線形判別の評価
## set.seed(1234) # 実験の再現性を求める場合
idx <- sample(1:150,75) # 訓練用データの番号をランダムに選ぶ
with(iris,table(Species[idx])) # 各種が何個ずつ選ばれたか表示

## 線形判別式の作成
model1 <- lda(Species ~ ., data=iris, subset=idx,
               prior=c(1/3,1/3,1/3))
## print(model1) # 結果を表示
## ## データの分布をそのまま使う場合はpriorを指定しない
## model1 <- lda(Species ~ ., data=iris, subset=idx)
## ## モデルの更新を行う場合はupdateを使う (例: Petal.Length を除く)
## model1 <- update(model1, . ~ . - Petal.Length)

## 線形判別による予測
true <- iris[-idx,5]
predict1 <- predict(model1, newdata=iris[-idx,-5])
table(true,predict=predict1$class)  # 真のクラスラベルと予測結果の比較
if(length(true!=predict1$class)>0) {# 誤ったデータがある場合
    which(true!=predict1$class) # 番号を表示
    predict1$posterior[true!=predict1$class,] # 事後確率を表示
}
## 線形判別の事後確率: 図(e)
cloud(setosa ~ versicolor * virginica,
      data=data.frame(predict1$posterior),
      groups=true)

## 訓練データと試験データによる2次判別の評価
## 2次判別式の作成
model2 <- qda(Species ~ ., data=iris, subset=idx,
               prior=c(1/3,1/3,1/3))
## print(model2) # 結果を表示

## 2次判別による予測
predict2 <- predict(model2, newdata=iris[-idx,-5])
table(true,predict=predict2$class)  # 真のクラスラベルと予測結果の比較
if(length(true!=predict2$class)>0) {# 誤ったデータがある場合
    which(true!=predict2$class) # 番号を表示
    predict2$posterior[true!=predict2$class,] # 事後確率を表示
}
## 2次判別の事後確率: 図(f)
cloud(setosa ~ versicolor * virginica, # 事後確率を図示
      data=data.frame(predict2$posterior),
      groups=true)


# 2.2
example(mean)

# 1. Generamos dos vectores de datos desde sendas distribuciones normales
# y los guardamos en sendos objetos 'x' e 'y'
x <- rnorm(50)
y <- rnorm(50, mean = 10, sd = 2)
# Imprimimos en la consola el contenido de los objetos 'x' e 'y'
x
y
# 2. Resumen descriptivo de los datos
summary(x)
summary(y)
# 3. Histograma de x
hist(x)
# 4. Representamos la distribución conjunta de los datos (scatterplot)
plot(x, y)
# 5. Ajustamos una recta de regresión a los datos
fit <- lm(y ~ x)
summary(fit)
# 6. Superponemos la recta de regresión al gráfico anterior
abline(fit)
# 7. Creamos dos nuevos vectores con secuencias de valores
x <- 1:10
y <- seq(-pi, pi, length.out = 10)
# 8. Escribimos una matriz con los vectores anteriores por columnas
cbind(x, y)
# 9. Escribimos una matriz con dos filas y cinco columnas con los elementos de x
matrix(x, 2, 5)
# 10. Creamos una matriz con filas y columnas indexadas por x e y,
# cuyos valores son cos(y)/(1 + x^2))
f <- outer(x, y, function(x, y) cos(y) / (1 + x^2))
f
# 11. Dos representaciones tridimensional de f como función de x e y
# primero un diagrama de contornos
contour(x, y, f)
# añadimos más niveles
contour(x, y, f, nlevels = 15, add = TRUE)
# y ahora un mapa de colores
image(x, y, f)
# 12. Demostración de otras funciones gráficas
demo(graphics)
demo(persp)
##############

# 2.3
x <- 5
y <- 2 * x
z <- log(y)
k <- x * y * z
ls()
rm(x, y)
ls()
rm(list = ls())
ls()

# matrix(data = NA, nrow = 1, ncol = 1, byrow = FALSE, dimnames = NULL)
matrix(pi, 1, 3)

#########
# 2.4
0.3 - 0.1 == 0.2
0.3 - 0.2
all.equal(0.3 - 0.2, 0.1)


m = matrix(1:6, nrow = 2, ncol = 3)
print("2x3 matrix:")
print(m)

c1 = m[,1]
print("First column:")
print(c1)

r2 = m[2,]
print("Second row:")
print(r2)

p23 = m[2,3]
print("Element of position 2,3:")
print(p23)

m[2,1:2] = 0
print("Updated matrix:")
print(m)

v2 = c(10, 11)
print("Working vector of length 2:")
print(v2)
v3 = c(20, 21, 22)
print("Working vector of length 3:")
print(v3)
m32 = matrix(1:6, nrow = 3, ncol = 2)
print("Working matrix of 3x2:")
print(m32)

m32v3 = cbind(v3, m32)
print("Matrix and vector bound by column:")
print(m32v3)

m32v2 = rbind(v2, m32)
print("Matrix and vector bound by row:")
print(m32v2)

bc23 = matrix(1:6, nrow = 2, ncol = 3)
bc24 = matrix(-8:-1, nrow = 2, ncol = 4)
bc = cbind(bc23, bc24)
print("Matrix 2x3 bound with 2x4 by column:")
print(bc)

br22 = matrix(1:4, nrow = 2, ncol = 2)
br32 = matrix(-6:-1, nrow = 3, ncol = 2)
br = rbind(br22, br32)
print("Matrix 2x2 bound with 3x2 by row:")
print(br)

Curs 1 - Introduction in Machine Learning/set4.r


##source(url("http://www.stat.pitt.edu/stoffer/tsa2/Rcode/itall.R"))
##z<- as.matrix(read.table("C:/Users/mccj07/Documents/Media mix modeling/MMM_data.csv", sep=",", header=T), 104, 4, byrow = TRUE)

### Lets first generate some Random DAta
x1=2000*10^arima.sim(n = 104, list(ar = c(0.8897, -0.178)),sd = sqrt(0.0796))
x2=5000*10^arima.sim(n = 104, list(ar = c(0.9497, -0.1758)),sd = sqrt(0.1296))
x3=1000*10^arima.sim(n = 104, list(ar = c(0.9197, -0.1258)),sd = sqrt(0.0696))
y=10000*10^arima.sim(n = 104, list(ar = c(0.9097, -0.1458), ma = c(-0.279, 0.188)),sd = sqrt(0.1596))

y=y+.75*x2+1.2*x1+.9*x3

xxxy=cbind(x1,x2,x3,y)
plot(xxxy,type='l')

xxxy

##  Lets go ahead and log the data
y1.l=log(y)
x1.l=log(x1)
x2.l=log(x2)
x3.l=log(x3)

## lets remove the mean for each series.
y1.m=mean(y1.l)
x1.m=mean(x1.l)
x2.m=mean(x2.l)
x3.m=mean(x3.l)

y1a=y1.l-y1.m
x1a=x1.l-x1.m
x2a=x2.l-x2.m
x3a=x3.l-x3.m

##   The two series X and Y must be made stationary before starting interpreting
##   the crosscorrelation function. Means of X and Y and variances of X and Y must
##   be constant over time. So the Autocorrelation Function of X and Y must be looked at
##   first of all and appropriate pre-transformations and differencing transformations
##   must be made until the ACF dies down quickly or has a cut off kind of behavior.

par(mfcol=c(2,2))
acf(y1a,lag=20)
acf(x1a,lag=20)
pacf(y1a,lag=20)
pacf(x1a,lag=20)

par(mfcol=c(2,2))
acf(x2a,lag=20)
acf(x3a,lag=20)
pacf(x2a,lag=20)
pacf(x3a,lag=20)

## in this case we generated staionary time series . so all are stationary

xxxya=cbind(x1a,x2a,x3a,y1a)
lag.plot(xxxya, 4, do.lines=FALSE)

x1_f=arima(x1a,order=c(2,0,0))
x2_f=arima(x2a,order=c(2,0,0))
x3_f=arima(x3a,order=c(2,0,0))

x1_f
x2_f
x3_f

###y1=arima(z[,1],order=c(2,0,0))
### choos x2 as a filter
tsdiag(x1_f, gof.lag=20)
tsdiag(x2_f, gof.lag=20)
tsdiag(x3_f, gof.lag=20)

f1=c(1,-x2_f$coef[1:2])

y1fil=filter(y1a, sides=1,f1)
y1fil=y1fil[3:103]

x1fil=filter(x1a, sides=1,f1)
x1fil=x1fil[3:103]
x2fil=filter(x1a, sides=1,f1)
x2fil=x2fil[3:104]
x3fil=filter(x1a, sides=1,f1)
x3fil=x3fil[3:104]

##   Identify an ARIMA model for the input series X that you made stationary and apply this model to Y.

##   Get the residuals from the model for X and the residuals of the model for Y. This is called Prewhitening the series.

ccf(x1fil,y1fil, ylab = "cross-correlation x1 and y")
ccf(x2fil,y1fil, ylab = "cross-correlation x2 and y")
ccf(x3fil,y1fil, ylab = "cross-correlation x3 and y")

x1f=x1_f$residuals[3:104]
x2f=x2_f$residuals[3:104]
x3f=x3_f$residuals[3:104]

##   Find the cross-correlation function between the residuals. This crosscorrelation function allows
##   us to find the impulse response function.

###   Use the estimates of the impulse response function to make guesses of the orders of the actual Y and X models.

source("C:/Users/mccj07/Documents/R/source/ccm.R")

xy=cbind(x1f,y1a[3:104],x2f,x3f)
##<== Combine filtered series.
ccm(xy,20)

##   With the latter get initial estimates of the parameters.
###  Estimate the parameters for the Y and the X part of the model

(fit2.gls = arima(y1a[3:104], order=c(2,0,2), xreg=cbind(x1f, x2f, x3f)))
acf(fit2.gls$residuals)
pacf(fit2.gls$residuals)

Box.test(resid(fit2.gls), 12, type="Ljung")
pchisq(12.377, 10, lower=FALSE)

x1.p=predict(x1_f, n.ahead=13, level=c(80,95))
x2.p=predict(x2_f, n.ahead=13, level=c(80,95))
x3.p=predict(x3_f, n.ahead=13, level=c(80,95))

newxreg=cbind(x1.p$pred,x2.p$pred,x3.p$pred)
y.fore = predict(fit2.gls, n.ahead=13, newxreg=newxreg)

exp(y.fore$pred)
y.fore$pred+y1.m

U = exp((y.fore$pred + 2*y.fore$se)+y1.m)
L = exp((y.fore$pred - 2*y.fore$se)+y1.m)
miny=min(y,L)
maxy=max(y,U)
ts.plot(y,exp(y.fore$pred+y1.m),col=1:2, ylim=c(miny,maxy))
lines(U, col="blue", lty="dashed")
lines(L, col="blue", lty="dashed")

exy=ts(exp(y.fore$pred+y1.m),start=105)

pred.xxxy=cbind(exp(x1.p$pred+x1.m),exp(x2.p$pred+x2.m),exp(x3.p$pred+x3.m),exy)

pred.xxxy


### 6.1-6

beforeData <- c(12, 15, 6, 20, 2, 5, 9, 16, 14, 17, 8, 5)
afterData <- c(11, 13, 3, 21, 5, 7, 6, 10, 9, 72, 4, 1)

nSamples <- length(beforeData)
df <- nSamples - 1

dArray <- beforeData - afterData
dSqArray <- dArray^2

dOverline <- sum(dArray) / nSamples
sD <- sqrt((sum(dSqArray - sum(dArray)^2/nSamples))/ df)

t <- dOverline / (sD / sqrt(nSamples))
print(df)
print(t)

### df = 11
tCrit <- qt(0.975, df, ncp=0, lower.tail=TRUE, log.p=FALSE)
print(tCrit)

### t = -0.6951115  ->  H0 is rejected (the movie did not affect the people)


# Generate two objects using rnorm(), then execute a Welch Two Sample t-test, to compare their means.
# SYNTAX: rnorm(numbers in length, mean, standard deviation)
# 1) Initial values
objectX <- rnorm(8, 10, 2)
objectY <- rnorm(8, 12, 2)

t.test(objectX, objectY)
# RESULT => p-value A = 0.004397

# 2) Make the objects 15 numbers in length
objectX <- rnorm(15, 10, 2)
objectY <- rnorm(15, 12, 2)

t.test(objectX, objectY)
# RESULT => p-value B = 0.0007762

# 3) The mean of each object must be 10
objectX <- rnorm(8, 10, 2)
objectY <- rnorm(8, 10, 2)

t.test(objectX, objectY)
# RESULT => p-value C = 0.6008

# 4) The mean of each object must be 10
objectX <- rnorm(15, 10, 2)
objectY <- rnorm(15, 10, 2)

t.test(objectX, objectY)
# RESULT => p-value D = 0.02587


rm(list = ls())
library("openssl")

## We are going to create a public key (n and e) and a private key(d) ####
## Assign Prime Numbers ###

p = bignum("112481050639317229656723018120659623829736571015511322021617837187076258724819")
q = bignum("89185111938335771293328323333111422985697062149139368049232365065924632677343")

##Public Keys###

n = p*q
print(n)

e = bignum("65537")

###Private Keys###

d = bignum_mod_inv(e, (p-1)*(q-1))

### GRADER ATTENTION: Following command has been commented out because "Private Key Info" Please uncomment if needed ###
#print(d)

m=bignum(charToRaw("Bitcoin is a vehicle of freedom"))
print(m)

c = bignum_mod_exp(m,e,n)
### GRADER ATTENTION: Following command has been commented out because "Private Message Payload" Please uncomment if needed ###
#print(c)

c_encoded = base64_encode(c)
### GRADER ATTENTION: Following command has been commented out because "Private Message Payload" Please uncomment if needed ###
#print(c_encoded)

### This section of the code will decode the information into a readable form ###
c_decoded = bignum(base64_decode("rGhkBLUmPQStyYGrhIcNxnhZw6GeGoFGswZuUihd+kPx21VtPSMmdBRQOkKw8uLPhsh0NV4qk27G/EFuVT2iAw=="))
m3 = bignum_mod_exp(c_decoded,d,n)
m3_char = rawToChar(m3)
print(m3_char)

m_hash = sha256(m3_char)
print(m_hash)

hashed_num = bignum(charToRaw(m_hash))
print (hashed_num)

s = bignum_mod_exp(hashed_num,d,n)

### Verify ###
m_verif = bignum_mod_exp(s,e,n)
print(m_verif)

## Simple logic test if the signature was the same and valid ###
if (m_verif == hashed_num)
  print("Success: The Signature Is Valid!")


##### Chapter 7: Neural Networks and Support Vector Machines -------------------

# 활성 함수는 인공 뉴런이 들어오는 정보를 처리해서 네트워크를 통해 정보를 처리하는 메커니즘.
# (로지스틱)시그모이드 함수를 자주 쓴다.
# 선형 함수를 활성 함수로 쓰면 선형 회귀와 매우 유사한 신경망르 만든다.
# 가우시안 활성 함수는 방사 기저 함수 네트워크라고 하는 모델을 만든다.
# 이들 각각은 특정 학습 작업에 좀 더 적합한 강점을 가진다.
# 여러 활성 함수의 경우, 출력 신호에 영향을 미치는 입력 값의 범위가 상대적으로 좁다는 것을 인식해야 한다.
# ex) 시그모이드는 절대값이 5를 넘어가는 값은 거의 0이나 1이다.
# 압축 문제에 대한 해결책은, 특징 값이 0 근처의 작은 범위 안으로 들어오게 모든 신경망 입력을 변환하는 것이다.
# 이 과정에서 표준화나 정규화가 수반된다.

# 네트워크 토폴로지(네트워크 패턴, 네트워크 구조)
# 계층 갯수, 네트워크의 정보가 역방향으로 이동할 수 있는지 여부, 네트워크의 각 계층 별 노드 개수로 구별.
# 다중 은닉 계층을 갖는 신경망을 DNN이라고 하며, 그런 신경망의 훈련을 딥러닝이라고 한다.

# 신경망은 각 계층의 노드 개수로 복잡도에 변화를 줄 수 있다.
# 입력 노드 개수는 입력 데이터의 특징 개수로 사전에 결정된다.
# 비슷하게 출력 노드의 갯수는 모델링되는 출력 개수 또는 출력 클래스 레벨 개수로 사전에 결정된다.
# 하지만 은닉 노드의 갯수는 모델을 훈련하기 전에 사용자가 결정한다.
# 은닉 계층의 뉴런 갯수를 결정하는 신뢰할 많나 규칙은 없다.
# 적합한 갯수는 다양한 요소 중, 입력 노드 수, 훈련 데이터양, 잡음 데이터양, 학습 작업의 복잡도에 따라 달라진다.
# 뉴런 갯수가 아주 많으면 오버피팅 가능성!
# 대부분의 경우 신경망은 적은 갯수의 은닉 노드 만으로도 엄청난 학습 능력 제공한다.

# 네트워크는 경험으로 훈련된다. 신경망이 입력 데이터를 처리하면서 뉴런 사이에 연결은 강화되거나 약화된다.
# 네트워크의 연결 가중치는 시간이 지나면서 관측되는 패턴을 반영하도록 조정된다.
# 순방향 단계
  # 입력 계층부터 출력 계층까지 뉴런이 순차적으로 활성화되면서
  # 도중에 뉴런의 가중치와 활성 함수가 적용된다.
  # 마지막 계층에 도달하면 출력 신호가 생성된다.
# 역방향 단계
  # 순방향 단계에서 만들어진 네트워크 출력 신호를 훈련 데이터의 실제 목표 값과 비교한다.
  # 네트워크 출력 신호와 실제 값의 차로 오차가 만들어지면,
  # 네트워크에서 역방향으로 전파되어 뉴런 사이에 연결 가중치를 수정하고, 미래의 오차를 줄인다.
# 뉴런의 입력과 출력 사이의 관계가 복잡한데, 알고리즘이 가중치를 얼마나 바꿔야 하는지 어떻게 결정하는가?
  # 경사 하강법!
    # 역전파 알고리즘은 각 뉴런의 활성 함수를 미분해 들어오는 각 가중치 방향의 그래디언트를 식별한다.
      # 그래서 미분 가능한 활성 함수를 갖는 것이 중요하다.
    # 그래디언트는 가중치의 변화에 대해 오차의 감소 또는 증가 방향(경사)를 나타낸다.
    # 알고리즘은 오차가 최대한 감소하도록, "학습률만큼" 변경하려고 할 것이다.
    # 학습률이 커질수록 알고리즘은 더 빠르게 언덕을 내려온다.->훈련 시간을 줄일 수 있다.

##### Part 1: Neural Networks -------------------
## Example: Modeling the Strength of Concrete  ----

## Step 2: Exploring and preparing the data ----
# read in data and examine structure
getwd()
setwd("D:/R_LAB/MLwR/Chapter 07")
concrete <- read.csv("concrete.csv")
str(concrete)

# custom normalization function
normalize <- function(x) {
  return((x - min(x)) / (max(x) - min(x)))
}
# apply normalization to entire data frame
concrete_norm <- as.data.frame(lapply(concrete, normalize))
# confirm that the range is now between zero and one
summary(concrete_norm$strength)
# compared to the original minimum and maximum
summary(concrete$strength)
# 모델을 훈련하기 전에 데이터에 적용한 모든 변환은 이후에 역으로 적용해서 원래 측정 단위로 되돌려야 한다.
# 재조정을 용이하게 하려면 원래 데이터나, 원래 데이터의 요약 통계를 저장해 두는 것이 좋다.

# create training and test data
# 이미 임의로 정렬되어 있으므로, 데이터 프레임을 단순히 두 부분으로 나누면 된다.
concrete_train <- concrete_norm[1:773, ]
concrete_test <- concrete_norm[774:1030, ]

## Step 3: Training a model on the data ----
# train the neuralnet model
install.packages("neuralnet")
library(neuralnet) # 사용하기 쉬운 표준 신경망의 구현을 제공 & 네트워크 토폴로지 그리는 함수 제공.

# simple ANN with only a single hidden neuron(은닉 노드 하나인 다층 순방향 네트워)
set.seed(13123313) # to guarantee repeatable results
concrete_model <- neuralnet(formula = strength ~ cement + slag +
                              ash + water + superplastic +
                              coarseagg + fineagg + age,
                              data = concrete_train)

# visualize the network topology
plot(concrete_model)
# 은닉 노드가 하나인 신경망은, 선형 회귀 모델과 비슷할 수 있다.
  # 각 입력 노드와 은닉 노드의 가중치는 회귀 계수와 비슷하다.
  # 바이어스 항의 가중치는 절편과 비슷하다.
# 아래 부분에 훈련 단계 횟수와 오차 제곱 합을 보고한다.

## Step 4: Evaluating model performance ----
# obtain model results
model_results <- compute(concrete_model, concrete_test[1:8])
# compute()는 predict()와는 다르게 작동한다.
  # 이 함수는 두 개의 구성 요소로 된 리스트를 반환한다.
    # $neurons는 네트워크의 계층별로 뉴런을 저장하며,
    # $net.result는 에측 값을 저장한다.

# obtain predicted strength values
predicted_strength <- model_results$net.result
# 지금은 분류 문제가 아닌 수치 예측 문제이기 때문에, 모델의 정확도를 검토할 때에 혼동 행렬 사용 불가.
# 대신 예측된 콘트리트 강도와 실제 값의 상관관계를 측정해야 한다.

# examine the correlation between predicted and actual values
cor(predicted_strength, concrete_test$strength)

## Step 5: Improving model performance ----
# a more complex neural network topology with 5 hidden neurons
set.seed(13123313) # to guarantee repeatable results
concrete_model2 <- neuralnet(strength ~ cement + slag +
                               ash + water + superplastic +
                               coarseagg + fineagg + age,
                               data = concrete_train, hidden = 5)

# plot the network
plot(concrete_model2)

# evaluate the results as we did before
model_results2 <- compute(concrete_model2, concrete_test[1:8])
predicted_strength2 <- model_results2$net.result
cor(predicted_strength2, concrete_test$strength)

##### Part 2: Support Vector Machines -------------------
# 다차원 공간에 표시되는 점들 사이에 경계를 만드는 표면.
# 분류, 수치 예측을 포함한 거의 도든 유형의 학습 작업에 이용 가능.
# SVM은 점이 선형적으로 분리되지 않는 문제에도 확장될 수 있다.
# 서포트 벡터란 각 클래스에서 최대 마진 초평면(MMH)에 가장 가까운 점들이다.
  # 서포트 벡터만을 이용해서 MMH를 정의할 수 있다.
  # 특징의 개수가 엄청나게 많더라도, 서포트 벡터는 분류 모델을 저장하기 위한 아주 간결한 방법을 제공한다.
  # 서포트 벡터를 식별하는 알고리즘은 벡터 기하학에 의존한다. 하지만 과정의 기본 원리는 간단하다.
# 선형적으로 분리가 불가능한 경우
  # 슬랙 항을 추가해 비선형 데이터에 대해 훈련
  # 커널 트릭을 이용해 문제를 고차원 공간으로 매핑. 그렇게 하면 비선형적 관계가 선형적 관계로 바뀐다.
    # 커널 트릭은 측정된 특성 간의 수학적 관계를 표현하는 새로운 특징의 구성 과정을 포함한다.
# 장단점
  # 장점
    # 분류 또는 수치 예측 문제에 사용 가능
    # 잡음에 거의 영향을 받지 않음. 과적합도 쉽게 일어나지 않음.
    # 신경망을 사용하는 것보다 쉬움. 잘 지원되는 SVM 알고리즘들이 이미 존재
    # 정확도가 높은 편
  # 단점
    # 최고의 모델을 찾기 위해 커널과 모델 파라미터의 다양한 조합을 테스트해야 한다.
    # 훈련이 느릴 수 있으며, 특히 입력 데이터셋이 아주 많은 특징이나 예시를 갖는 경우 느리다.
    # 해석하기 어려울 수 있다.
# 커널
  # 일반적인 커널 함수는 특징 벡터 xi,xj에 변환을 적용하고, 내적으로 둘을 결합한다.
    # 이 때 내적은 두 벡터를 받아 하나의 숫자를 반환한다.
  # 선형 커널 : 데이터를 전혀 변환하지 않는다 -> 특징의 내적으로 간단히 표현 가능.
  # d차원 다항 커널 : 간단한 데이터의 비선형 변환을 더한다.
  # 시그모이드 커널 : 시그모이드 활성 함수를 사용한 신경망과 다소 유사한 SVM 모델을 만든다.
  # 가우시안 RBF 커널 : RBF 신경망과 유사하다. 많은 유형의 데이터에서 잘 작동한다.
# 커널을 특정 학습 작업에 연결해주는 신뢰할 만한 규칙은 없다.
  # 커널의 적합 여부는 훈련 데이터의 양, 특징, 그 관계, 그리고 학습될 개념에 크게 의존한다.
# 검증 데이터셋에 대해 몇 개의 SVM을 훈련하고 평가하는 식의 시행착오가 필요하다.

## Example: Optical Character Recognition ----

## Step 2: Exploring and preparing the data ----
# read in data and examine structure
letters <- read.csv("letterdata.csv")
str(letters)
# SVM 학습자는 모든 특징이 수치여야 하고, 게다가 각 특징이 아주 작은 구간으로 값이 조정되어야 한다.
# str을 해 보니 데이터의 정규화 또는 표준화가 필요하다는 것을 알 수 있다.
  # 모델을 적합시키기 위해 사용할 R 패키지가 자동으로 재조정을 실행한다.

# divide into training and test data
# 데이터는 이미 무작위로 나뉘어져 있다.
letters_train <- letters[1:16000, ]
letters_test  <- letters[16001:20000, ]

## Step 3: Training a model on the data ----
# begin by training a simple linear SVM
# 뛰어난 패키지들이 많다.
  # e1071 패키지는 LIBSVM 라이브러리의 R 인터페이스를 제공한다.(C++로 작성됨)
  # klaR 패키지는 SVM 구현을 R에서 직접 수행하는 함수를 제공한다.
  # kernlab  패키지는 caret 패키지와 함께 사용할 수 있어서, 다양한 자동화 방법(11장)으로 훈련 및 평가 가능.

install.packages("kernlab")
library(kernlab)
# ksvm() 함수는 디폴트로 가우시안 RBF 커널을 사용하지만, 다양한 옵션도 제공한다.
# SVM의 성능 측정 기준선을 마련하기 위해, 단순한 선형 SVM 분류기의 훈련으로 시작해보자.
letter_classifier <- ksvm(letter ~ ., data = letters_train,
                          kernel = "vanilladot") # vanilladot 옵션으로 선형 커널을 명시.

# look at basic information about the model
# 명령어를 동작시켜도, 실제 얼마나 잘 실행될 것인지에 대해서는 알려주지 않는다.
letter_classifier
# 모델이 범용 기능을 가지는지 알려면, 테스트 데이터 셋에 대한 성능을 검토해보자.

## Step 4: Evaluating model performance ----
# predictions on testing dataset 함수 predict() 이용
letter_predictions <- predict(letter_classifier, letters_test)
# type 파라미터를 지정하지 않았기 때문에, type ="response" 디폴트가 사용되었다.

head(letter_predictions)
# 예측된 문자와 테스트 데이터셋에 있는 실제 문자 비교
table(letter_predictions, letters_test$letter)

# look only at agreement vs. non-agreement(전체적인 정확도만 평가)
# construct a vector of TRUE/FALSE indicating correct/incorrect predictions
agreement <- letter_predictions == letters_test$letter
table(agreement)
prop.table(table(agreement)) # 정확도 약 84%

## Step 5: Improving model performance ----
# 선형 커널 함수보다 더 복잡한 커널 함수를 사용해, 데이터를 더 높은 차원으로 매핑하여 더 나은 모델 적합 얻기 가능.
set.seed(13123313)

letter_classifier_rbf <- ksvm(letter ~ ., data = letters_train, kernel = "rbfdot")
letter_predictions_rbf <- predict(letter_classifier_rbf, letters_test)

agreement_rbf <- letter_predictions_rbf == letters_test$letter
table(agreement_rbf)
prop.table(table(agreement_rbf)) # 정확도 93%로 증가


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

rm(list = ls())

Q <- matrix(c(-1/3,  1/3,   0,
              1/20, -1/4,  1/5,
               1/2,    0, -1/2),
            3, 3, byrow = TRUE)

(A <- cbind(Q[, 1:(nrow(Q) - 1)], rep(1, nrow(Q))))
# -0.3333333	 0.3333333	1
#  0.0500000	-0.2500000	1
#  0.5000000	 0.0000000	1

(stationary <- solve(A)[nrow(A), ])
# 0.348837209302326 0.465116279069767 0.186046511627907

R <- Q[1:2, 1:2]
(between.rainy <- (- solve(R) %*% rep(1, nrow(R)))[1])
# 8.75

r <-  - Q / diag(Q)
(a <- cbind(r[, 1:(nrow(r) - 1)], rep(1, nrow(r))))
# -1.0	 1	1
#  0.2	-1	1
#  1.0 	 0	1

solve(a)[nrow(a), ]
# 0.357142857142857 0.357142857142857 0.285714285714286


# Simulación de Variables Aleatorias

# 5.5.1 Método de inversión
#

# --------------------------------------------------------------------------------
# Eg

# F(x) = 1-exp(-\lambda x), x>= 0
# u = F^-1 (x) ==> x = F^-1(u) = - frac{log(1-5)}{\lambda}

n <- 1000
set.seed(1)
u <- runif(n)
lambda <- 0.5
x <- -log(u) / lambda
x[1:10]

# Comprobamos que es una exponencial con lambda 0.5
hist(x,
    freq = FALSE, breaks = "FD", main = "Método de inversión (Exponencial)",
    ylim = c(0, 0.5)
)
lines(density(x), col = "blue")
curve(dexp(x, rate = lambda), add = TRUE, col = 2)

# Comprobamos con Kolmogorov - Smirnov:
ks.test(x, pexp, rate = lambda)

# --------------------------------------------------------------------------------
# Eg
# Generamos desde una doble exp/de Cauchy
# f(x) = \l/2exp(-\|x|) ==>
# F(x) = \{
# x<0 -> exp(\l/x)/2
# x>0 -> 1-exp(\l/x)/2
# }
ddexp <- function(x, lambda) lambda * exp(-lambda * abs(x)) / 2
rddexp <- function(n, lambda) {
    u <- runif(n)
    x <- ifelse(u < 0.5,
        log(2 * u) / lambda,
        -log(2 * (1 - u)) / lambda # este ifelse es la F^-1(u)
    )
    return(x)
}

n <- 1000
set.seed(1)
lambda <- 1
x <- rddexp(n, lambda)
x[1:10]

hist(x,
    freq = FALSE, breaks = "FD", ylim = c(0, 0.6),
    main = "Método de inversión (Doble exponencial)"
)
lines(density(x), col = "blue")
curve(ddexp(x, lambda), add = TRUE, col = 2)

# la función de distribución de la doble exponencial
pddexp <- function(x, lambda) {
    x <- ifelse(x < 0,
        exp(lambda * x) / 2,
        1 - exp(-lambda * x) / 2
    )
    return(x)
}
# pasamos la función como argumento a ks.test()
ks.test(x, pddexp, lambda = lambda)

# --------------------------------------------------------------------------------
# EG Weibull
# F(x) = 1-exp(l(\l/x)^\alpha)

f <- function(x, lambda, alpha) {
    alpha * lambda^alpha * x^(alpha - 1) * exp(-(lambda * x)^alpha)
}

rweib <- function(n, lambda, alpha) {
    u <- runif(n)
    x <- (-log(1 - u))^(1 / alpha) / lambda
    return(x)
}

n <- 1000
set.seed(1)
lambda <- 0.5
alpha <- 2
x <- rweib(n, lambda, alpha)
x[1:10]

hist(x,
    freq = FALSE, breaks = "FD", ylim = c(0, 0.5),
    main = "Método de inversión (Weibull)"
)
lines(density(x), col = "blue")
curve(ddexp(x, lambda), add = TRUE, col = 2)

ks.test(x, pweibull, shape = alpha, scale = 1 / lambda)

# Problema: y si la inversa es difícil de calcular? Numéricamente? Alternativa:

# Método de aceptación-rechazo

# 2 pasos:
#   Generamos un valor candidato para la variable aleatoria.
#   Aceptamos el valor generado sólo si verica una condición particular.
# Alg:
#   Generas U
#   Generas candidato Y desde g(y)
#   Comprobación:
#       U < 1/M * f(Y)/g(Y) ==> X = Y se acepta como valor simulado de f
#       Si no, se rechaza el valor

# EG Beta desde Uniforme
a <- 2.7
b <- 6.3
# auxiliar? la uniforme basta. g(y) = unif
# Necesitamos calcular la M

res <- optimize(
    f = function(x) dbeta(x, shape1 = a, shape2 = b),
    maximum = TRUE, interval = c(0, 1)
)
res
M <- res$objective

a <- 2.7
b <- 6.3
curve(dbeta(x, shape1 = a, shape2 = b), 0, 1)
curve(M * dunif(x), 0, 1, add = TRUE, col = 2, lty = 2)
legend("right",
    legend = c(
        "f(x): Beta (a=2.7, b=6.3)",
        "g(x)*M"
    ),
    col = c(1, 2), lty = c(1, 2), bty = "n"
)

n <- 1000
x <- double(n)
f <- function(x) dbeta(x, shape1 = a, shape2 = b)
g <- function(x) 1
# Generación de los n valores a través del algoritmo
set.seed(1)
contador <- 0
for (i in 1:n) {
    repeat {
        u <- runif(1)
        y <- runif(1)
        contador <- contador + 1
        if (u <= f(y) / (M * g(y))) {
            break
        }
    }
    x[i] <- y
}

# Número de simulaciones total que han sido necesarias
contador
# Veremos después que el número esperado
n * M

# Comprobamos que la secuencia generada procede de la distribución deseada
hist(x, freq = FALSE, breaks = "FD", main = "Método de aceptación-rechazo (Beta)")
lines(density(x), col = "blue")
curve(dbeta(x, shape1 = a, shape2 = b), add = TRUE, col = 2)
ks.test(x, pbeta, shape1 = a, shape2 = b)

# Nota: eficiencia del algoritmo, elección de g
# Cuanto más cerca esté M de 1, más eficiente será (M=1 ==> f = g, no tiene sentido)
# En alguna familia paramétrica,
# M_opt = min theta max x f(x)/g_theta(x)

# EG Tomamos una doble exponencial como aux:

# Densidad de la doble exponencial:
ddexp <- function(x, lambda) lambda * exp(-lambda * abs(x)) / 2
# Construimos una función que dado lambda nos da el M óptimo
M.lambda <- function(lambda) {
    optimize(
        f = function(x) dnorm(x) / ddexp(x, lambda), maximum = TRUE,
        interval = c(0, 2)
    )$objective
}
# Minimizamos la función anterior en lambda para obtener el óptimo
# y el correspondiente M
res <- optimize(M.lambda, interval = c(0.5, 2))
res

lambda.opt <- res$minimum
M <- res$objective

curve(dnorm(x), -3, 3, ylim = c(0, 0.7))
curve(M * ddexp(x, lambda.opt), add = TRUE, col = 2, lty = 2)
legend("topright",
    legend = c("f(x): N(0,1)", "g(x)*M"),
    col = c(1, 2), lty = c(1, 2), bty = "n"
)

# Función para simular de la doble exponencial (método de inversión)
rddexp <- function(n, lambda) {
    u <- runif(n)
    x <- ifelse(u < 0.5, log(2 * u) / lambda, -log(2 * (1 - u)) / lambda)
    return(x)
}
# Método de aceptación-rechazo para simular la normal
n <- 1000
x <- double(n)
f <- function(x) dnorm(x)
g <- function(x) ddexp(x, lambda = lambda.opt)
# Generación de los n valores a través del algoritmo
set.seed(1)
contador <- 0
for (i in 1:n) {
    u <- runif(1)
    y <- rddexp(1, lambda.opt)
    contador <- contador + 1
    while (u > f(y) / (M * g(y))) {
        u <- runif(1)
        y <- rddexp(1, lambda.opt)
        contador <- contador + 1
    }
    x[i] <- y
}
# Número de simulaciones total que han sido necesarias
contador
# El número esperado es
n * M
# Comprobamos que la secuencia generada procede de la distribución deseada
hist(x, freq = FALSE, breaks = "FD", main = "Método de aceptación-rechazo (Normal)")
lines(density(x), col = "blue")
curve(dnorm(x), add = TRUE, col = 2)
# Confirmamos con el test de Kolmogorov-Smirnov
ks.test(x, pnorm)

1 / M # tasa de aceptación

# --------------------------------------------------------------------------------
# modif a A-R

# --------------------------------------------------------------------------------
# Otros métodos

# Composición
#  Si la densidad objetivo es una mixtura discreta de densidades
#  eso es, es la suma (discreta ie no integral) de funciones de densidad
# -> escoges j.
# -> generas X desde f_j

# Box Muller
# Para generar normales independientes
# E <- Exp(1); U <- Unif
# ==> X1 = sqrt(2E) cos(2piU) es normal
# ==> X2 = sqrt(2E) sin(2piU) es normal
# y son indep

# Aplicaciones
# aproximar la distribución de estimadores

# EG 1
mu <- 10
sigma <- 1
n <- 10 # tamaño de la muestra
nsim <- 1000 # número de simulaciones
# simulamos nsim=1000 muestras de tamaño n=10
# y las almacenamos por filas en una matriz (nsim*n)
set.seed(1)
muestras <- matrix(rnorm(nsim * n, mean = mu, sd = sigma), ncol = n, nrow = nsim)
# A partir de cada muestra calculamos la media muestral
medias <- rowMeans(muestras)
# medias contiene los nsim=1000 valores simulados de la media muestral
# un histograma de estos valores nos da una aproximación de la distribución muestral
hist(medias, breaks = 20, freq = FALSE, main = "Distribución muestral de la media")
# superponemos la densidad suavizada
lines(density(medias), col = "blue")
# ahora la distribución exacta (N(mu, sigma/sqrt(n)))
curve(dnorm(x, mean = mu, sd = sigma / sqrt(n)), col = 2, add = TRUE)

# Ej Comprobar TCL
# 1.
# 2.
# 3.

# Eg 2 mediana

mu <- 10
sigma <- 1
n <- 10 # tamaño de la muestra
nsim <- 1000 # número de simulaciones
# simulamos nsim=1000 muestras de tamaño n=10
# y las almacenamos por filas en una matriz (nsim*n)
set.seed(1)
muestras <- matrix(rnorm(nsim * n, mean = mu, sd = sigma), ncol = n, nrow = nsim)
# A partir de cada muestra calculamos la medianal
medianas <- apply(muestras, 1, median)
# medianas contiene los nsim=1000 valores simulados de la media muestral
# un histograma de estos valores nos da una aproximación de la distribución muestral
hist(medianas, breaks = 20, xlim = c(9, 11), freq = FALSE, main = "Distribución muestral de la mediana")
# superponemos la densidad suavizada
lines(density(medianas), col = "blue")

# Comparación de estimadores

# Sea f una f densidad de una N(0,1) contaminada por una N(3,3) con frecuencias 0.95, 0.05 respectivamente.
# Con el método de composición:
n <- 100
set.seed(1)
j <- rbinom(n, 1, 0.05) # 1's y 0's indicando si es f2 o f1, respectivamente
x <- rnorm(n, 3 * j, 1 + 2 * j) # esto genera n valores de f1 o f2 dependiendo de j
# representamos un histograma de la muestra generada
hist(x, breaks = "FD", freq = FALSE, main = "Muestra contaminada")
# superponemos la densidad desde la que se generó
curve(0.95 * dnorm(x, 0, 1) + 0.05 * dnorm(x, 3, 3), add = TRUE, col = 2)
# Con datos anómalos
mean(x)
median(x)
# Dan resultados similares

n <- 100
set.seed(1)
j <- rbinom(n * nsim, 1, 0.05)
muestras <- matrix(rnorm(n * nsim, 3 * j, 1 + 2 * j), nrow = nsim, ncol = n)
# cada fila de la matriz 'muestras' es una muestra de tamaño n
# calculamos los estimadores
medias <- apply(muestras, 1, mean)
medianas <- apply(muestras, 1, median)
# comparamos la distribución muestral usando un boxplot
boxplot(medias, medianas, names = c("Media", "Mediana"))
# una línea horizontal indicando el valor a estimar (mu=0)
abline(h = 0, col = 2)
# La media se ve bastante afectada por valores anómalos

# Estimamos los errores cuadráticos medios E[(theta_gorro - theta)^2]
ecm.media <- mean((medias - 0)^2)
ecm.media
ecm.mediana <- mean((medianas - 0)^2)
ecm.mediana
# boxplot de las desviaciones al cuadrado
boxplot(medias^2, medianas^2,
    ylab = "Errores cuadráticos",
    names = c("Media", "Mediana")
)


library(tidyverse)
library(nloptr)
library(dplyr)
library(modelsummary)
library(broom.mixed)

#Q.4

seed.set(1234567)

X <- matrix(rnorm(1000000), nrow = 100000, ncol = 10)
X [, 1]<- 1

eps <- matrix(rnorm(100000, mean = 0, sd = 0.5), nrow = 100000)

beta <- matrix(c(1.5, -1, -0.25, 0.75, 3.5, -2, 0.5, 1, 1.25, 2))

Y <- X%*%beta + eps

#Q.5

beta_hat <- solve(crossprod(X))%*%(crossprod(X,Y))

comparison <- as_tibble_col(beta_hat,"beta_hat")
comparison <- comparison %>% add_column(beta)
comparison

#Q.6

obj_func <- function(beta,Y,X) {
  return (sum((Y-X%*%beta)^2))
}

gradient <- function(beta_graid,Y,X) {
  return (as.vector(-2*t(X)%*%(Y-X%*%beta_graid)))
}

# initial values
beta0 <- matrix(rnorm(10, mean = 0, sd=0.5), 10, 1)

gradient_descent <- function(Y, X, beta_g, object, grad, learn_rate, tol, max_iter) {

  n=dim(Y)[1]
  m <- beta_g
  c <- matrix(rnorm(n,mean = 0,sd=0.5),n,1)

  yhat <- X%*%m+c
  MSE <- object(m,Y,X)

  converged = F
  iterations = 0

  while(converged == F) {
    m_new <- m - learn_rate * grad(m,Y,X)
    m <- m_new
    c <- Y-X%*%m
    yhat <- X%*%m+c
    MSE_new <- object(m,Y,X)
    if(MSE - MSE_new <= tol) {
      converged = T

      return(m)
    }
    iterations = iterations + 1
    if(iterations > max_iter) {
      converged = T
      return(m)
    }
  }
}

# Run the function

learn_rate <- 0.0000003
tol <- 0.0000000001
max_iter <- 1000

beta_hat_gradident <- gradient_descent(Y, X, beta0,obj_func, gradient, learn_rate , tol , max_iter)

#Q.7

options <- list("algorithm"="NLOPT_LD_LBFGS","xtol_rel"= 1.0e-6,"maxeval"= 1e3)
beta_BFGS <- nloptr( x0=beta0,eval_f=obj_func,eval_grad_f=gradient,opts=options,Y=Y,X=X)
beta_BFGS$solution

options <- list("algorithm"="NLOPT_LN_NELDERMEAD","xtol_rel"=1.0e-8)
beta_NM <- nloptr( x0=beta0,eval_f=obj_func,opts=options,Y=Y,X=X)

beta_hat_BFGS <- beta_NM$solution

#Q.8

gradient_MLE <- function (theta ,Y, X) {
  grad <- as.vector( rep (0, length (theta )))
  beta <- theta [1:( length ( theta) -1)]
  sig <- theta [ length (theta )]
  grad [1:( length ( theta) -1)] <- -t(X)%*%(Y - X%*%beta )/(sig ^2)
  grad[ length (theta )] <- dim (X)[1] /sig - crossprod (Y-X%*%beta )/(sig^3)
  return ( grad )
}
objfun_MLE <- function(beta, Y , X) {
  return (sum((Y-X%*%beta[1:( length (beta) -1)])^2))
}
#theta0 <- runif(dim(X)[2]+1)
theta0 <- append(as.vector(summary(lm(Y~X-1))$coefficients[,1]),runif(1))
options <- list("algorithm"="NLOPT_LD_LBFGS","xtol_rel"=1.0e-6,"maxeval"=1e3)
beta_MLE <- nloptr(x0=theta0, eval_f=objfun_MLE, eval_grad_f=gradient_MLE, opts=options, Y=Y, X=X)

beta_hat_MLE <- round(beta_MLE$solution,3)

#Q.9

beta_hat_ols <- lm(Y~X-1)

modelsummary(beta_hat_ols, output = 'latex')


## Author: Sergio García Prado

rm(list = ls())

y <- c(1997, 904, 906)
k <- length(y) + 1
n <- 3839

## a)
####

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

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

opt <- optim(rep(1 / k, k - 1), NegativeLogLikelihood, y = y, n = n,
             hessian = TRUE)
p.hat <- opt$par
p.hat.var <- solve(opt$hessian)

g.function <- function(p) {
  c(4 * p[1] + 4 * p[2] - 3,
    p[2] - p[3])
}

g.derivative <- function(p) {
  matrix(c(4,  4,  0,
           0,  1, -1),
         2, 3, byrow = TRUE)
}

g.zero <- rep(0, 2)

## Sandwitch Estimator.
(W <- (g.function(p.hat) - g.zero) %*% g.derivative(p.hat) %*% p.hat.var %*% t(g.derivative(p.hat)) %*% (g.function(p.hat) - g.zero))
# 3.809448e-07

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

## b)
####

LogLikelihoodH0 <- function(theta, y, n) {
  LogLikelihood(c((2 + theta) / 4, (1 - theta) / 4,
                  (1 - theta) / 4), y, n)
}

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

opt.hzero <- optim(runif(1), NegativeLogLikelihoodH0, y = y, n = n,
                   hessian = TRUE)
(theta.hat <- opt.hzero$par)
# 0.0357236506373738

(theta.hat.var <- solve(opt.hzero$hessian)[1])
# 3.63072505048225e-05

(LRT <- 2 * (LogLikelihood(p.hat, y, n) - LogLikelihoodH0(theta.hat, y, n)))
# 2.01858568600073

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

## c)
####

# Done in (b).

## d)
####

alpha <- 0.05

## Classic Wald Confidence Interval.
theta.hat + c(-1, 1) * qnorm(1 - alpha / 2) * sqrt(theta.hat.var)
# 0.0238929671430484 0.0474947392364342

## Likelihood Ratio Confidence Interval.
## We'll look for the intersection between LogLikelihood function and Chisq critic value.

f <- function(theta, p, y, n, alpha, df) {
   2 * (LogLikelihood(p, y, n) - LogLikelihoodH0(theta, y, n)) - qchisq(1 - alpha / 2, df = df)
}

c(uniroot(f, c(0, theta.hat), p.hat, y, n, alpha, df=2)$root,
  uniroot(f, c(theta.hat, 1), p.hat, y, n, alpha, df=2)$root)
# 0.0234000324864232 0.0513203185453315


sigma=(70-40)/4

alpha=0.025
z.alpha=qnorm(1-alpha)

E=4 #given
#  number of replications is
n=((sigma^2)*(z.alpha^2))/E^2
print(n)


# ************************************************
### simon munzert
### logit and probit
# ************************************************

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

### Running a logit model -----------------------

data("turnout") # example dataset from the Zeliig package
?turnout
tabyl(turnout$vote)

# estimation with glm function
logit_out <- glm(vote ~ age + educate + income,
                 family = binomial, data = turnout)
summary(logit_out)

# estimation with manually programmed logit likelihood function
# see also http://www.stat.cmu.edu/~cshalizi/uADA/12/lectures/ch12.pdf
logit_loglik <- function(theta, y, X){
  b <- theta
  logl <- sum(-y*log(1+exp(- X %*% b)) # for y = 1
              - (1-y)*log(1+exp(X %*% b))) # for y = 0
  return(-logl)
}

logit_out_manual <- optim(rep(1,4), logit_loglik, y = turnout$vote, X = as.matrix(cbind(1,(turnout[,c("age", "educate", "income")]))), method = "BFGS")
logit_out_manual

### Running a probit model ---------------------

# estimation with glm function
probit_out <- glm(vote ~ age + educate + income,
                 family = binomial(link = "probit"), data = turnout)
summary(probit_out) # careful - the coefficients are not directly comparable with those from the logit model! (Divide logit coefficients by approximately 1.6 to arrive at probit coefficients; see http://andrewgelman.com/2006/06/06/take_logit_coef/)

# again, a little simulation
n <- 100
x <- rnorm (n)
a <- 1.5
b <- 1
y <- rbinom (n, 1, invlogit(a + b*x))
M1 <- glm (y ~ x, family=binomial(link="logit"))
summary (M1)
M2 <- glm(y ~ x, family=binomial(link="probit"))
summary (M2)

### Goodness of fit ----------------------------

# Log-Likelihood
LogLik <- logLik(logit_out)
LogLik

# McFadden's Pseudo-R^2
logit_out_empty <- glm(vote ~ 1, family = binomial, data = turnout) # estimate empty model
Pseudo_R2 <- 1 - (as.numeric(logLik(logit_out)))/(as.numeric(logLik(logit_out_empty)))
Pseudo_R2

# Likelihood ratio Chi-squared
chi2_test_stat <- 2*(as.numeric(logLik(logit_out)) - as.numeric(logLik(logit_out_empty)))
lr_test <- 1 - pchisq(chi2_test_stat, 1)
chi2_test_stat
lr_test

# BIC
# see J. Scott Long and Jeremy Freese 2000. Stata Technical Bulletin STB-56:34-40
D.M.mod <- as.numeric(-2*LogLik)
N <- length(logit_out$y)
k <- length(logit_out$coef)
df.mod <- N - k
BIC.mod <- D.M.mod - df.mod*log(N)
BIC.mod

### Precision and recall -----------------------

turnout$vote_pred_link <- predict(logit_out, type = "link")
turnout$vote_pred_prob <- predict(logit_out, type = "response")
turnout$vote_pred <- ifelse(turnout$vote_pred_prob > .5, 1, 0)

plot(turnout$vote_pred_link, turnout$vote_pred_prob) # links versus response

tab <- table(turnout$vote, turnout$vote_pred)
colnames(tab) <- c("pred vote NO", "pred vote YES")
rownames(tab) <- c("rep vote NO", "rep vote YES")
tab

# precision:
sum(turnout$vote_pred == 1 & turnout$vote == 1) / sum(turnout$vote_pred == 1)

# recall:
sum(turnout$vote_pred == 1 & turnout$vote == 1) / sum(turnout$vote == 1)

### From log odds to odds ratios and probabilities ---

summary(logit_out)
cbind(log_odds <- round(coef(logit_out), 4),
      odds_ratios <- round(exp(coef(logit_out)), 4),
      probabilities <- round(1/(1+exp(-coef(logit_out))), 4))

# look at an empty model again to understand how the log odds and the probability are related
logit_out_empty <- glm(vote ~ 1,
                 family = binomial, data = turnout)
summary(logit_out_empty)
summary(turnout$vote)
1/(1+exp(-coef(logit_out_empty)))

# here's a little logit to probability function
logit2prob <- function(logit){
  odds <- exp(logit)
  prob <- odds / (1 + odds)
  return(prob)
}
logit2prob(.5)
logit2prob(-.5)

### Predict marginal effects with the margins package ---

library(margins)
summary(logit_out)
margins(logit_out, type = "link") # this equals the log odds

margins(logit_out, type = "response") # this equals marginal probabilities

margins(logit_out, at = list(age = c(25, 60),
                             educate = c(10, 10),
                             income = c(3, 3)))

marginal_effects(logit_out) # unit-specific marginal effects with respect to all variables

### Visualize probabilities - graphical solution ---

df <- data.frame(age = min(turnout$age):max(turnout$age), educate = 10, income = 4)
model_preds <- predict(logit_out, newdata = df, type = 'response', se.fit = TRUE)
df$prediction <- model_preds$fit
df$lower <- model_preds$fit - 1.96 * model_preds$se.fit
df$upper <- model_preds$fit + 1.96 * model_preds$se.fit

# graph predicted probabilities
ggplot(df) + geom_line(aes(x = age, y = prediction)) + theme_bw() + geom_ribbon(aes(ymin = lower, ymax = upper, x = age), alpha = .3)

# alternatively, use cplot() command from the margins package
cplot(logit_out, "age")

# graph marginal effects
cplot(logit_out, "age", what = "effect")

## Interactions in logit models -------------

logit_out_int <- glm(vote ~ educate + income*age,
                 family = binomial, data = turnout)
summary(logit_out_int)

hist(turnout$income)

df <- data.frame(educate = 12, age = rep(min(turnout$age):max(turnout$age), 10), income = rep(1:10, each = diff(range(turnout$age))+1))
model_preds <- predict(logit_out, newdata = df, type = 'response', se.fit = TRUE)
df$prediction <- model_preds$fit

plot(df$age, df$prediction, cex = 0)
income_values <- unique(df$income)
for(i in income_values) {
 with(filter(df, income == income_values[i]), lines(age, prediction))
  }
#plot(df$income, df$prediction)

# also see
browseURL("https://cran.r-project.org/web/packages/margins/vignettes/Introduction.html")
# --> section "Interactions in Logit"

## Credit Default data -------------

?Default
dat <- Default
dat$def <- ifelse(as.numeric(dat$default) == 2, 1, 0)
table(dat$def)

pdf(file="../output/logit-viz-1.pdf", height=4, width=6, family="URWTimes")
par(oma=c(0,0,0,0))
par(mar=c(4,4,1.2,.5))
plot(dat$balance, dat$def, col = "blue", xlab = "Balance", ylab = "Credit default (No/Yes)")
abline(h=0:1, lty = 3)
abline(h=.5, lty = 3)
dev.off()

pdf(file="../output/logit-viz-2.pdf", height=4, width=6, family="URWTimes")
par(oma=c(0,0,0,0))
par(mar=c(4,4,1.2,.5))
plot(dat$balance, dat$def, col = "blue", xlab = "Balance", ylab = "Credit default (No/Yes)")
abline(h=0:1, lty = 3)
abline(h=.5, lty = 3)
abline(lm(def~balance, data = dat), col = "red", lwd = 2)
dev.off()

pdf(file="../output/logit-viz-3.pdf", height=4, width=6, family="URWTimes")
par(oma=c(0,0,0,0))
par(mar=c(4,4,1.2,.5))
plot(dat$balance, dat$def, col = "blue", xlab = "Balance", ylab = "Credit default (No/Yes)")
abline(h=0:1, lty = 3)
abline(h=.5, lty = 3)
# logit fit
fit = glm(def ~ balance, data=dat, family = binomial)
newdat <- data.frame(balance = seq(min(dat$balance), max(dat$balance),len=100))
newdat$vs = predict(fit, newdata=newdat, type="response")
lines(vs ~ balance, newdat, col="red", lwd=2)
dev.off()

pdf(file="../output/logit-viz-4.pdf", height=4, width=6, family="URWTimes")
par(oma=c(0,0,0,0))
par(mar=c(4,4,1.2,.5))
plot(dat$balance, dat$def, col = "blue", xlab = "Balance", ylab = "Credit default (No/Yes)")
abline(h=0:1, lty = 3)
abline(h=.5, lty = 3)
# logit fit
fit = glm(def ~ balance, data=dat, family = binomial)
newdat <- data.frame(balance = seq(min(dat$balance), max(dat$balance),len=100))
newdat$vs = predict(fit, newdata=newdat, type="response")
lines(vs ~ balance, newdat, col="red", lwd=2)
abline(v=c(500, 1000), col = "black", lwd = 3)
arrows(500, .3, 1000, .3, lwd = 3)
dev.off()

pdf(file="../output/logit-viz-5.pdf", height=4, width=6, family="URWTimes")
par(oma=c(0,0,0,0))
par(mar=c(4,4,1.2,.5))
plot(dat$balance, dat$def, col = "blue", xlab = "Balance", ylab = "Credit default (No/Yes)")
abline(h=0:1, lty = 3)
abline(h=.5, lty = 3)
# logit fit
fit = glm(def ~ balance, data=dat, family = binomial)
newdat <- data.frame(balance = seq(min(dat$balance), max(dat$balance),len=100))
newdat$vs = predict(fit, newdata=newdat, type="response")
lines(vs ~ balance, newdat, col="red", lwd=2)
abline(v=c(1500, 2000), col = "black", lwd = 3)
arrows(1500, .3, 2000, .3, lwd = 3)
dev.off()

## Probability and cumulative density functions --------------

# probability and cumulative density functions of the logistic distribution
z_scores <- seq(-5, 5, by = .1)
dlogistic_values <- dlogis(z_scores, 0, 1)
plot(z_scores, dlogistic_values,  type = "l", main = "pdf of the Logistic", xlab= "Z score", ylab="Probability Density", col = "blue")

dlogistic_values <- plogis(z_scores, 0, 1)
plot(z_scores, dlogistic_values,  type = "l", main = "cdf of the Logistic", xlab= "Z score", ylab="Probability Density", col = "blue")
# playing with the scale parameter
lines(z_scores, plogis(z_scores, 0, 2), col = "red")
lines(z_scores, plogis(z_scores, 0, .5), col = "red")
# playing with the location parameter
lines(z_scores, plogis(z_scores, -2, 1), col = "green")
lines(z_scores, plogis(z_scores, 2, 1), col = "green")

# probability and cumulative density functions of the standard normal distribution
z_scores <- seq(-5, 5, by = .1)
dnorm_values <- dnorm(z_scores, 0, 1)
plot(z_scores, dnorm_values,  type = "l", main = "pdf of the Standard Normal", xlab= "Z score", ylab="Probability Density", col = "blue")

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


##### Chapter 10: Evaluating Model Performance -------------------

## Confusion matrixes in R ----
sms_results <- read.csv("sms_results.csv")
head(sms_results)
head(subset(sms_results, actual_type != predict_type))

# specifying vectors
table(sms_results$actual_type, sms_results$predict_type)
# using the formula interface
xtabs(~ actual_type + predict_type, sms_results)
# using the CrossTable function
library(gmodels)
CrossTable(sms_results$actual_type, sms_results$predict_type)

# accuracy and error rate calculation --
# accuracy
(154 + 1202) / (154 + 1202 + 5 + 29)
# error rate
(5 + 29) / (154 + 1202 + 5 + 29)
# error rate = 1 - accuracy
1 - 0.9755396

## Beyond accuracy: other performance measures ----
library(caret)
confusionMatrix(sms_results$predict_type, sms_results$actual_type, positive = "spam")

# Kappa statistic
# example using SMS classifier
pr_a <- 0.865 + 0.111
pr_a

pr_e <- 0.868 * 0.886 + 0.132 * 0.114
pr_e

k <- (pr_a - pr_e) / (1 - pr_e)
k

library(vcd)
Kappa(table(sms_results$actual_type, sms_results$predict_type))

library(irr)
kappa2(sms_results[1:2])

# Sensitivity and specificity
# example using SMS classifier
sens <- 154 / (154 + 29)
sens

spec <- 1202 / (1202 + 5)
spec

# example using the caret package
library(caret)
sensitivity(sms_results$predict_type, sms_results$actual_type, positive = "spam")
specificity(sms_results$predict_type, sms_results$actual_type, negative = "ham")

# Precision and recall
prec <- 154 / (154 + 5)
prec

rec <- 154 / (154 + 29)
rec

# example using the caret package
library(caret)
posPredValue(sms_results$predict_type, sms_results$actual_type, positive = "spam")
sensitivity(sms_results$predict_type, sms_results$actual_type, positive = "spam")

# F-measure
f <- (2 * prec * rec) / (prec + rec)
f

f2 <- (2 * 154) / (2 * 154 + 5 + 29)
f2

## Visualizing Performance Tradeoffs ----
library(ROCR)
pred <- prediction(predictions = sms_results$prob_spam,
                   labels = sms_results$actual_type)

# ROC curves
perf <- performance(pred, measure = "tpr", x.measure = "fpr")
plot(perf, main = "ROC curve for SMS spam filter", col = "blue", lwd = 2)

# add a reference line to the graph
abline(a = 0, b = 1, lwd = 2, lty = 2)

# calculate AUC
perf.auc <- performance(pred, measure = "auc")
str(perf.auc)
as.numeric(perf.auc@y.values)

# partitioning data
library(caret)
credit <- read.csv("credit.csv")

# Holdout method
# using random IDs
random_ids <- order(runif(1000))
credit_train <- credit[random_ids[1:500],]
credit_validate <- credit[random_ids[501:750], ]
credit_test <- credit[random_ids[751:1000], ]

# using caret function
in_train <- createDataPartition(credit$default, p = 0.75, list = FALSE)
credit_train <- credit[in_train, ]
credit_test <- credit[-in_train, ]

# 10-fold CV
folds <- createFolds(credit$default, k = 10)
str(folds)
credit01_train <- credit[folds$Fold01, ]
credit01_test <- credit[-folds$Fold01, ]

## Automating 10-fold CV for a C5.0 Decision Tree using lapply() ----
library(caret)
library(C50)
library(irr)

set.seed(123)
folds <- createFolds(credit$default, k = 10)

cv_results <- lapply(folds, function(x) {
  credit_train <- credit[x, ]
  credit_test <- credit[-x, ]
  credit_model <- C5.0(default ~ ., data = credit_train)
  credit_pred <- predict(credit_model, credit_test)
  credit_actual <- credit_test$default
  kappa <- kappa2(data.frame(credit_actual, credit_pred))$value
  return(kappa)
})

str(cv_results)
mean(unlist(cv_results))


#Installing package
install.packages("ggplot2")
library('ggplot2')
#Scattered Plots
library(readr)
options(repr.plot.width = 6, repr.plot.height = 6)
Iris <- read.csv('Iris.csv')
class(Iris)
#[1] "data.frame"
View(Iris)
head(Iris)

summary(Iris)

ggplot(data=Iris,aes(x=SepalWidthCm, y=SepalLengthCm)) + geom_point() + theme_minimal()
ggplot(data=Iris,aes(x=SepalWidthCm, y=SepalLengthCm,color=Species)) + geom_point() + theme_minimal()
#Creating histograms
hist(iris$Sepal.Width, freq=NULL, density=NULL, breaks=12,
xlab="Sepal Width", ylab="Frequency", main="Histogram of Sepal Width")

library(ggplot2)

histogram <- ggplot(data=iris, aes(x=Sepal.Width))
histogram + geom_histogram(binwidth=0.2, color="black", aes(fill=Species)) +
xlab("Sepal Width") + ylab("Frequency") + ggtitle("Histogram of Sepal Width")
library(ggplot2)

#Density Plots
ggplot(iris) +
geom_density(aes(x = Petal.Width, fill = Species), alpha=0.25)

#Probability Plots
p1 <- ggplot(data = Iris, aes(PetalWidthCm)) +
 stat_function(fun = dnorm, n = 101, args = list(mean = 0, sd = 1)) + ylab("") +
 scale_y_continuous(breaks = NULL)
 p1

p2 <- ggplot(data = Iris, aes(PetalWidthCm)) +
 stat_function(fun = pnorm, n = 101, args = list(mean = 0, sd = 1)) + ylab("") +
 scale_y_continuous(breaks = NULL)
p2

p4 <- ggplot(data = Iris, aes(PetalWidthCm)) +
 stat_function(fun = rnorm, n = 101, args = list(mean = 0, sd = 1)) + ylab("") +
 scale_y_continuous(breaks = NULL)
p4

#Box plots

ggplot(data=Iris,aes(x=Species, y=SepalLengthCm,color=Species)) + geom_boxplot() +theme_minimal()+
 theme(legend.position="none")

ggplot(data=Iris,aes(x=Species, y=SepalLengthCm,color=Species)) + geom_violin() +theme_minimal()+
 theme(legend.position="none")

#Residual Plots
ggplot(lm(Sepal.Length~Sepal.Width, data=iris)) + geom_point(aes(x=.fitted, y=.resid))


heat_loss <- c(86,80,77 , 78,84,75 ,33,38,43)
temperature <- c(20,20,20,40,40,40,60,60,60)
plot(temperature,heat_loss)
# Apply the lm() function.
relation <- lm(heat_loss~temperature)

print(summary(relation))
 # linear regression model : y= 109-1.07*x
anova(relation)
#  y and y-ycap for the nine observations
cbind( temperature,heat_loss,predict(relation),resid(relation))
plot(predict(relation),resid(relation))


# Sales Volume
y=c(25,55,50,75,110,138,90,60,10,100)
# % of Ingredients Purchased Directly,
x=c(10,18,25,40,50,63,42,30,5,55)
# Sxy is the sum of x deviations times y deviations and Sxx is the sum of x deviations squared.

Sxx=(x-mean(x))^2
Sxy=(x-mean(x))*(y-mean(y))

# least-squares estimates of slope and intercept
Beta1=sum(Sxy)/sum(Sxx)
Beta0=mean(y)-Beta1*mean(x)
 print(Beta1)
 print(Beta0)


###########################
# SECTION 2.13: EXERCISES #
###########################

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

# 1. Compute the per 100,000 murder rate for each state and store it in an object called `murder_rate`. Then use logical operators to create a logical vector named `low` that tells us which entries of `murder_rate` are lower than 1.

state <- murders$state
population <- murders$population
total <- murders$total
region <- murders$region
abb <- murders$abb

murder_rate <- total / population * 100000
low <- murder_rate < 1
low

# 2. Now use the results from the previous exercise and the function which to determine the indices of `murder_rate` associated with values lower than 1.

which(murder_rate < low)

# 3. Use the results from the previous exercise to report the names of the states with murder rates lower than 1.

states[low]

# 4. Now extend the code from exercises 2 and 3 to report the states in the Northeast with murder rates lower than 1. Hint: use the previously defined logical vector low and the logical operator &.

northeast <- region == 'Northeast'
state[low & northeast]

# 5. In a previous exercise we computed the murder rate for each state and the average of these numbers. How many states are below the average?

avg = mean(murder_rate)
below_avg <- murder_rate < avg
sum(below_avg)

# 6. Use the match function to identify the states with abbreviations AK, MI, and IA. Hint: start by defining an index of the entries of murders$abb that match the three abbreviations, then use the [ operator to extract the states.

ind <- match(c('AK', 'MI', 'IA'), abb)
state[ind]

# 7. Use the %in% operator to create a logical vector that answers the question: which of the following are actual abbreviations: MA, ME, MI, MO, MU?

some_abbs <- c('MA', 'ME', 'MI', 'MO', 'MU')
some_abbs[some_abbs %in% abb]

# 8. Extend the code you used in exercise 7 to report the one entry that is not an actual abbreviation. Hint: use the ! operator, which turns FALSE into TRUE and vice versa, then which to obtain an index.

some_abbs[!some_abbs %in% abb]


library(Rcpp)
library(ggplot2)
library(rstan)
library(reshape2)
library(beepr)

## External files
source(paste(getwd(), "../../sir-functions", "StocSIRSstan.r", sep = "/"))
stanfile <- "sirs-euler.stan"

#set.seed(6287502)

T 		<- 200
i_infec <- 5
steps 	<- 7
N 		<- 500
sigma 	<- 3

true_pars <- c(R0 = 3.0,  	# new infected people per infected person
          	   r = 0.1, 	# recovery rate
		  	   N = 500,    	# population size
		  	   eta = 0.5, 	# geometric random walk
		  	   berr = 0.5, 	# Beta geometric walk noise
          	   re = 1)    # resuceptibility rate

true_init_cond <- c(S = N - i_infec,
					I = i_infec,
					R = 0)

sdeout <- StocSIRS(true_init_cond, true_pars, T, steps)
colnames(sdeout) <- c('S','I','R','B')

infec_counts_raw <- sdeout[,'I'] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

#quartz()
qplot(0:T, sdeout[,'I'], geom = "line", xlab = "week", ylab = "Infection Count") +
    geom_point(aes(y = infec_counts)) +
    theme_bw()

## Stan setup
##

datlen <- T*steps + 1

data <- matrix(data = -1, nrow = T+1, ncol = steps)
data[,1] <- infec_counts
standata <- as.vector(t(data))[1:datlen]

sir_data <- list( T = datlen,   	# simulation time
                  y = standata, 	# infection count data
                  N = 500,      	# population size
                  h = 1/steps )   	# step size per day

rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

stan_options <- list(   chains = 1,    		# number of chains
                        iter   = 2000, 		# iterations per chain
                        warmup = 1000, 		# warmup interations
                        thin   = 1 )   		# thinning number

## fit
##
hmctime <- system.time(fit <- with(stan_options,
                        stan( file    = stanfile,
                              data    = sir_data,
                              chains  = chains,
                              iter    = iter,
                              warmup  = warmup,
                              thin    = thin)
                        )
            )

# Done beep
beep()

## extract fit
##
exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)

paramdata <- data.frame(R0 = melt(exfit[,,'R0'])$value,
                        r = melt(exfit[,,'r'])$value,
                        re = melt(exfit[,,'re'])$value,
                        sigma = melt(exfit[,,'sigma'])$value,
                        eta = melt(exfit[,,'eta'])$value,
                        berr = melt(exfit[,,'berr'])$value,
                        Iinit = melt(exfit[,,'Iinit'])$value )

for (j in 1:datlen) {
	varname <- paste('Bnoise[', j, ']', sep = '')
	paramdata[[varname]] <- melt( exfit[,,varname] )$value
}

#parnames <- c("R0","r","re","sigma","eta","berr","Iinit")
#parvars <- var(paramdata[parnames])
parmeans <- colMeans(paramdata)
#names(parmeans) <- parnames

berrvec <- numeric(datlen)
for (j in 1:datlen) {
	varname <- paste("Bnoise[", j, "]", sep = "")
	berrvec[j] <- parmeans[[varname]]
}

## Setup for generated trajectory
pars_fit <- with( as.list(parmeans),
              c(R0 = R0,
      			r = r,
      			N = N,
      			eta = eta,
      			berr = berr,
      			re = re) )

init_cond_fit <- with( as.list(parmeans),
                   c(S = N - Iinit,
               		 I = Iinit,
               		 R = 0.0) )

sdeout_fit <- StocSIRSstan(init_cond_fit, pars_fit, T, steps, berrvec, datlen)
colnames(sdeout_fit) <- c('S','I','R','B')

#quartz()
qplot(0:T, sdeout[,'I'], geom = "line", xlab = "week", ylab = "Infection Count") +
	geom_line(aes(y = sdeout_fit[,'I']), linetype = "dashed") +
	#geom_line(aes(y = if2data$statemeans[,2]), linetype = "dotted") +
    geom_point(aes(y = infec_counts)) +
    theme_bw()