################################################################################
# Monte Carlo Simulation and Resampling Methods for Social Science             #
# Thomas M. Carsey and Jeffrey J. Harden                                       #
# Chapter 6 File                                                               #
# Last update: 2/28/13                                                         #
################################################################################
# Set the working directory
setwd("C:/Users/jjharden/Dropbox/Research/Sim Book")

# OLS as a Probability Model
set.seed(123456) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store the
                                             # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rnorm(n, b0 + b1*X, 1) # The true DGP, Y ~ N(mu, sigma)
model <- lm(Y ~ X) # Estimate OLS model
vcv <- vcov(model) # Variance-covariance matrix
par.est[i, 1] <- model$coef[1] # Put the estimate for the intercept
                               # in the first column
par.est[i, 2] <- model$coef[2] # Put the estimate for the coefficient on
                               # X in the second column
par.est[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

# Logit
# Inverse Logit Function
inv.logit <- function(p){
return(exp(p)/(1 + exp(p)))
}

# CP Function
coverage <- function(b, se, true, level = .95, df = Inf){ # Estimate,
                                                          # standard error,
                                                          # true parameter,
                                                          # confidence level,
                                                          # and df
qtile <- level + (1 - level)/2 # Compute the proper quantile
lower.bound <- b - qt(qtile, df = df)*se # Lower bound
upper.bound <- b + qt(qtile, df = df)*se # Upper bound
# Is the true parameter in the confidence interval? (yes = 1)
true.in.ci <- ifelse(true >= lower.bound & true <= upper.bound, 1, 0)
cp <- mean(true.in.ci) # The coverage probability
mc.lower.bound <- cp - 1.96*sqrt((cp*(1 - cp))/length(b)) # Monte Carlo error
mc.upper.bound <- cp + 1.96*sqrt((cp*(1 - cp))/length(b))
return(list(coverage.probability = cp, # Return results
            true.in.ci = true.in.ci,
            ci = cbind(lower.bound, upper.bound),
            mc.eb = c(mc.lower.bound, mc.upper.bound)))
}

set.seed(32945) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.logit <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                   # the estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rbinom(n, 1, inv.logit(b0 + b1*X)) # The true DGP, Bernoulli trials
model <- glm(Y ~ X, family = binomial (link = logit)) # Estimate logit model
vcv <- vcov(model) # Variance-covariance matrix
par.est.logit[i, 1] <- model$coef[1] # Put the estimate for the
                                     # intercept in the first column
par.est.logit[i, 2] <- model$coef[2] # Put the estimate for the coefficient
                                     # on X in the second column
par.est.logit[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est.logit[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

cp.beta0.logit <- coverage(par.est.logit[ , 1], par.est.logit[ , 3], b0,
 df = n - model$rank)
cp.beta1.logit <- coverage(par.est.logit[ , 2], par.est.logit[ , 4], b1,
 df = n - model$rank)

pdf("logit-hist1.pdf")

par(mar = c(5, 5.25, .5, .5))
hist(par.est.logit[ , 1], breaks = 25, col = "gray50", ylim = c(0, 150),
 xlab = "", ylab = "", main = "", axes = FALSE)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[0])), cex.lab = 1.5)
title(ylab = expression("Frequency"), line = 3.75, cex.lab = 1.5)
abline(v = b0, lwd = 4)
text(.05, 70, expression("True"~beta[0]~"= 0.20"), cex = 1.5)
box()

dev.off()

pdf("logit-hist2.pdf")

par(mar = c(5, 5.25, .5, .5))
hist(par.est.logit[ , 2], breaks = 25, xlim = c(.1, .9), col = "gray50",
 ylim = c(0, 200), xlab = "", ylab = "", main = "", axes = FALSE)
axis(1, at = seq(.1, .9, .1), cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta)[1]), cex.lab = 1.5)
title(ylab = expression("Frequency"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 4)
text(.75, 125, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()

dev.off()

# Probit
set.seed(3295255) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.probit <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                   # the estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rbinom(n, 1, pnorm(b0 + b1*X)) # The true DGP, Bernoulli trials
model <- glm(Y ~ X, family = binomial (link = probit)) # Estimate probit model
vcv <- vcov(model) # Variance-covariance matrix
par.est.probit[i, 1] <- model$coef[1] # Put the estimate for the
                                      # intercept in the first column
par.est.probit[i, 2] <- model$coef[2] # Put the estimate for the coefficient
                                      # on X in the second column
par.est.probit[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est.probit[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

mean(par.est.probit[ , 1]) # Mean of intercept estimates
mean(par.est.probit[ , 2]) # Mean of coefficient on X estimates
# Coverage probability for the intercept
coverage(par.est.probit[ , 1], par.est.probit[ , 3], b0,
 df = n - model$rank)$coverage.probability
# Coverage probability for the coefficient on X
coverage(par.est.probit[ , 2], par.est.probit[ , 4], b1,
 df = n - model$rank)$coverage.probability

# Ordered Models
library(MASS)
set.seed(8732) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.oprobit <- matrix(NA, nrow = reps, ncol = 2) # Empty matrices to store
taus.oprobit <- matrix(NA, nrow = reps, ncol = 3)    # the estimates
b0 <- 0 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- rnorm(n, 0, 1) # Create a sample of n observations on the
                    # independent variable X

XB <- b0 + b1*X # Systematic component
sd.error <- 1 # SD of the error of the unobserved Y*
# Define the true cutpoints
tau1 <- qnorm(.1, mean = mean(XB), sd = sqrt(var(XB) + sd.error^2))
tau2 <- qnorm(.5, mean = mean(XB), sd = sqrt(var(XB) + sd.error^2))
tau3 <- qnorm(.9, mean = mean(XB), sd = sqrt(var(XB) + sd.error^2))

for(i in 1:reps){ # Start the loop
Y.star <- rnorm(n, XB, sd.error) # The unobserved Y*
Y <- rep(NA, n) # Define Y as a vector of NAs with length n
Y[Y.star < tau1] <- 1 # Set Y equal to a value according to Y.star
Y[Y.star >= tau1 & Y.star < tau2] <- 2
Y[Y.star >= tau2 & Y.star < tau3] <- 3
Y[Y.star >= tau3] <- 4
# Estimate ordered model
model <- polr(as.ordered(Y) ~ X, method = "probit", Hess = TRUE)
vcv <- vcov(model) # Variance-covariance matrix
par.est.oprobit[i, 1] <- model$coef[1] # Put the estimate for the coefficient
                                       # on X in the second column
par.est.oprobit[i, 2] <- sqrt(diag(vcv)[1]) # SE of the coefficient on X
taus.oprobit[i, ] <- model$zeta
cat("Just completed iteration", i, "\n")
} # End the loop

pdf("ystar.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(Y.star, Y, xlim = c(-3, 3), xlab = "", ylab = "", main = "",
 axes = FALSE, pch = 19)
axis(1, at = seq(-3, 3, 1), cex.axis = 1.25)
axis(2, at = 1:4, cex.axis = 1.25, las = 2)
title(xlab = expression("Y* (Unobserved/Continuous)"), cex.lab = 1.5)
title(ylab = expression("Y (Observed/Categorical)"), line = 3.75,
 cex.lab = 1.5)
abline(v = c(tau1, tau2, tau3), lwd = 2, lty = 3)
text(tau1 - .25, 3.5, expression(tau[1]), cex = 2)
text(tau2 - .25, 3.5, expression(tau[2]), cex = 2)
text(tau3 - .25, 3.5, expression(tau[3]), cex = 2)
box()

dev.off()

mean(par.est.oprobit[ , 1]) # Mean of coefficient on X estimates
# Compare the actual taus to the means of the tau estimates
data.frame(True = c(tau1, tau2, tau3), Estimated = apply(taus.oprobit, 2, mean))
# Coverage probability for the coefficient on X
coverage(par.est.oprobit[ , 1], par.est.oprobit[ , 2], b1,
 df = n - length(c(coef(model), model$zeta)))$coverage.probability

# Unordered Models
library(Zelig)
set.seed(45262) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.mnl <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                 # the estimates
b0A <- .2 # True values for the intercepts
b0B <- -.2
b1A <- .5 # True values for the slopes
b1B <- .75
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X
# Compute the probabilities of each outcome based on the DGP
pA <- exp(b0A + b1A*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pB <- exp(b0B + b1B*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pC <- 1 - pA - pB

for(i in 1:reps){ # Start the loop
Y <- rep(NA, n) # Define Y as a vector of NAs with length n
for(j in 1:n){ # Create the dependent variable in another loop
Y[j] <- sample(c("A", "B", "C"), 1, replace = TRUE,
 prob = c(pA[j], pB[j], pC[j]))
}

# Estimate a MNL model
model <- zelig(as.factor(Y) ~ X, model = "mlogit",
 data = data.frame(Y, X), cite = FALSE)
vcv <- vcov(model) # Variance-covariance matrix
par.est.mnl[i, 1] <- coefficients(model)[3] # Coefficient on X, outcome 1
par.est.mnl[i, 2] <- coefficients(model)[4] # Coefficient on X, outcome 2
par.est.mnl[i, 3] <- sqrt(diag(vcv)[3]) # SE of coefficient on X, outcome 1
par.est.mnl[i, 4] <- sqrt(diag(vcv)[4]) # SE of coefficient on X, outcome 2
cat("Just completed iteration", i, "\n")
} # End the loop

# Mean of coefficients on X estimates
mean(par.est.mnl[ , 1]) # Outcome 1
mean(par.est.mnl[ , 2]) # Outcome 2

# Coverage probabilities for the coefficients on X
# Outcome 1
coverage(par.est.mnl[ , 1], par.est.mnl[ , 3], b1A,
 df = n - length(coef(model)))$coverage.probability
# Outcome 2
coverage(par.est.mnl[ , 2], par.est.mnl[ , 4], b1B,
 df = n - length(coef(model)))$coverage.probability

# Ordered vs. MNL
library(Zelig)
set.seed(99999)

reps <- 1000 # Set the number of repetitions at the top of the script
d.pp <- array(NA, c(4, 3, reps)) # Empty array to store
                                 # simulated change in probabilities

# Ordered logit model DGP
b0 <- 0 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

# MNL model DGP
b0A <- .2 # True values for the intercepts
b0B <- -.2
b1A <- .5 # True values for the slopes
b1B <- .75
n <- 1000 # Sample size

# Compute the probabilities of each outcome based on the DGP
pA <- exp(b0A + b1A*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pB <- exp(b0B + b1B*X)/(1 + exp(b0A + b1A*X) + exp(b0B + b1B*X))
pC <- 1 - pA - pB

for(i in 1:reps){
# Ordered dependent variable
Y.star <- rlogis(n, b0 + b1*X, 1) # The unobserved Y*
# Define the true cutpoints
tau1 <- quantile(Y.star, .25)
tau2 <- quantile(Y.star, .75)
Y.o <- rep(NA, n) # Define Y as a vector of NAs with length n
Y.o[Y.star < tau1] <- 1 # Set Y equal to a value according to Y.star
Y.o[Y.star >= tau1 & Y.star < tau2] <- 2
Y.o[Y.star >= tau2] <- 3
# Ordered data
o.data <- data.frame(Y.o, X) # Put the data in a data frame

# Unordered dependent variable
Y.m <- rep(NA, n) # Define Y as a vector of NAs with length n
for(j in 1:n){ # Create the dependent variable in another loop
Y.m[j] <- sample(1:3, 1, replace = TRUE, prob = c(pA[j], pB[j], pC[j]))
}
# Unordered data
m.data <- data.frame(Y.m, X) # Put the data in a data frame

# Estimate the models with the ordered dependent variable
o.correct <- zelig(as.ordered(Y.o) ~ X, model = "ologit",
 data = o.data, cite = FALSE)
m.incorrect <- zelig(as.factor(Y.o) ~ X, model = "mlogit",
 data = o.data, cite = FALSE)

# Estimate the models with the multinomial dependent variable
m.correct <- zelig(as.factor(Y.m) ~ X, model = "mlogit",
 data = m.data, cite = FALSE)
o.incorrect <- zelig(as.ordered(Y.m) ~ X, model = "ologit",
 data = m.data, cite = FALSE)

# Set X to its minimum and maximum for each model
x.oc <- setx(o.correct, X = min(X)) # For o.correct
x.oc1 <- setx(o.correct, X = max(X))

x.mi <- setx(m.incorrect, X = min(X)) # For m.incorrect
x.mi1 <- setx(m.incorrect, X = max(X))

x.mc <- setx(m.correct, X = min(X)) # For m.correct
x.mc1 <- setx(m.correct, X = max(X))

x.oi <- setx(o.incorrect, X = min(X)) # For o.incorrect
x.oi1 <- setx(o.incorrect, X = max(X))

# Compute the change in expected probabilities of falling in each category
# when moving from the minimum to the maximum of X
sim.oc <- sim(o.correct, x = x.oc, x1 = x.oc1)$qi$fd
sim.mi <- sim(m.incorrect, x = x.mi, x1 = x.mi1)$qi$fd
sim.mc <- sim(m.correct, x = x.mc, x1 = x.mc1)$qi$fd
sim.oi <- sim(o.incorrect, x = x.oi, x1 = x.oi1)$qi$fd
d.pp[1, , i] <- apply(sim.oc, 2, mean)
d.pp[2, , i] <- apply(sim.mi, 2, mean)
d.pp[3, , i] <- apply(sim.mc, 2, mean)
d.pp[4, , i] <- apply(sim.oi, 2, mean)
cat("Just completed iteration", i, "of", reps, "\n")
}

# Compute the average change in probability for each of the four models
dpp.means <- rbind(apply(d.pp[1, , ], 1, mean), apply(d.pp[2, , ], 1, mean), apply(d.pp[3, , ], 1, mean), apply(d.pp[4, , ], 1, mean))

# Compute the SD of the change in probability for each of the four models
dpp.sds <- rbind(apply(d.pp[1, , ], 1, sd), apply(d.pp[2, , ], 1, sd), apply(d.pp[3, , ], 1, sd), apply(d.pp[4, , ], 1, sd))

# LaTeX table
library(xtable)
results <- rbind(dpp.means, dpp.sds)

xtable(results, digits = 4, caption = "Means and Standard Deviations of the Change in expected probability for Each Category", label = "ord-unord-results", align = "lrrr")

# Count Models
# Poisson
set.seed(3759) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.pois <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store the
                                                  # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){ # Start the loop
Y <- rpois(n, exp(b0 + b1*X)) # The true DGP
model <- glm(Y ~ X, family = "poisson") # Estimate Poisson model
vcv <- vcov(model) # Variance-covariance matrix
par.est.pois[i, 1] <- model$coef[1] # Put the estimate for the intercept
                                    # in the first column
par.est.pois[i, 2] <- model$coef[2] # Put the estimate for the coefficient on
                                    # X in the second column
par.est.pois[i, 3] <- sqrt(diag(vcv)[1]) # SE of the intercept
par.est.pois[i, 4] <- sqrt(diag(vcv)[2]) # SE of the coefficient on X
} # End the loop

# Means of the coefficient estimates
mean(par.est.pois[ , 1]) # Intercept
mean(par.est.pois[ , 2]) # Coefficient on X

# Coverage probabilities
# Intercept
coverage(par.est.pois[ , 1], par.est.pois[ , 3], b0,
 df = n - model$rank)$coverage.probability
# Coefficient on X
coverage(par.est.pois[ , 2], par.est.pois[ , 4], b1,
 df = n - model$rank)$coverage.probability

pdf("od1.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(1:n, Y, ylim = c(0, 20), col = "gray50", xlab = "", ylab = "",
 main = "", axes = FALSE)
axis(1, cex.axis = 1.25)
axis(2, at = 0:20, cex.axis = 1.25, las = 2)
title(xlab = expression("Observations"), cex.lab = 1.5)
title(ylab = expression("Y"), line = 3.75, cex.lab = 1.5)
abline(h = mean(Y), lwd = 2)
abline(h = var(Y), lwd = 2, lty = 2)
box()
legend("topleft", bty = "n", c(expression("Mean of Y"),
 expression("Variance of Y")), lty = c(1, 2), lwd = 2, cex = 1.5)

dev.off()

# Poisson vs. Negative Binomial
library(MASS)
set.seed(763759) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.pnb <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store the
                                                 # estimates
b0 <- .2 # True value for the intercept
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X

for(i in 1:reps){
Y <- rnbinom(n, size = .5, mu = exp(b0 + b1*X)) # Generate data with
                                                # overdispersion
model.p <- glm(Y ~ X, family = "poisson") # Estimate Poisson model
model.nb <- glm.nb(Y ~ X) # Estimate NB model
vcv.p <- vcov(model.p) # Variance-covariance matrices
vcv.nb <- vcov(model.nb)
par.est.pnb[i, 1] <- model.p$coef[2]  # Store the results
par.est.pnb[i, 2] <- model.nb$coef[2]
par.est.pnb[i, 3] <- sqrt(diag(vcv.p)[2])
par.est.pnb[i, 4] <- sqrt(diag(vcv.nb)[2])
cat("Completed", i, "of", reps, "\n")
}

# Means of the coefficient on X estimates
mean(par.est.pnb[ , 1]) # Poisson estimates
mean(par.est.pnb[ , 2]) # NB estimates

# MSE
mean((par.est.pnb[ , 1])^2) # Poisson MSE
mean((par.est.pnb[ , 2])^2) # NB MSE

# Coverage probabilities
# Poisson SEs
coverage(par.est.pnb[ , 1], par.est.pnb[ , 3], b1,
 df = n - model.p$rank)$coverage.probability
# NB SEs
coverage(par.est.pnb[ , 2], par.est.pnb[ , 4], b1,
 df = n - model.nb$rank)$coverage.probability

pdf("od2.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(1:n, Y, ylim = c(0, 20), col = "gray50", xlab = "", ylab = "",
 main = "", axes = FALSE)
axis(1, cex.axis = 1.25)
axis(2, at = 0:20, cex.axis = 1.25, las = 2)
title(xlab = expression("Observations"), cex.lab = 1.5)
title(ylab = expression("Y"), line = 3.75, cex.lab = 1.5)
abline(h = mean(Y), lwd = 2)
abline(h = var(Y), lwd = 2, lty = 2)
box()
legend("topleft", bty = "n", c(expression("Mean of Y"),
 expression("Variance of Y")), lty = c(1, 2), lwd = 2, cex = 1.5)

dev.off()

# Negative Binomial vs. Zero-Inflated Negative Binomial
library(pscl)
# Zero-inflated negative binomial random number generator
rzinbinom <- function(n, mu, size, zprob){
ifelse(rbinom(n, 1, zprob) == 1, 0, rnbinom(n, size = size, mu = mu))
}

set.seed(2837) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.zinb <- matrix(NA, nrow = reps, ncol = 4) # Empty matrix to store
                                                  # the estimates
b0z <- -.8 # True value for the inflation intercept
b1z <- .3 # True value for the inflation slope
b0c <- .2 # True value for the count intercept
b1c <- .5 # True value for the count slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X
Z <- rnorm(n, X, 1) # Inflation independent variable

for(i in 1:reps){
# Generate data with a zero-inflation component
Y.zi <- rzinbinom(n, mu = exp(b0c + b1c*X), size = .5,
zprob = exp(b0z + b1z*Z)/(1 + exp(b0z + b1z*Z)))

# Generate data with no zero-inflation component
Y.nozi <- rzinbinom(n, mu = exp(b0c + b1c*X), size = .5, zprob = 0)
model.nb1 <- glm.nb(Y.zi ~ X) # Standard negative binomial
model.nb2 <- glm.nb(Y.nozi ~ X)
model.zinb1 <- zeroinfl(Y.zi ~ X | Z, dist = "negbin") # Zero-inflated model
model.zinb2 <- zeroinfl(Y.nozi ~ X | Z, dist = "negbin")

# Store the estimates of the coefficient on X (count equation)
par.est.zinb[i, 1] <- model.nb1$coef[2] # Standard NB, with ZI
par.est.zinb[i, 2] <- model.nb2$coef[2] # Standard NB, no ZI
par.est.zinb[i, 3] <- as.numeric(model.zinb1$coef$count[2]) # ZI NB, with ZI
par.est.zinb[i, 4] <- as.numeric(model.zinb2$coef$count[2]) # ZI NB, no ZI
cat("Completed", i, "of", reps, "\n")
}

pdf("zinb-zi.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(density(par.est.zinb[ , 1]), xlim = c(-.5, 1.5), ylim = c(0, 3.5),
 lwd = 3, xlab = "", ylab = "", main = "", axes = FALSE)
lines(density(par.est.zinb[ , 3]), lwd = 3, lty = 2)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[1])), cex.lab = 1.5)
title(ylab = expression("Density"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 2)
text(1, 2, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()
legend("topright", bty = "n", c(expression("Standard NB"),
 expression("ZINB")), lty = c(1, 2), lwd = 3, cex = 1.5)

dev.off()

pdf("zinb-nozi.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(density(par.est.zinb[ , 2]), xlim = c(-.5, 1.5), ylim = c(0, 5),
 lwd = 3, xlab = "", ylab = "", main = "", axes = FALSE)
lines(density(par.est.zinb[ , 4]), lwd = 3, lty = 2)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[1])), cex.lab = 1.5)
title(ylab = expression("Density"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 2)
text(1, 2, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()
legend("topright", bty = "n", c(expression("Standard NB"),
 expression("ZINB")), lty = c(1, 2), lwd = 3, cex = 1.5)

dev.off()

# Duration Models (Cox PH)
library(survival)
library(coxrobust)

set.seed(4679) # Set the seed for reproducible results

reps <- 1000 # Set the number of repetitions at the top of the script
par.est.cox <- matrix(NA, nrow = reps, ncol = 3) # Empty matrix to store
                                                 # the estimates
b1 <- .5 # True value for the slope
n <- 1000 # Sample size
X <- runif(n, -1, 1) # Create a sample of n observations on the
                     # independent variable X
Z <- runif(n, -1, 1) # Create an omitted variable

for(i in 1:reps){ # Start the loop
Y <- rexp(n, exp(b1*X + Z)) # Generate survival times
Ys <- Surv(Y, event = rep(1, n))
model.plm <- coxph(Ys ~ X, method = "breslow") # Standard PLM estimator
model.irr <- coxr(Ys ~ X, trunc = .95) # IRR, downweighting outliers (5%)
model.irr2 <- coxr(Ys ~ X, trunc = .8) # IRR, even more downweighting (20%)
par.est.cox[i, 1] <- model.plm$coef[1] # Store the estimates
par.est.cox[i, 2] <- model.irr$coef[1]
par.est.cox[i, 3] <- model.irr2$coef[1]
cat("Completed", i, "of", reps, "\n")
}

apply(par.est.cox, 2, mean)
apply(par.est.cox, 2, sd)

mean((par.est.cox[ , 1] - b1)^2)
mean((par.est.cox[ , 2] - b1)^2)
mean((par.est.cox[ , 3] - b1)^2)

pdf("cox.pdf")

par(mar = c(5, 5.25, .5, .5))
plot(density(par.est.cox[ , 1]), xlim = c(.15, .65), lwd = 3, xlab = "",
 ylab = "", main = "", axes = FALSE)
lines(density(par.est.cox[ , 2]), lwd = 3, lty = 2)
lines(density(par.est.cox[ , 3]), lwd = 3, lty = 3)
axis(1, cex.axis = 1.25)
axis(2, cex.axis = 1.25, las = 2)
title(xlab = expression(hat(beta[1])), cex.lab = 1.5)
title(ylab = expression("Density"), line = 3.75, cex.lab = 1.5)
abline(v = b1, lwd = 2)
text(.58, 6, expression("True"~beta[1]~"= 0.50"), cex = 1.5)
box()
legend("topleft", bty = "n", c(expression("PLM"), expression("IRR 5%"),
 expression("IRR 20%")), lty = c(1, 2, 3), lwd = 3, cex = 1.5)

dev.off()

# Computational Issues
source("parallel1.r")
source("parallel2.r")


dms_to_rad <- function(d, m, s) (d + m / 60 + s / 3600) * pi / 180

# Volumetric mean radius is 6371 km, see http://nssdc.gsfc.nasa.gov/planetary/factsheet/earthfact.html
# The diameter is thus 12742 km

great_circle_distance <- function(lat1, long1, lat2, long2) {
   a <- sin(0.5 * (lat2 - lat1))
   b <- sin(0.5 * (long2 - long1))
   12742 * asin(sqrt(a * a + cos(lat1) * cos(lat2) * b * b))
}

# Coordinates are found here:
#     http://www.airport-data.com/airport/BNA/
#     http://www.airport-data.com/airport/LAX/

great_circle_distance(
   dms_to_rad(36,  7, 28.10), dms_to_rad( 86, 40, 41.50),   # Nashville International Airport (BNA)
   dms_to_rad(33, 56, 32.98), dms_to_rad(118, 24, 29.05))  # Los Angeles International Airport (LAX)

# Output:  2886.327


# Anomaly detection
# Examples based on the following blog:
# http://tjo.hatenablog.com/entry/2017/01/11/190000
# Which was based on the following book:
# https://www.amazon.co.jp/%E5%85%A5%E9%96%80-%E6%A9%9F%E6%A2%B0%E5%AD%A6%E7%BF%92%E3%81%AB%E3%82%88%E3%82%8B%E7%95%B0%E5%B8%B8%E6%A4%9C%E7%9F%A5%E2%80%95R%E3%81%AB%E3%82%88%E3%82%8B%E5%AE%9F%E8%B7%B5%E3%82%AC%E3%82%A4%E3%83%89-%E4%BA%95%E6%89%8B-%E5%89%9B/dp/4339024910

d <- read.csv('watertreatment_mod.csv')

d.dist <- dist(d[,-1])

d.hcl <- hclust(d.dist, method='ward.D2')

plot(d.hcl, labels=d[,1])

# Try k-means for 4 to 10 clusters

for (i in 4:10){
  km <- kmeans(d[,-1], centers = i)
  print(table(km$cluster))
}

# Investigate the cluster of only 3 datapoints for k > 7
for (i in 8:10){
  km <- kmeans(d[,-1], centers = i)
  cls <- which(table(km$cluster)==3)
  print(d$date[km$cluster==cls])
}

# Seems the 3 same dates have anomalies

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

# Part 2
# http://tjo.hatenablog.com/entry/2017/02/08/190000

# Anomaly detection for 1-D case under normal distribution

# Create data

set.seed(1)
x1 <- rnorm(300) # White noise
x2 <- rep(c(15, rep(0,49)),6) # Create data spikes
x3 <- c(rep(0,150),rep(3,150)) # Step data

x <- x1 + x2 + x3
y <- x+c(rep(0,130),30,rep(0,169)) # Add anomaly of size 30 at 131st element

# Line plot
plot(y, type = 'l')

# point plot
plot(y)

mu <- mean(y)
s2 <- mean((y - mu)^2)
mu
s2

a <- (y - mu)^2 / s2
thr <- qchisq(0.99, 1) # Deviation from 99% threshold of Chi Sq distro

plot(a)
segments(0, thr, 300, thr, col='red', lty = 3, lwd = 3) # draw lines

# Note how the spike at 30 is looks even more like an anomaly when graphed using Chi Sq

# Hotelling T2

# Normally distrbuted variables in 3D
set.seed(1)
x <- rnorm(n = 500, mean = 1, sd = 1)
set.seed(2)
y <- rnorm(n = 500, mean = 1, sd = 1)
set.seed(3)
z <- rnorm(n = 500, mean = 1, sd = 1)
d <- data.frame(x = x, y = y, z = z)

# Add 3 anomalies
set.seed(4)
idx <- sample(nrow(d), 3)
d[idx,] <- d[idx,] + 10

install.packages('scatterplot3d')
library(scatterplot3d)
scatterplot3d(d, pch=19, cex.symbols=0.5)

# Calculate Hotelling's T^2
X <- as.matrix(d)
mx <- colMeans(X)
Xc <- as.matrix(X) - matrix(1, nrow(X), 1) %*% mx
Sx <- t(Xc) %*% Xc / nrow(X)
am <- rowSums((Xc %*% solve(Sx)) * Xc)
thr <- qchisq(0.99, 1)
plot(am)
segments(0, thr, 500, thr, col='red', lty=3, lwd=3)

# Plot the anomalies in red
idx_a <- which(am > thr)
col_3d <- rep(1, 500)
col_3d[idx_a] <- 2
cex_3d <- rep(0.5, 500)
cex_3d[idx_a] <- 2
scatterplot3d(d, pch=19, cex.symbols = cex_3d, color=col_3d)

# Mahalanobis-Taguchi Method
# http://tjo.hatenablog.com/entry/2017/02/08/190000

# Make 3D points from normally ditributed random numbers

xt <- rnorm(n = 500, mean = 1, sd = 1)
yt <- rnorm(n = 500, mean = 1, sd = 1)
zt <- rnorm(n = 500, mean = 1, sd = 1)
dt <- data.frame(x = xt, y = yt, z = zt)

# Insert 3 deviations in the z direction
idxt <- sample(nrow(dt), 3)
dt[idxt,3] <- dt[idxt,3] + 20
scatterplot3d(dt, pch=19, cex.symbols = 0.5)

# Find anomalies using Hotelling T^2 and Mahalanobis-Taguchi
Xt <- as.matrix(dt)
mxt <- colMeans(Xt)
Xct <- as.matrix(Xt) - matrix(1, nrow(Xt), 1) %*% mxt
Sxt <- t(Xct) %*% Xct / nrow(Xt)
amt <- rowSums((Xct %*% solve(Sxt)) * Xct) / ncol(Xt)
thrt <- 1
plot(amt)
segments(0, thrt, 500, thrt, col = 'red', lty=3, lwd=3)

# Plot the anomalies as red points
idx_at <- which(amt > thrt)
col_3dt <- rep(1, 500)
col_3dt[idx_at] <- 2
cex_3dt <- rep(0.5, 500)
cex_3dt[idx_at] <- 2
scatterplot3d(dt, pch=19, cex.symbols = cex_3dt, color=col_3dt)

# Plot signal/noise ratio

par(mfrow=c(2,2))

for (i in 1:3){
  xc_prime <- Xct[idxt[i],]
  SN1 <- 10*log10(xc_prime^2 / diag(Sxt))
  barplot(SN1)
}


#' Probability of path choices using probit model.
#'
#' This function calculates probabilities for selection of each path on the network based on set of path disutilities (costs). The function uses a probit random utility model. Calculations are exact for two route networks. In other case the probabilities are approximated by simulation.
#' @param u Vector of utlities on each path
#' @param ODpair Vector indicating the OD pair serviced by each route.
#' @param A Path-link incidence matrix
#' @param theta Vector of standard deviations for link cost errors. Defaults to 1 in each case.
#' @param Niter Number of iterations when computing probabilities by simulation. Defaults to 1000.
#' @return Vector of route choice probabilities
#' @keywords path route probability
#' @examples
#' A <- diag(2)
#' ODpair <- c(1,1)
#' u <- c(15,17)
#' LogitPathProb(u,ODpair,A,theta=1)
#' @export

ProbitPathProb <- function(u,ODpair,A,theta,Niter=1000){
	exact <- is.matrix(A) && dim(A) == 2 && all(A == diag(2))
	if (exact){
		p <- pnorm(-u[1]+u[2],sd=theta*sqrt(2))
		p <- c(p,1-p)
	}
	if (!exact){
		n.paths <- ncol(A)
		link.errors <- matrix(rnorm(Niter*nrow(A),mean=0,sd=theta),nrow=nrow(A))
		path.errors <- t(A)%*%link.errors
		path.u <- u + path.errors
		p <- numeric(n.paths)
		for (i in unique(ODpair)){
			working.u <- path.u[ODpair==i,]
			working.u <- cbind(working.u,diag(nrow(working.u)))  # Add artifical utilities to ensure every route included in tabulation of results
			p[ODpair==i] <- table(apply(working.u,2,which.min)) - rep(1,nrow(working.u)) # Includes removal of results from artificial utilities
		}
		p <- p/Niter
	}
	p
}


# ......................................................................................
# ........................Exercise 12. Tests for multiple samples.......................
# ..................Michal Béreš, Martina Litschmannová, Adéla Vrtková..................
# ......................................................................................

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

# * Test data for a function call example ####
#

# I will create some data from the normal distribution with same variances
a = as.data.frame(rnorm(n = 35, mean = 100, sd = 10))
b = as.data.frame(rnorm(n = 30, mean = 108, sd = 10))
c = as.data.frame(rnorm(n = 40, mean = 104, sd = 10))
d = as.data.frame(rnorm(n = 32, mean = 112, sd = 10))

# I will rename the column name
colnames(a) = c("value")
colnames(b) = c("value")
colnames(c) = c("value")
colnames(d) = c("value")

# I will add a type for all frame data
a$type = "group1"
b$type = "group2"
c$type = "group3"
d$type = "group4"

# I glue the lines together
data = rbind(a,b,c,d)

# Convert type to type factor (needed for some tests)
data$type = as.factor(data$type)

head(data)

boxplot(data$value ~ data$type)
# if there are any outliars, I will ignore them
# I know the data is from a normal distribution!
# I also know they have the same variance sd = 10

#  Overview of tests and their functions ####
#
# * Comparing the measures of Variability (variances) ####

# ** Bartlett test ####
# - verifies the equality of variances
# - $H_0: \sigma^2_1 = \sigma^2_2 = \sigma^2_3 = \ldots$
# - $H_A: \neg H_0$
# - the assumtion data normality(and of course independence and continuity)

bartlett.test(data$value ~ data$type)

# ** Levene's test ####
# - verifies the equality of variances
# - $H_0: \sigma^2_1 = \sigma^2_2 = \sigma^2_3 = \ldots$
# - $H_A: \neg H_0$
# - only independence and continuity are required

car::leveneTest(data$value ~ data$type)

# ** Cochran's and Hartley's test ####
# - verifies the equality of variances
# - require data normality and so-called balanced sorting
#     - balanced sorting means that we have approximately the same amount of data in
# each group
# - we will not use them

# * Comparing the measures of Position (means or medians)  ####
#
# ** ANOVA(analysis of variance) ####
# - test the equality of mean values
# - $H_0: \mu_1 = \mu_2 = \mu_3 = \ldots$
# - $H_A: \neg H_0$
# - prerequisites:
#     - normality dat
#     - homoskedasticity(identical variances)
#     - (and of course independence and continuity)
# - if we reject $H_0$ Post-Hoc analysis is required
#     - using TukeyHSD test
#     - we want the result in the form of letter scheme and effects

# ANOVA
# H0: mu1=mu2=mu3=mu4
# HA:~H0(H0 negation)

res = aov(data$value~ data$type)
summary(res)

# Post-Hoc analysis

TukeyHSD(res)

# effect computation
library(dplyr)

# overall average
mean_overall = mean(data$value)
mean_overall

# averages in groups
effects = data %>% group_by(type) %>%
    summarize(mean_group = mean(value))

# effects
effects$effect = effects$mean_group - mean_overall

# list them sorted
effects %>% arrange(desc(effect))

# letter scheme, library rcompanion

# install.packages("rcompanion")
posthoc = TukeyHSD(res)

# how to get the matrix of values out of the result
matrix_posthoc = posthoc[[1]]
matrix_posthoc
# now we make a dataframe with columns of pairs and pvalues
posthoc_DF = data.frame(pairs = rownames(matrix_posthoc),
                   pval = matrix_posthoc[,'p adj'])
posthoc_DF

rcompanion::cldList(pval ~ pairs,
        data = posthoc_DF,
        threshold = 0.05)

# ** Kruskal - Wallis test ####
#
# - verifiesthe equality of medians
# - $H_0: X_{0.5,1} = X_{0.5,2} = X_{0.5,3} = \ldots$
# - $H_A: \neg H_0$
# - prerequisites:
#     - data symmetry
#     - (and of course independence and continuity)
# - if we reject $H_0$ Post-Hoc analysis is required
#     - using the Dunn test
#         - method = "bonferroni"
#     - we want the result in the form of letter scheme and effects

# KW test
# H0: X0.5,1=X0.5,2=X0.5,3=X0.5,4
# HA:~H0(H0 negation)

kruskal.test(data$value ~ data$type)

# Post-Hoc analysis

# install.packages("FSA")
FSA::dunnTest(data$value ~ data$type,   # FSA library
              method="bonferroni")

# effects

# overall median
median_overall = median(data$value)
median_overall

# medians in groups
effects = data %>% group_by(type) %>%
    summarize(median_group = median(value))

# effects
effects$effect = effects$median_group - median_overall

# list them sorted
effects %>% arrange(desc(effect))

# letter scheme, library rcompanion

# install.packages("rcompanion")
posthoc = FSA::dunnTest(data$value ~ data$type,   # FSA library
              method="bonferroni")

# how to get the matrix of values out of the result
posthoc_DF = posthoc$res
posthoc_DF
# its in the data frame form already

rcompanion::cldList(P.adj ~ Comparison,
        data = posthoc_DF,
        threshold = 0.05)

#  Examples ####

# * Example 1. ####
#
# 122 patients who underwent heart surgery were randomly divided into three groups
# - **Group 1:** Patients received 50% nitrous oxide and 50% oxygen mixed continuously
# for 24 hours.
# - **Group 2:** Patients received 50% nitric oxide and 50% oxygen only during surgery.
# - **Group 3:** Patients received no nitrous oxide but received 35-50% oxygen for 24
# hours.
#
# The data in the sheet 1 of testy_vicevyberove.xlsx file correspond to the folic acid
# salt concentrations in the red blood cells in all three groups 24 hours after the
# surgery. Verify that the observed differences between the folic acid salt
# concentrations are statistically significant, i.e. that there is an effect of the
# composition of the mixture on the monitored parameter.

acid = readxl::read_excel("data/testy_vicevyberove.xlsx", sheet=1)
colnames(acid) = c("Group 1","Group 2","Group 3")   # rename columns
head(acid)

# conversion to standard data format
acid.s = stack(acid)
colnames(acid.s) = c("values","group")
acid.s = na.omit(acid.s)
head(acid.s)

boxplot(acid.s$values ~ acid.s$group, xlab = "Test groups", ylab = "Folic acid salt concentration")
# Data do not contain any outliars

# we test the normality using S-W. test

acid.s %>% group_by(group) %>%
    summarise(pval_SW = shapiro.test(values)$p.value)

# Information needed to set rounding

acid.s %>% group_by(group) %>%
    summarise(len = length(values), st.dev = sd(values))

# sd is rounded to 3 valid digits
# sd and position measures are rounded to tenths

# equality of variance
s2 = acid.s %>% group_by(group) %>%
        summarise(var = sd(values)^2)
s2 # sampling variances

max(s2$var)/min(s2$var)
# According to the box chart and information on the ratio of the largest and smallest
# variances(<2) we do not assume that the variances differ statistically significantly

# The assumption of normality was not rejected -> Bartlett's test

bartlett.test(acid.s$values ~ acid.s$group)

# At the significance level of 0.05, there are no statistically significant differences in variances

# We want to compare the mean values of independent samples from normal distributions
# with same variances -> ANOVA
# The aov() command requires data in the standard data format

results = aov(acid.s$values ~ acid.s$group)
summary(results)

# At the significance level of 0.05, there are statistically significant differences in mean values

# post-hoc analysis
TukeyHSD(results)

# effect computation

# overall average
mean_overall = mean(acid.s$values)
mean_overall

# averages in groups
effects = acid.s %>% group_by(group) %>%
    summarize(mean_group = mean(values))

# effects
effects$effect = effects$mean_group - mean_overall

# list them sorted
effects %>% arrange(desc(effect))

# letter scheme, library rcompanion

# make a dataframe with columns of pairs and pvalues
matrix_posthoc = TukeyHSD(results)[[1]]
posthoc_DF = data.frame(pairs = rownames(matrix_posthoc),
                   pval = matrix_posthoc[,'p adj'])
# letter scheme
rcompanion::cldList(pval ~ pairs,
        data = posthoc_DF,
        threshold = 0.05)

# * Example 2. ####
#
# Three breeds of rabbits are bred on the farm. An experiment was performed on sheet 2
# of testy_vicevyberove.xlsx, the aim of which was to find out whether, even if we keep
# all the rabbits for the same time and under the same conditions (food, environment),
# there is a statistically significant difference between breeds in rabbit weights.
# Verify.

rabbits = readxl::read_excel("data/testy_vicevyberove.xlsx", sheet=2)
colnames(rabbits) = c("Vienna","Czech","Kalif")   # rename columns
head(rabbits)

# conversion to standard data format
rabbits.s = stack(rabbits)
colnames(rabbits.s) = c("value","group")
rabbits.s = na.omit(rabbits.s)
head(rabbits.s)

boxplot(rabbits.s$value ~ rabbits.s$group)
# data contains an outliar

# Eliminate outliar

rabbits.s$id = seq(1,length(rabbits.s$value))

outliars = rabbits.s %>% group_by(group) %>% rstatix::identify_outliers(value)
outliars

rabbits.s$value_cleared = ifelse(rabbits.s$id %in% outliars$id, NA, rabbits.s$value)

# Box chart
boxplot(rabbits.s$value_cleared ~ rabbits.s$group)

library(dplyr)

rabbits.s %>% group_by(group) %>%
    summarise(norm.pval = shapiro.test(value_cleared)$p.value)

# At the significance level of 0.05, we do not reject the assumption of normality.

# Information needed for correct rounding
rabbits.s %>% group_by(group) %>%
    summarize(len = sum(!is.nan(value_cleared)),
              sd = sd(value_cleared, na.rm = TRUE))

# sd is rounded to 2 valid digits
# sd and position measurements round to hundredths

# The assumption of normality was not rejected ->Bartlett's test
bartlett.test(rabbits.s$value_cleared ~ rabbits.s$group)

# At the significance level of 0.05, the equality of variances cannot be rejected

# We want to compare the mean values of independent samples from normal
# distributions with the same variances -> ANOVA
# The aov() command requires data in the standard data format

results = aov(rabbits.s$value_cleared ~ rabbits.s$group)
summary(results)

# At the significance level of 0.05, we reject the hypothesis of equality of the mean values

# post-hoc analysis
TukeyHSD(results)

# effect computation

# overall average
mean_overall = mean(rabbits.s$value_cleared, na.rm = TRUE)
mean_overall

# averages in groups
effects = rabbits.s %>% group_by(group) %>%
    summarize(mean_group = mean(value_cleared, na.rm = TRUE))

# effects
effects$effect = effects$mean_group - mean_overall

# list them sorted
effects %>% arrange(desc(effect))

# * Example 3. ####
#
# Four manufacturers A, B, C, D sent a total of 66 products to the competition for the
# best product quality. The jury compiled the ranking (only the position of the product
# in the list of 66 from best to worst), which is listed in the sheet 3 of the file
# testy_vicevyberove.xlsx. On the basis of the above data, assess whether the origin of
# the products affects its quality.

quality = readxl::read_excel("data/testy_vicevyberove.xlsx", sheet = 3)
colnames(quality) = c("ranking", "manufacturer")   # rename columns
head(quality)
# data is already in standard format

boxplot(quality$ranking ~ quality$manufacturer)

# the data are not independent by nature, also they are not continuous!
# outliars should not be present by the nature of the dataset
# the assumptions are corrupted for all tests -> our best bet is the most robust test in our arsenal
# we skip directly into KW test

# Symmetry verification

quality %>% group_by(manufacturer) %>%
    summarize(skewness = moments::skewness(ranking))

# We want to compare the medians of "independent" samples -> Kruskal-Wallis test
kruskal.test(quality$ranking ~ quality$manufacturer)

# At the significance level of 0.05, there are no statistically significant differences in medians

# * Example 4. ####
#
# The effect of three types of medicaments on blood clotting was studied (so called
# thrombin time). Data of 42 monitored persons are recorded in the sheet 4 of the file
# testy_vicevyberove.xlsx. Does the thrombin time depend on which preparation was used?

trombin.s = readxl::read_excel("data/testy_vicevyberove.xlsx",
                               sheet=4, skip = 1)
colnames(trombin.s) = c("value","group")   # rename columns

head(trombin.s)
# data is already in standard format

# exploratory analysis
boxplot(trombin.s$value ~ trombin.s$group)
# no outliars

# verification of normality
library(dplyr)

trombin.s %>% group_by(group) %>%
    summarize(norm.pval = shapiro.test(value)$p.value)

# At the significance level of 0.05 we reject the assumption of normality(for A)

# we can at least test the equality of variances -> same variances
# means better KW test result in terms of type II error

# The assumption of normality was rejected -> Levene's test

car::leveneTest(trombin.s$value ~ trombin.s$group)

# the assumption of homoskedasticity was rejected (at significance 0.05)

# Symmetry verification
trombin.s %>% group_by(group) %>%
  summarize(skewness = moments::skewness(value))
# we do not reject the assumption of data symmetry

# We want to compare medians (data not from normal dist.)-> Kruskal - Wallis test

kruskal.test(trombin.s$value,trombin.s$group)

# At the significance level of 0.05, we found statistically significant differences in medians

FSA::dunnTest(trombin.s$value~trombin.s$group,method = "bonferroni")

# effect counting
library(dplyr)

# overall average
median_overall = median(trombin.s$value)
median_overall

# averages in groups
effects = trombin.s %>% group_by(group) %>%
    summarize(median_group = median(value))

# effects
effects$effect = effects$median_group - median_overall

# List sorted
effects %>% arrange(desc(effect))

# * Example 5.(multiple groups) ####
#
# When Snow White got to the seven dwarves, she sensed an opportunity to make a lot of
# money. The Dwarves basically fell in love with the Snow White and immediately handed
# over all of their mined gold. However, even this is not enough for Snow White and she
# feels that she could benefit more from the dwarves. Therefore, she began to record how
# many kilograms of gold a day she received from each of the dwarves(snehurka.xlsx).
# Verify that the dwarves differ in the amount of gold mined.

gold = readxl::read_excel("data/snehurka.xlsx")
colnames(gold) = c("ammount","dwarf")
head(gold)
# data is in the standard data format

boxplot(gold$ammount ~ gold$dwarf)
# data does not outliars

# verification of normality
library(dplyr)

gold %>% group_by(dwarf) %>%
    summarize(p.val = shapiro.test(ammount)$p.value)

# The assumption of normality was not rejected -> Bartlett's test
bartlett.test(gold$ammount ~ gold$dwarf)

# At the significance level of 0.05, there are no statistically significant differences in variances

# ANOVA
results = aov(gold$ammount ~ gold$dwarf)
summary(results)

# POST-HOC
res = TukeyHSD(results)[[1]]
res

# effects computation
library(dplyr)

# overall average
overall = mean(gold$ammount)
overall

# averages in groups
effects = gold %>% group_by(dwarf) %>%
    summarize(mean_dwarf = mean(ammount))

# effects
effects$effect = effects$mean_dwarf - overall

# list sorted
effects %>% arrange(desc(effect))

# letter scheme, library rcompanion

# make a dataframe with columns of pairs and pvalues
matrix_posthoc = TukeyHSD(results)[[1]]
posthoc_DF = data.frame(pairs = rownames(matrix_posthoc),
                   pval = matrix_posthoc[,'p adj'])
# letter scheme
rcompanion::cldList(pval ~ pairs,
        data = posthoc_DF,
        threshold = 0.05)


#функция на разпределение на две случайни велични: F X,Y(x,y) = P(X<=x, Y<=y)
#две случайни величини X, Y са независими, ако за всяко x,y e изпълнено: F X,Yx,y) = F X(x) * F Y(y) или P(X=x, Y=y) = P(X=x) * P(Y=y)
#ковариация на две случайни величини: cov(X,Y) = E(XY) - EX*EY
#корелация на две случайни величини: cor(X,Y) = cov(X,y)/sqrt(DX*DY)
#ако X,Y са независими, то cor = 0, обратното не е вярно
#ако корелацията клони към 1 или -1, значи X и Y са зависими
#за графики: scatterplot и pairs
#cor=1
x=c(1:10)
y=c(1:10)
cor(x,y)
plot(x,y)

#cor=-1
x=c(1:10)
y=c(10:1)
cor(x,y)
plot(x,y)
plot(y,x)

#cor~0
x=rnorm(100)
y=rexp(100)
cor(x,y)
plot(x,y)

#многомерно нормално разпределение
#n-мерна случайна величина X = (X1,..,Xn) с нормално разпределение N(m,K), K=E((X - m)(X - m)transp) ковариационна матрица
install.packages('mvtnorm')
library('mvtnorm')
x=y=seq(-5,5, length=50)
f=function(x,y)dmvnorm(cbind(x,y))
z=outer(x,y,f)
persp(x,y,z, theta=10, phi=20,expand=0.5, col="light blue")
persp(x,y,z, theta=10, phi=20,expand=0.5, col="light blue", shade=0.75)

#-----------------------------------------------------

#01
x=iris[,1:4]
cor(x)
pairs(x)

#02
#Kz ковариация на X=(X1, X2, X2) -> по диагонала е DXi = E(Xi^2) - (EXi)^2
#другите елементи на матрицата са ковариацията на елементите два по два
Kz = matrix(c(16, -14, 12, -14, 49, -21, 12, -21, 36), ncol = 3, byrow = TRUE)
cor(Kz) #като че ли не го смята никак правилно
#супер грозен начин за решаване, но май е по-верен? :)
#не се прави така, нямам идея как се прави, но и не ни трябва да го знем за момента
cov.X1.X2 = Kz[1,2] / sqrt(Kz[1,1]*Kz[2,2])
cov.X1.X3 = Kz[1,3] / sqrt(Kz[1,1]*Kz[3,3])
cov.X2.X3 = Kz[2,3] / sqrt(Kz[2,2]*Kz[3,3])
cov.X = matrix(c(1, cov.X1.X2, cov.X1.X3, cov.X1.X2, 1, cov.X2.X3, cov.X1.X3, cov.X2.X3, 1), ncol = 3, byrow = TRUE)


#' Quadratic form of a matrix and a vector
#'
#' We compute the quadratic form of a vector and a matrix in an efficient
#' manner. Let `x` be a real vector of length `p`, and let `A` be
#' a p x p real matrix. Then, we compute the quadratic form \eqn{q = x' A x}.
#'
#' A naive way to compute the quadratic form is to explicitly write
#' `t(x) \%*\% A \%*\% x`, but for large `p`, this operation is
#' inefficient. We provide a more efficient method below.
#'
#' Note that we have adapted the code from:
#' \url{http://tolstoy.newcastle.edu.au/R/help/05/11/14989.html}
#'
#' @param A matrix of dimension p x p
#' @param x vector of length p
#' @return scalar value
quadform <- function(A, x) {
  drop(crossprod(x, A %*% x))
}

#' Quadratic Form of the inverse of a matrix and a vector
#'
#' We compute the quadratic form of a vector and the inverse of a matrix in an
#' efficient manner. Let `x` be a real vector of length `p`, and let
#' `A` be a p x p nonsingular matrix. Then, we compute the quadratic form
#' \eqn{q = x' A^{-1} x}.
#'
#' A naive way to compute the quadratic form is to explicitly write
#' `t(x) \%*\% solve(A) \%*\% x`, but for large `p`, this operation is
#' inefficient. We provide a more efficient method below.
#'
#' Note that we have adapted the code from:
#' \url{http://tolstoy.newcastle.edu.au/R/help/05/11/14989.html}
#'
#' @param A matrix that is p x p and nonsingular
#' @param x vector of length p
#' @return scalar value
quadform_inv <- function(A, x) {
  drop(crossprod(x, solve(A, x)))
}

#' Centers the observations in a matrix by their respective class sample means
#'
#' @inheritParams lda_diag
#' @param y vector of class labels for each training observation
#' @return matrix with observations centered by its corresponding class sample
#' mean
center_data <- function(x, y) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  # Notice that the resulting centered data are sorted by class and do not
  # preserve the original ordering of the data.
  x_centered <- tapply(seq_along(y), y, function(i) {
    scale(x[i, ], center = TRUE, scale = FALSE)
  })
  x_centered <- do.call(rbind, x_centered)

  # Sorts the centered data to preserve the original ordering.
  orig_ordering <- do.call(c, tapply(seq_along(y), y, identity))
  x_centered[orig_ordering, ] <- x_centered
  x_centered
}

#' Computes the inverse of a symmetric, positive-definite matrix using the
#' Cholesky decomposition
#'
#' This often faster than [solve()] for larger matrices.
#' See, for example:
#' \url{http://blog.phytools.org/2012/12/faster-inversion-of-square-symmetric.html}
#' and
#' \url{http://stats.stackexchange.com/questions/14951/efficient-calculation-of-matrix-inverse-in-r}.
#'
#' @export
#' @param x symmetric, positive-definite matrix
#' @return the inverse of `x`
solve_chol <- function(x) {
  chol2inv(chol(x))
}

#' Computes the log determinant of a matrix.
#'
#' @export
#' @param x matrix
#' @return log determinant of `x`
log_determinant <- function(x) {
  # The call to 'as.vector' removes the attributes returned by 'determinant'
  as.vector(determinant(x, logarithm=TRUE)$modulus)
}

#' Computes multivariate normal density with a diagonal covariance matrix
#'
#' Alternative to `mvtnorm::dmvnorm`
#'
#' @importFrom stats dnorm
#' @param x matrix
#' @param mean vector of means
#' @param sigma vector containing diagonal covariance matrix
#' @return multivariate normal density
dmvnorm_diag <- function(x, mean, sigma) {
  exp(sum(dnorm(x, mean=mean, sd=sqrt(sigma), log=TRUE)))
}

#' Computes posterior probabilities via Bayes Theorem under normality
#'
#' @importFrom mvtnorm dmvnorm
#'
#' @param x matrix of observations
#' @param means list of means for each class
#' @param covs list of covariance matrices for each class
#' @param priors list of prior probabilities for each class
#' @return matrix of posterior probabilities for each observation
posterior_probs <- function(x, means, covs, priors) {
  if (is.vector(x)) {
    x <- matrix(x, nrow=1)
  }
  x <- pred_to_matrix(x)

  posterior <- mapply(function(xbar_k, cov_k, prior_k) {
    if (is.vector(cov_k)) {
      post_k <- apply(x, 1, function(obs) {
        dmvnorm_diag(x=obs, mean=xbar_k, sigma=cov_k)
      })
    } else {
      post_k <- dmvnorm(x=x, mean=xbar_k, sigma=cov_k)
    }
    prior_k * post_k
  }, means, covs, priors)

  if (is.vector(posterior)) {
    posterior <- posterior / sum(posterior)
  } else {
    posterior <- posterior / rowSums(posterior)
  }

  posterior
}

pred_to_matrix <- function(x) {
  if (is.vector(x)) {
    rlang::abort("'x' should be a matrix or data frame.")
  }

  if (is.null(colnames(x))) {
    rlang::abort("'x' should have column names.")
  }
  if (!is.matrix(x)) {
   x <- as.matrix(x)
   if (is.character(x)) {
     rlang::abort(
       paste(
         "When the predictors data were converted to a matrix, the matrix was",
         "no longer numeric. Were there non-numeric columns in the original",
         "data?"
       )
     )
   }
  }
  x
}

outcome_to_factor <- function(y) {
  if (is.numeric(y) | is.matrix(y) | is.data.frame(y)) {
    rlang::abort(
      paste(
        "The outcome data should be a character or factor vector."
      )
    )
  }
  if (!is.factor(y)) {
    y <- as.factor(y)
  }
  y
}

format_priors <- function(x) {
  priors <- vapply(x$est, function(x) x$prior, numeric(1))
  paste0(names(priors), " (", round(priors * 100, 2), "%)", collapse = ", ")
}

print_basics <- function(x, ...) {
  cat("Sample Size:", x$N, "\n")
  cat("Number of Features:", x$p, "\n\n")
  cat("Classes and Prior Probabilities:\n  ")
  cat(format_priors(x), "\n")
}

no_form_env <- function(x) {
  attr(x, ".Environment") <- rlang::base_env()
  x
}

new_discrim_object <- function(x, cls) {
  class(x) <- cls
  has_terms <- any(names(x) == ".terms")

  if (has_terms) {
    attr(x$.terms, ".Environment") <- rlang::base_env()
    class(x) <- c(paste0(cls, "_formula"), cls)
  }
  x
}

process_newdata <- function(object, x) {
  if (is.null(colnames(x))) {
    rlang::abort("'newdata' should have column names.")
  }
  has_terms <- any(names(object) == ".terms")
  if (has_terms) {
    .terms <- object$.terms
    .terms <- stats::delete.response(.terms)
    x <- stats::model.frame(.terms, x, na.action = stats::na.pass) #, xlev = object$xlevels)
    x <- model.matrix(.terms, x)
    attr(x, "contrasts") <- NULL
    attr(x, "assign") <- NULL
  }
  x <- x[, object$col_names, drop = FALSE]
  as.matrix(x)

}

min_index <- function(x) {
  if (any(is.na(x))) {
    NA_integer_
  } else {
    which.min(x)
  }
}

score_to_class <- function(x, object) {
  if (is.vector(x)) {
    min_scores <- min_index(x)
  } else {
    min_scores <- apply(x, 2, min_index)
  }
  factor(object$groups[min_scores], levels = object$groups)
}


hcf <- function(x, y) {
while(y) {
temp = y
y = x %% y
x = temp
}
return(x)
}


#' Stochastic User Equilibrium
#'
#' This function calculates stochastic user equilibrium (SUE) using the method of successive averages. Output is a list of SUE route flows x and corresponding path costs u.
#' @param ODdemand Vector of origin-destination (OD) travel demands
#' @param ODpair Vector indicating the OD pair serviced by each route (ordered by columns of the path-link incidence matrix, A).
#' @param A Path-link incidence matrix
#' @param Alpha Vector of free flow travel time parameters for each link
#' @param Beta Vector of capacity parameters for each link
#' @param pow Polynomial order of cost function for each link. Defaults to 4.
#' @param RUM Choice of random utility model. Can be "logit" (the default) or "probit".
#' @param x.ini Initialization route flows for SUE algorithm (optional).
#' @param theta A dispersion parameter. For the logit model, a single value specifying the logit parameter. For the probit model, a vector of standard deviations for the individual link cost errors. Defaults to 1.
#' @param tol Tolerance for convergence assessment (measured as route mean squared difference between current flow vector and the search direction). Defaults of 1e-4.
#' @param verbose Should progress of algorithm be printed out? Defaults to FALSE.
#' @return Output is a list of SUE route flows x and corresponding path costs u.
#' @keywords SUE
#' @examples
#' A <- matrix(c(0,1,0,0,1,0,0,0,0,1,1,0,0,0,1,0,0,0,0,1,1,0,0,0,0,0,0,1),ncol=4,byrow=T)
#' Alpha <- rep(10,7)
#' Beta <- rep(50,7)
#' pow <- rep(4,7)
#' ODpair <- c(1,1,2,2)
#' ODdemand <- c(50,50)
#' theta <- 0.7
#' SUE(ODdemand,ODpair,A=A,Alpha=Alpha,Beta=Beta,pow=pow,theta=theta,verbose=F)
#' @export

SUE <- function(ODdemand,ODpair,A,Alpha,Beta,pow=4,RUM="logit",x.ini = NULL,theta=1,tol=1e-4,verbose=F){
	if (any(ODdemand<=0)){ stop("All OD demands must be strictly positive") }
  	ODdemand.rep <- rep(ODdemand,unname(table(ODpair)))
        if(is.null(x.ini)) x.ini <- rep(ODdemand/unname(table(ODpair)), unname(table(ODpair)))
        x <- x.ini
  	gap <- 1
  	iter <- 1
  	while(gap > tol){
		u <- PathCost(x=x,A=A,Alpha=Alpha,Beta=Beta,pow=pow)
    		y <- PathProb(u=u,ODpair=ODpair,A=A,RUM=RUM,theta=theta)*ODdemand.rep
    		gap <- sqrt(mean(((x-y)/ODdemand.rep)^2))
   		if(verbose) cat(gap,"\n")
    		if(gap > tol){
      		x <- x + (y-x)/iter
     			iter <- iter + 1
		}
 	}
	list(x=unname(x),u=u)
}


# here is an ecample of how you would compute the sum for the first 20 integers
20*(20+1)/2

# however, we can define a variable to use the formula for other values of variable n
n <- 20
n*(n+1)/2

# remember the '<-' is how you would assign values to an object
n <- 25
n*(n+1)/2

# below is an example that would calculate the sum of the first 100 integers
n <- 100
n*(n+1)/2


#Copyright (c) 2016 Riccardo Francescato
a <- c(15,31,47,54,60)
b <- c(12,15,21,28,30)
cat(paste("Mean of a= ",mean(a)))
cat(paste("Mean of b= ",mean(b)))
cat(paste("Variance of a= ",var(a)))
cat(paste("Variance of b= ",var(b)))
cat(paste("Covariance= ",cov(a, b)))
cat(paste("Corr. coef.= ",cor(a, b)))


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('mle')
options(width=70)

## ----loglik,echo=FALSE,cap='log likelihood functions for three one-sample binomial problems',bty='l'----
p <- seq(.01, .99, by=.001)
loglike <- function(p, s, n) s*log(p)+(n-s)*log(1-p)
score <- function(p, s, n) s/p-(n-s)/(1-p)
info <- function(p, s, n) n/p/(1-p)
s <- c(50, 60, 12)
n <- c(100, 100, 20)
lt <- c(1, 3, 4)
cl <- 0.7
plot(1:2, 1:2, xlim=c(0,1), ylim=c(-150,-10), xlab="P",
     ylab="Log Likelihood", type="n")
labl <- paste("s=", s, "  n=", n, sep="")
legend(.125, -110, labl, lty=lt, bty="n", cex=cl)
q <- par()$usr
for(i in 1:3) {
  lines(p, loglike(p, s[i], n[i]), lty=lt[i])
  lines(c(.5, .5), c(q[3], loglike(.5, s[i], n[i])), lty=2)
  lines(c(q[1], .5), c(loglike(.5, s[i], n[i]), loglike(.5, s[i], n[i])), lty=2)
  pe <- s[i]/n[i]
  lines(c(pe, pe), c(q[3], loglike(pe, s[i], n[i])), lty=2)
  lines(c(q[1], pe), c(loglike(pe, s[i], n[i]), loglike(pe, s[i], n[i])), lty=2)
}

## ----score,echo=FALSE,cap='Score functions ($\\partial\\log L/\\partial P$)',bty='l'----
plot(0, 0, xlim=c(0,1), ylim=c(-500,600), xlab="P", ylab="Score", type="n")
legend(.05, -225, labl, lty=lt, bty="n", cex=cl)
for(i in 1:3) {
  lines(p, score(p, s[i], n[i]), lty=lt[i])
  q <- par()$usr
  lines(c(.5, .5), c(q[3], score(.5, s[i], n[i])), lty=2)
  lines(c(q[1], .5), c(score(.5, s[i], n[i]), score(.5, s[i], n[i])), lty=2)
  pe <- s[i]/n[i]
  lines(c(pe, pe), c(q[3], score(pe, s[i], n[i])), lty=2)
  lines(c(q[1], pe), c(score(pe, s[i], n[i]), score(pe, s[i], n[i])), lty=2)
}

## ----information,echo=FALSE,cap='Information functions ($- \\partial^{2}\\log L/\\partial P^{2})$',bty='l'----
plot(0, 0, xlim=c(0,1), ylim=c(80,1200), xlab="P", ylab="Information", type="n")
w <- c(1,3)
legend(.4, 1000, paste("n=", n[w], sep=""), lty=lt[w], bty="n", cex=cl)
for(i in w) lines(p, info(p, s[i], n[i]), lty=lt[i])

## ----results='asis'-----------------------------------------------------------
require(rms)
options(prType='latex')
n <- 200
set.seed(15)
x1 <- rnorm(n)
logit <- x1/2
y <- ifelse(runif(n) <= plogis(logit), 1, 0)
dd <- datadist(x1);  options(datadist='dd')
f <- lrm(y ~ pol(x1,2), x=TRUE, y=TRUE)
f
anova(f)

## ----bootor,cap='Distribution of 1000 bootstrap x=1:5 log odds ratios',h=2,w=3----
# Get 2-row design matrix for obtaining predicted values
# for x = 1 and 5
X <- cbind(Intercept=1,
           predict(f, data.frame(x1=c(1,5)), type='x'))
Xdif <- X[2,,drop=FALSE] - X[1,,drop=FALSE]
Xdif
b <- bootcov(f, B=1000)
boot.log.odds.ratio <- b$boot.Coef %*% t(Xdif)
sd(boot.log.odds.ratio)
# This is the same as from summary(b, x=c(1,5)) as summary
# uses the bootstrap covariance matrix
summary(b, x1=c(1,5))[1, 'S.E.']
# Compare this s.d. with one from information matrix
summary(f, x1=c(1,5))[1,'S.E.']
# Compute percentiles of bootstrap odds ratio
exp(quantile(boot.log.odds.ratio, c(.025, .975)))
# Automatic:
summary(b, x1=c(1,5))[' Odds Ratio',]
print(contrast(b, list(x1=5), list(x1=1), fun=exp))
# Figure (*\ref{fig:mle-bootor}*)
hist(boot.log.odds.ratio, nclass=100, xlab='log(OR)', main='')

## ----bootvary,h=4,w=6.5,cache=TRUE,cap='Predicted log odds and confidence bands for seven types of confidence intervals.  Seven categories are ordered top to bottom corresponding to order of lower confidence bands at \\texttt{x1=5}.  Dotted lines are for Wald--type methods that yield symmetric confidence intervals and assume normality of point estimators.',scap='Seven types of confidence bands'----
x1s <- seq(0, 5, length=100)
pwald     <- Predict(f, x1=x1s)
psand     <- Predict(robcov(f), x1=x1s)
pbootcov  <- Predict(b, x1=x1s, usebootcoef=FALSE)
pbootnp   <- Predict(b, x1=x1s)
pbootbca  <- Predict(b, x1=x1s, boot.type='bca')
pbootbas  <- Predict(b, x1=x1s, boot.type='basic')
psimult   <- Predict(b, x1=x1s, conf.type='simultaneous')
z <- rbind('Boot percentile'     = pbootnp,
           'Robust sandwich'     = psand,
           'Boot BCa'            = pbootbca,
           'Boot covariance+Wald'= pbootcov,
           Wald                  = pwald,
           'Boot basic'          = pbootbas,
           Simultaneous          = psimult)

z$class <- ifelse(z$.set. %in% c('Boot percentile','Boot bca',
             'Boot basic'), 'Other', 'Wald')
ggplot(z, groups=c('.set.', 'class'),
       conf='line', ylim=c(-1, 9), legend.label=FALSE)

## ----pmle,w=5,h=3.25,fig.align='right',cap='Penalized least squares estimates for an unnecessary five-knot restricted cubic spline function.  In the left graph all parameters (except the intercept) are penalized.  The effective d.f.\\ are $4, 3.21, 2.71, 2.30, 2.03, 1.82$, and $1.51$.  In the right graph, only parameters associated with nonlinear functions of $X_{1}$ are penalized.  The effective d.f.\ are $4, 3.22, 2.73, 2.34, 2.11, 1.96$, and $1.68$.',scap='Penalized least squares estimates'----
set.seed(191)
x1 <- rnorm(100)
y  <- x1 + rnorm(100)
pens <- df <- aic <- c(0,.07,.5,2,6,15,60)
all <- nl <- list()

for(penalize in 1:2) {
  for(i in 1:length(pens)) {
    f <- ols(y ~ rcs(x1,5), penalty=
             list(simple=if(penalize==1)pens[i] else 0,
                  nonlinear=pens[i]))
    df[i] <-  f$stats['d.f.']
    aic[i] <- AIC(f)
    nam <- paste(if(penalize == 1) 'all' else 'nl',
                 ' penalty:', pens[i], sep='')
    nam <- as.character(pens[i])
    p <- Predict(f, x1=seq(-2.5, 2.5, length=100),
                 conf.int=FALSE)
    if(penalize == 1) all[[nam]] <- p else nl[[nam]] <- p
  }
  print(rbind(df=df, aic=aic))
}
all <- do.call('rbind', all); all$type <- 'Penalize All'
nl  <- do.call('rbind', nl) ; nl$type  <- 'Penalize Nonlinear'
both <- as.data.frame(rbind.data.frame(all, nl))
both$Penalty <- both$.set.
ggplot(both, aes(x=x1, y=yhat, color=Penalty)) + geom_line() +
  geom_abline(col=gray(.7)) + facet_grid(~ type)
# Figure (*\ref{fig:mle-pmle}*)


rref <- function(m) {
  pivot <- 1
  norow <- nrow(m)
  nocolumn <- ncol(m)
  for(r in 1:norow) {
    if ( nocolumn <= pivot ) break;
    i <- r
    while( m[i,pivot] == 0 ) {
      i <- i + 1
      if ( norow == i ) {
        i <- r
        pivot <- pivot + 1
        if ( nocolumn == pivot ) return(m)
      }
    }
    trow <- m[i, ]
    m[i, ] <- m[r, ]
    m[r, ] <- trow
    m[r, ] <- m[r, ] / m[r, pivot]
    for(i in 1:norow) {
      if ( i != r )
        m[i, ] <- m[i, ] - m[r, ] * m[i, pivot]
    }
    pivot <- pivot + 1
  }
  return(m)
}

m <- matrix(c(1, 2, -1, -4,
              2, 3, -1, -11,
              -2, 0, -3, 22), 3, 4, byrow=TRUE)
print(m)
print(rref(m))


library("plot3D")
library("plotrix")
library("scatterplot3d")
library("animation")

################################################################################
#   1
################################################################################

x <- seq(0, 10, by = 0.001)
plot(x, dnorm(x, 5, 1), type = 'l')
title("1-d Gaussian function")

################################################################################
#   2
################################################################################

x <- seq(0, 10, 0.1)
y <- x
f <- function(x, y) {
    mean <- 5
    distanceToMean <- sqrt( (x - mean)^2 + (y - mean)^2 )
    return(dnorm(distanceToMean, 0, 1))
}
z <- outer(x, y, f)
persp(x, y, z, theta = 30, phi = 30, col = "lightblue", ticktype = "detailed")
title("2-d Gaussian function")

################################################################################
#   3
################################################################################

x <- seq(1, 10, 0.001)
hist(rnorm(x, 5, 1), breaks = 100)
# title("1-d Gaussian random data histogram")

################################################################################
#   4
################################################################################

acc <- matrix(0, 40, 40)
x <- rnorm(10000, 5, 1)
y <- rnorm(10000, 5, 1)

plot(x, y)
title("2-d Gaussian random data")

for (i in 1:10000) {
    xi <- ceiling(x[i] * 4)
    yi <- ceiling(y[i] * 4)
    acc[xi, yi] <- acc[xi, yi] + 1
}
hist3D(z = acc, ticktype = "detailed",)
title("2-d Gaussian random data histogram")

################################################################################
#   5
################################################################################

tcol <- terrain.colors(12)
contour(acc, col = tcol, lty = "solid")
title("2-d Gaussian random data contour")

################################################################################
#   6
################################################################################

plot(NA, xlim=c(0,10), ylim=c(0,10), xlab="x", ylab="y")
segments(0, -1, 11, 10)
title("x - y = 1")

################################################################################
#   7
################################################################################

plot(NA, xlim=c(-2,2), ylim=c(-2,2), xlab="x", ylab="y")
draw.circle(0, 0, 1)
title("x² + y² = 1")

################################################################################
#   8
################################################################################

plot(NA, xlim=c(-2,2), ylim=c(-2,2), xlab="x", ylab="y")
draw.ellipse(0, 0, 1, 2)
title("x² + y²/4 = 1")

################################################################################
#   9
################################################################################

f <- function(x,y) x^2 - (y^2)/4 - 1
x <- y <- seq(-10,10,length=100)
z <- outer(x,y,f)
contour(
  x = x, y = x, z = z,
  levels = 0, las = 1, drawlabels = FALSE, lwd = 3,
  xlab = "x", ylab = "y"
)
title("x² - y²/4 = 1")

################################################################################
#   10
################################################################################

x <- 1:100
y <- x * 2

plot(x, y)
title("2x - y = 0")

################################################################################
#   11
################################################################################

x <- seq(-2, 2, by = 0.04)
y <- sqrt(4 - x ^ 2)

plot(x, y,
    asp = 1, xlim = c(-2,2), ylim = c(-2,2),
    xlab = "x", ylab = "y")
par(new = TRUE)
plot(x, -y,
    asp = 1, xlim = c(-2,2), ylim = c(-2,2),
    xlab = "x", ylab = "y")

title("x² + y² = 4")

################################################################################
#   12
################################################################################

x <- seq(-2, 2, by = 0.04)
y <- sqrt(1 - (x ^ 2) / 4)

plot(x, y,
    asp = 1, xlim = c(-2,2), ylim = c(-2,2),
    xlab = "x", ylab = "y")
par(new = TRUE)
plot(x, -y,
    asp = 1, xlim = c(-2,2), ylim = c(-2,2),
    xlab = "x", ylab = "y")

title("x²/4 + y² = 4")

################################################################################
#   13
################################################################################

x <- seq(-1, 1, by = 0.02)
y <- 1 / x

plot(x, y)
title("xy = 1")

################################################################################
#   14
################################################################################

i <- 0:96
r <- 6.5 * (104 - i) / 104
theta <- pi * i / 16
x <- r * sin(theta)
y <- r * cos(theta)

plot(x, y,
    asp = 1, xlim = c(-8,8), ylim = c(-8,8),
    xlab = "x", ylab = "y", col = "red")
par(new = TRUE)
x <- - r * sin(theta)
y <- - r * cos(theta)
plot(x, y,
    asp = 1, xlim = c(-8,8), ylim = c(-8,8),
    xlab = "x", ylab = "y", col = "blue")
title("2 spirals")

################################################################################
#   15
################################################################################

x1 <- c(0, 0, 1, 0)
y1 <- c(1, 0, 1, 1)
z1 <- c(1, 1, 1, 0)

x2 <- c(0, 1, 1, 1)
y2 <- c(0, 0, 0, 1)
z2 <- c(0, 0, 1, 0)

points1 <- cbind(x1, y1, z1)
points2 <- cbind(x2, y2, z2)

graph <- scatterplot3d(points1, color = "blue", type = "p",
    xlim = c(0, 1), ylim = c(0, 1), zlim = c(-0.1, 1.1),
    xlab = "x", ylab = "y", zlab = "z")
graph$points3d(points2, col = "red", type = "p")
graph$plane3d(c(0.4, 1, -0.5))
title("hyperplane")

################################################################################
#   16
################################################################################

i <- 1:1000
theta <- (pi * i) / 1000
r <- rnorm(1000, 1, 0.1)

x <- r * cos(theta)
y <- r * sin(theta)

plot(x, y,
    asp = 1, xlim = c(-2,3), ylim = c(-2,2),
    xlab = "x", ylab = "y", col = "red")
par(new = TRUE)
x <- r * cos(theta) + 1
y <- - r * sin(theta)
plot(x, y,
    asp = 1, xlim = c(-2,3), ylim = c(-2,2),
    xlab = "x", ylab = "y", col = "blue")
title("2 moons")

################################################################################
#   16
################################################################################

saveGIF({
  for(i in 1:100){
    curve(sin(x), from = -5 + (i * 0.05), to = 5 + (i * 0.05), col = "red", ylab = "")
    curve(sin(x/2), from = -5 + (i * 0.05), to = 5 + (i * 0.05), add = TRUE, col = "blue", ylab = "")
    curve(sin(x/3), from = -5 + (i * 0.05), to = 5 + (i * 0.05), add = TRUE, col = "green", ylab = "")
    curve(sin(x/4), from = -5 + (i * 0.05), to = 5 + (i * 0.05), add = TRUE, col = "cyan", ylab = "")
    curve(sin(x/5), from = -5 + (i * 0.05), to = 5 + (i * 0.05), add = TRUE, col = "orange", ylab = "")
    legend("topright", legend = c("sin(x)", "sin(x/2)", "sin(x/3)", "sin(x/4)", "sin(x/5)"), fill = c("red", "blue", "green", "cyan", "orange"), bty = "n")
  }
}, interval = 0.1, ani.width = 550, ani.height = 350)


###############################################################################
#
# library
#
library(VGAM)   # zeta function
library(R.matlab) # read matlab file just for test purpose
#
###############################################################################
#
# test zone
#
###############################################################################
runtest <- function(){
 #read a matlab file
 #x generated by x = randht(10000,'xmin',15,'powerlaw',2.5) with matlab (continuous law)
 x<-readMat(file("x_2.5_15_10000.mat","rb"))$x[,1]
 #plfit matlab:alpha=2.4975,xmin=18.5752,D=0.0062
 plfit(x)
 #plfit R:alpha=2.497485,xmin=18.57524,D=0.006174977
 #x0 generated by x0 =floor(x) with matlab (big discrete approximation)
 x0<-readMat(file("x0_2.5_15_10000.mat","rb"))$x[,1]
 #plfit matlab:alpha=2.4700,xmin=15,D=0.0056
 plfit(x0)
 #plfit r:alpha=2.47,xmin=15,D=0.00564463

}
###############################################################################
#
# PLFIT fits a power-law distributional model to data.
#
#    PLFIT(x) estimates x_min and alpha according to the goodness-of-fit
#    based method described in Clauset, Shalizi, Newman (2007). x is a
#    vector of observations of some quantity to which we wish to fit the
#    power-law distribution p(x) ~ x^-alpha for x >= xmin.
#    PLFIT automatically detects whether x is composed of real or integer
#    values, and applies the appropriate method. For discrete data, if
#    min(x) > 1000, PLFIT uses the continuous approximation, which is
#    a reliable in this regime.
#
#    The fitting procedure works as follows:
#    1) For each possible choice of x_min, we estimate alpha via the
#       method of maximum likelihood, and calculate the Kolmogorov-Smirnov
#       goodness-of-fit statistic D.
#    2) We then select as our estimate of x_min, the value that gives the
#       minimum value D over all values of x_min.
#
#    Note that this procedure gives no estimate of the uncertainty of the
#    fitted parameters, nor of the validity of the fit.
#
#    Example:
#       x <- (1-runif(10000))^(-1/(2.5-1))
#       plfit(x)
#
#
# Version 1.0   (2008 February)
# Version 1.1   (2008 February)
#    - correction : division by zero if limit >= max(x) because the unique R function do no sort
#                   and the matlab function do...
# Version 1.1   (minor correction 2009 August)
#    - correction : lines 230 zdiff calcul was wrong when xmin=0 (thanks to Naoki Masuda)
#    - gpl version updated to v3.0 (asked by Felipe Ortega)
# Version 1.2 (2011 August)
#    - correction for method "limit" thanks to David R. Pugh
#      xmins <- xmins[xmins<=limit] is now xmins <- xmins[xmins>=limit]
#    - "fixed" method added for xmins from David R. Pugh
#    - modifications by Alan Di Vittorio:
#       - correction : zdiff calculation was wrong when xmin==1
#       - the previous zdiff correction was incorrect
#       - correction : x has to have at least two unique values
#       - additional discrete x input test : discrete x cannot contain the value 0
#       - added option to truncate continuous xmin search when # of obs gets small
#
# Copyright (C) 2008,2011 Laurent Dubroca laurent.dubroca_at_gmail.com
# (Stazione Zoologica Anton Dohrn, Napoli, Italy)
# Distributed under GPL 3.0
# http://www.gnu.org/copyleft/gpl.html
# PLFIT comes with ABSOLUTELY NO WARRANTY
# Matlab to R translation based on the original code of Aaron Clauset (Santa Fe Institute)
# Source: http://www.santafe.edu/~aaronc/powerlaws/
#
# Notes:
#
# 1. In order to implement the integer-based methods in Matlab, the numeric
#    maximization of the log-likelihood function was used. This requires
#    that we specify the range of scaling parameters considered. We set
#    this range to be seq(1.5,3.5,0.01) by default. This vector can be
#    set by the user like so,
#
#       a <- plfit(x,"range",seq(1.001,5,0.001))
#
# 2. PLFIT can be told to limit the range of values considered as estimates
#    for xmin in two ways. First, it can be instructed to sample these
#    possible values like so,
#
#       a <- plfit(x,"sample",100)
#
#    which uses 100 uniformly distributed values on the sorted list of
#    unique values in the data set. Alternatively, it can simply omit all
#    candidates below a hard limit, like so
#
#       a <- plfit(x,"limit",3.4)
#
#    In the case of discrete data, it rounds the limit to the nearest
#    integer.
#
#     Finally, if you wish to force the threshold parameter to take a specific value
#     (useful for bootstrapping), simply call plfit() like so
#
#       a <- plfit(x,"fixed",3.5)
#
# 3. When the input sample size is small (e.g., < 100), the estimator is
#    known to be slightly biased (toward larger values of alpha). To
#    explicitly use an experimental finite-size correction, call PLFIT like
#    so
#
#       a <- plfit(x,finite=TRUE)
#
# 4. For continuous data, PLFIT can return erroneously large estimates of
#    alpha when xmin is so large that the number of obs x >= xmin is very
#    small. To prevent this, we can truncate the search over xmin values
#    before the finite-size bias becomes significant by calling PLFIT as
#
#       a = plfit(x,nosmall=TRUE);
#
#    which skips values xmin with finite size bias > 0.1.
#
###############################################################################
plfit<-function(x=rpareto(1000,10,2.5),method="limit",value=c(),finite=FALSE,nowarn=FALSE,nosmall=FALSE){
   #init method value to NULL
   vec <- c() ; sampl <- c() ; limit <- c(); fixed <- c()
###########################################################################################
#
#  test and trap for bad input
#
   switch(method,
     range = vec <- value,
     sample = sampl <- value,
     limit = limit <- value,
     fixed = fixed <- value,
     argok <- 0)

   if(exists("argok")){stop("(plfit) Unrecognized method")}

   if( !is.null(vec) && (!is.vector(vec) || min(vec)<=1 || length(vec)<=1) ){
     print(paste("(plfit) Error: ''range'' argument must contain a vector > 1; using default."))
     vec <- c()
   }
   if( !is.null(sampl) && ( !(sampl==floor(sampl)) ||  length(sampl)>1 || sampl<2 ) ){
     print(paste("(plfit) Error: ''sample'' argument must be a positive integer > 2; using default."))
     sample <- c()
   }
   if( !is.null(limit) && (length(limit)>1 || limit<1) ){
     print(paste("(plfit) Error: ''limit'' argument must be a positive >=1; using default."))
     limit <- c()
   }
   if( !is.null(fixed) && (length(fixed)>1 || fixed<=0) ){
     print(paste("(plfit) Error: ''fixed'' argument must be a positive >0; using default."))
     fixed <- c()
   }

#  select method (discrete or continuous) for fitting and test if x is a vector
   fdattype<-"unknow"
   if( is.vector(x,"numeric") ){ fdattype<-"real" }
   if( all(x==floor(x)) && is.vector(x) ){ fdattype<-"integer" }
   if( all(x==floor(x)) && min(x) > 1000 && length(x) > 100 ){ fdattype <- "real" }
   if( fdattype=="unknow" ){ stop("(plfit) Error: x must contain only reals or only integers.") }

#
#  end test and trap for bad input
#
###########################################################################################

###########################################################################################
#
#  estimate xmin and alpha in the continuous case
#
   if( fdattype=="real" ){

    xmins <- sort(unique(x))
    xmins <- xmins[-length(xmins)]

    if( !is.null(limit) ){
      xmins <- xmins[xmins>=limit]
    }
    if( !is.null(fixed) ){
      xmins <- fixed
    }
    if( !is.null(sampl) ){
      xmins <- xmins[unique(round(seq(1,length(xmins),length.out=sampl)))]
    }

    dat <- rep(0,length(xmins))
    z   <- sort(x)

    for( xm in 1:length(xmins) ){
      xmin <- xmins[xm]
      z    <- z[z>=xmin]
      n    <- length(z)
      # estimate alpha using direct MLE
      a    <- n/sum(log(z/xmin))
      # truncate search if nosmall is selected
      if( nosmall ){
       if((a-1)/sqrt(n) > 0.1){
           dat <- dat[1:(xm-1)]
           print(paste("(plfit) Warning : xmin search truncated beyond",xmins[xm-1]))
           break
       }
      }
      # compute KS statistic
      cx   <- c(0:(n-1))/n
      cf   <- 1-(xmin/z)^a
      dat[xm] <- max(abs(cf-cx))
    }

    D     <- min(dat)
    xmin  <- xmins[min(which(dat<=D))]
    z     <- x[x>=xmin]
    n     <- length(z)
    alpha <- 1 + n/sum(log(z/xmin))

    if( finite ){
      alpha <- alpha*(n-1)/n+1/n # finite-size correction
    }
    if( n<50 && !finite && !nowarn){
      print("(plfit) Warning : finite-size bias may be present")
    }

   }
#
#  end continuous case
#
###########################################################################################

###########################################################################################
#
#  estimate xmin and alpha in the discrete case
#
   if( fdattype=="integer" ){

    if( is.null(vec) ){ vec<-seq(1.5,3.5,.01) } # covers range of most practical scaling parameters
    zvec <- zeta(vec)

    xmins <- sort(unique(x))
    xmins <- xmins[-length(xmins)]

    if( !is.null(limit) ){
      limit <- round(limit)
      xmins <- xmins[xmins>=limit]
    }

    if( !is.null(fixed) ){
      xmins <- fixed
    }

    if( !is.null(sampl) ){
      xmins <- xmins[unique(round(seq(1,length(xmins),length.out=sampl)))]
    }

    if( is.null(xmins) || length(xmins) < 2){
      stop("(plfit) error: x must contain at least two unique values.")
    }

    if(length(which(xmins==0) > 0)){
      stop("(plfit) error: x must not contain the value 0.")
    }

    xmax <- max(x)
     dat <- matrix(0,nrow=length(xmins),ncol=2)
       z <- x
    for( xm in 1:length(xmins) ){
      xmin <- xmins[xm]
      z    <- z[z>=xmin]
      n    <- length(z)
      # estimate alpha via direct maximization of likelihood function
      #  vectorized version of numerical calculation
      # matlab: zdiff = sum( repmat((1:xmin-1)',1,length(vec)).^-repmat(vec,xmin-1,1) ,1);
      if(xmin==1){
        zdiff <- rep(0,length(vec))
      }else{
       zdiff <- apply(rep(t(1:(xmin-1)),length(vec))^-t(kronecker(t(array(1,xmin-1)),vec)),2,sum)
      }
      # matlab: L = -vec.*sum(log(z)) - n.*log(zvec - zdiff);
      L <- -vec*sum(log(z)) - n*log(zvec - zdiff);
      I <- which.max(L)
      # compute KS statistic
      fit <- cumsum((((xmin:xmax)^-vec[I])) / (zvec[I] - sum((1:(xmin-1))^-vec[I])))
      cdi <- cumsum(hist(z,c(min(z)-1,(xmin+.5):xmax,max(z)+1),plot=FALSE)$counts/n)
      dat[xm,] <- c(max(abs( fit - cdi )),vec[I])
    }
    D     <- min(dat[,1])
    I     <- which.min(dat[,1])
    xmin  <- xmins[I]
    n     <- sum(x>=xmin)
    alpha <- dat[I,2]

    if( finite ){
      alpha <- alpha*(n-1)/n+1/n # finite-size correction
    }
    if( n<50 && !finite && !nowarn){
      print("(plfit) Warning : finite-size bias may be present")
    }

   }
#
#  end discrete case
#
###########################################################################################

#  return xmin, alpha and D in a list
   return(list(xmin=xmin,alpha=alpha,D=D))
}


function()
{
  n=as.integer(readline(prompt = "Enter any number"))
  fact=1
  for(i in 1:n)
  {
      fact=fact*i
  }
  print(paste("Factorial is ",fact))
}
multi<- function()
{
  no=as.integer(readline(prompt = "Enter no to print its multplicatio table "))
  mult=1
  for(i in 1:10)
  {
    mult=no*i
    print(paste(no,"X",i,"=",mult))
  }
}
multi()

primeno <- function()
{
  flag=1
  num=as.integer(readline(prompt = "Enter no to check prime"))
  mult=1
  i=1
  temp=num-1
  for(i in 2:temp)
  {
    if(num%%i==0)
    {

      flag=0
      break
    }
  }
  ifelse(flag==0,"no is not prime","no is prime")
}
primeno()

fibonacci<-function()
{
  f1=0
  f2=1
  f3=0
  num=as.integer(readline(prompt = "Enter a number"))
  print(f1)
  print(f2)
  while(num>0) {
    f3=f1+f2
    print(f3)
    f1=f2
    f2=f3
    num=num-1
  }
}
fibonacci()

SumOfN<-function()
{
  n=as.integer(readline(prompt = "Enter a number"))
  i=1
  sum=0
  repeat
  {
    sum=sum+i
    i=i+1
    if(i>n)
    {
      break
    }
    }
  print(sum)
}
SumOfN()

SumOfDigit<-function()
{
  n=as.integer(readline(prompt = "Enter a number"))
  sum=0
  rem=0
  while(n>0)
  {
    rem=n%%10
    sum=sum+rem
    n=n%/%10

  }
  print(paste("Sum of digits is : ",sum))
}
SumOfDigit()

PerfectNumber=function()
{
  n=as.integer(readline(prompt = "Enter a number"))
  temp=n-1
  sum=0
  for(i in 1:temp)
  {
    if(n%%i==0)
      sum=sum+i
  }
  if(sum==n)
    print("No is perfect ")
  else
    print("No is not perfect")
}
PerfectNumber()


kf = function(q) {
    (asin(2*q-1)+pi/2)/pi
}
data = data.frame(q=x, k=kf(x), q2=x^2, q3=x^3, q4=x^4)

### train on data in [0.03, 0.5], but we only use the polynomial for
### data in [0.05, 0.5]
limit = 0.03
m = lm(k~q+q2+q3+q4, data[data$q>limit,])
data$m = 0
data[data$q>limit,]$m = predict(m)
m$coefficients

data$z = 2*data$q-1
data = cbind(data, data.frame(t2=cos(2*acos(data$z)), t3=cos(3*acos(data$z)),
    t4=cos(4*acos(data$z)),
    t5=cos(5*acos(data$z)),
    t6=cos(6*acos(data$z)),
    t7=cos(7*acos(data$z)),
    t8=cos(8*acos(data$z)),
    t9=cos(9*acos(data$z))
))
m.cheb = lm(k~z+t2+t3+t4+t5+t6+t7+t8+t9, data[data$q>limit,])

data$m.cheb = 0
data[data$q>limit,]$m.cheb = predict(m.cheb)

plot(m-k~q, data[data$q>limit,], type='l')
lines(m.cheb-k~q, data[data$q>0.05,], type='l', col='red')


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

y <- seq(0.5, 8.5, by=0.01)   # range of yields
d6m <- 1/(1+y/2/100)   # 6-month discount factor
c1 <- 4.5  # annual coupon
b1 <- c1/2*(d6m+d6m^2+d6m^3+d6m^4) + 100*d6m^4  # 2Y bond
b2 <- c1/(y/100)*(1-d6m^10) + 100*d6m^10        # 5Y bond
b3 <- c1/(y/100)*(1-d6m^20) + 100*d6m^20        # 10Y bond
b4 <- c1/(y/100)*(1-d6m^40) + 100*d6m^40        # 20Y bond

plot(y,b4, type='l', xlim=c(1,8), lty=1, lwd=2, col="purple")
lines(y, b3, lty=2, lwd=2, col="magenta")
lines(y, b2, lty=3, lwd=2, col="red")
lines(y, b1, lty=4, lwd=2, col="orange")
abline(h=100, lty=1, lwd=1, col="gray")
legend.text <- c("20Y", "10Y", "5Y", "2Y")
legend("topright", legend.text, lty=1:4, lwd=2, col=c("purple","magenta","red","orange"))


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

library(deSolve)
library(rstan)
library(shinystan)
library(ggplot2)
library(RColorBrewer)
library(reshape2)

SIR <- function(Time, State, Pars) {

    with(as.list(c(State, Pars)), {

        B   <- R0*r/N
        BSI <- B*S*I
        rI  <- r*I

        dS = -BSI
        dI = BSI - rI
        dR = rI

        return(list(c(dS, dI, dR)))

    })

}

pars  <- c(R0  <- 3.0,    # average number of new infected individuals per infectious person
           r   <- 0.1,    # recovery rate
           N   <- 500)    # population size

T <- 100
y_ini <- c(S = 495, I = 5, R = 0)
times <- seq(0, T, by = 1)

odeout <- ode(y_ini, times, SIR, pars)

set.seed(1001)
sigma <- 10
infec_counts_raw <- odeout[,3] + rnorm(T+1, 0, sigma)
infec_counts     <- ifelse(infec_counts_raw < 0, 0, infec_counts_raw)

g <- qplot(0:T, odeout[,3], geom = "line", xlab = "Time (weeks)", ylab = "Infection Count") +
		geom_point(aes(y = infec_counts)) +
		theme_bw()

print(g)
ggsave(g, filename="dataplot.pdf", height=4, width=6.5)

sPw <- 7
datlen <- (T-1)*7 + 1

data <- matrix(data = -1, nrow = T+1, ncol = sPw)
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/sPw )   # step size per day

rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())
stan_options <- list(   chains = 4,    # number of chains
                        iter   = 2000, # iterations per chain
                        warmup = 1000, # warmup interations
                        thin   = 2)   # thinning number
fit <- stan(file    = "d_sirode_euler.stan",
            data    = sir_data,
            chains  = stan_options$chains,
            iter    = stan_options$iter,
            warmup  = stan_options$warmup,
            thin    = stan_options$thin )

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

R0points <- exfit$R0
R0kernel <- qplot(R0points, geom = "density", xlab = expression(R[0]), ylab = "frequency") +
				geom_vline(aes(xintercept=R0), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(R0kernel)
ggsave(R0kernel, filename="kernelR0.pdf", height=3, width=3.25)

rpoints <- exfit$r
rkernel <- qplot(rpoints, geom = "density", xlab = "r", ylab = "frequency") +
				geom_vline(aes(xintercept=r), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(rkernel)
ggsave(rkernel, filename="kernelr.pdf", height=3, width=3.25)

sigmapoints <- exfit$sigma
sigmakernel <- qplot(sigmapoints, geom = "density", xlab = expression(sigma), ylab = "frequency") +
				geom_vline(aes(xintercept=sigma), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(sigmakernel)
ggsave(sigmakernel, filename="kernelsigma.pdf", height=3, width=3.25)

infecpoints <- exfit$y0[,2]
infeckernel <- qplot(infecpoints, geom = "density", xlab = "Initial Infected", ylab = "frequency") +
				geom_vline(aes(xintercept=y_ini[['I']]), linetype="dashed", size=1, color="grey50") +
				theme_bw()

print(infeckernel)
ggsave(infeckernel, filename="kernelinfec.pdf", height=3, width=3.25)

exfit <- extract(fit, permuted = FALSE, inc_warmup = FALSE)
plotdata <- melt(exfit[,,"R0"])
tracefitR0 <- ggplot() +
              geom_line(data = plotdata,
                        aes(x = iterations,
                        y = value,
                        color = factor(chains, labels = 1:stan_options$chains))) +
              labs(x = "Sample", y = expression(R[0]), color = "Chain") +
              scale_color_brewer(palette="Greys") +
              theme_bw()

print(tracefitR0)
ggsave(tracefitR0, filename="traceplotR0.pdf", height=4, width=6.5)

exfit <- extract(fit, permuted = FALSE, inc_warmup = TRUE)
plotdata <- melt(exfit[,,"R0"])
tracefitR0 <- ggplot() +
              geom_line(data = plotdata,
                        aes(x = iterations,
                        y = value,
                        color = factor(chains, labels = 1:stan_options$chains))) +
              labs(x = "Sample", y = expression(R[0]), color = "Chain") +
              scale_color_brewer(palette="Greys") +
              theme_bw()

print(tracefitR0)
ggsave(tracefitR0, filename="traceplotR0_inc.pdf", height=4, width=6.5)

sso <- as.shinystan(fit)
sso <- launch_shinystan(sso)


## See http://stats.stackexchange.com/questions/147733/equation-of-a-fitted-smooth-spline-and-its-analytical-derivative

## This fits a natural spline (linear tail restricted) using the truncated
## power basis.  Default knots are not used; instead specify 4 knots.
require(rms)
x <- 1:11
y <- c(0.2,0.40, 0.6, 0.75, 0.88, 0.99, 1.1, 1.15, 1.16, 1.16, 1.16 )
dd <- datadist(x); options(datadist='dd')

f <- ols(y ~ rcs(x, c(3, 5, 7, 9)))
f
anova(f)
ggplot(Predict(f)) + geom_point(aes(x=x, y=y), data=data.frame(x,y))
Function(f)   ## if have latex installed can also use latex(f)

## Function re-expresses the restricted cubic spline in simplest form

## The first derivative is:

## function(x) 0.174 - 3 * 0.00279 * pmax(x - 3, 0) ^ 2 + 3 * 0.0015 * pmax(x - 5, 0) ^ 2 + ...


model_deterministic_simulateR <- function(init_obs, period_start, times, pars, fix_pars){
  ode_solveR <- function(stage_pars, fix_pars, old_values) {
    ## stage pars
    b = stage_pars[1]
    r = stage_pars[2]
    ## fixed pars
    alpha= fix_pars[1]
    beta_1 = fix_pars[2]
    delta_1 = fix_pars[3]
    lambda = fix_pars[4]
    mu = fix_pars[5]
    mu_c = fix_pars[6]
    De = fix_pars[7]
    Dr = fix_pars[8]
    N = fix_pars[9]
    ## old values
    S = old_values[1]
    E = old_values[2]
    U = old_values[3]
    P = old_values[4]
    RU = old_values[5]
    RR = old_values[6]
    DU = old_values[7]
    DR = old_values[8]
    ## new values

    S_new = S - 0.5* b * S * (P + alpha* U) / N + lambda * N - mu * S
    E_new = E + 0.5 * b * S * (P + alpha * U ) / N - E / De - mu * E
    U_new = U + (1 - r) * E / De - U / (beta_1 * Dr) - delta_1 * mu_c * U - mu * U
    P_new = P + r * E / De - P / Dr - mu_c * P - mu * P
    RU_new <- RU + U / (beta_1 * Dr) - mu * RU
    RR_new <- RR + P / Dr - mu * RR
    DU_new <- DU + delta_1 * mu_c * U
    DR_new <- DR + mu_c * P
    est_P_new_n <- E
    est_P_new_prob <- r/ De
    est_RD_new_n <- P
    est_RD_new_prob_R <- 1 / Dr
    est_RD_new_prob_D <- mu_c

    return(c(S_new, E_new, U_new, P_new,RU_new, RR_new, DU_new, DR_new,
             est_P_new_n, est_P_new_prob,
             est_RD_new_n, est_RD_new_prob_R, est_RD_new_prob_D))
  }
  n_period = length(period_start)
  ymat = matrix(0, length(times), length(init_obs) + 6)
  ymat[, 1] = times

  colnames(ymat) <- c("time", names(init_obs), "est_p_n", "est_p_prob", "est_RD_n", "est_RD_prob_R", "est_RD_prob_D")

  which.period <- function(i, phase = period_start){ # function to determine which period i falls in
    sum(i >= phase)
  }

  for(i in 1:length(times)){
    stage_pars <- c(b = pars[which.period(i)], r = pars[n_period + which.period(i)])
    if(i == 1) {
      old_values <- init_obs
    } else {
      old_values <- ymat[i - 1, 2:9]
    }
    ymat[i, 2:14] <- ode_solveR(stage_pars = stage_pars, fix_pars = fix_pars, old_values = old_values)
  }
  return(ymat)
}


weight <- function(euclidean.dist, sigma) {
	return (exp(-euclidean.dist^2 / (2*sigma^2)))
}

dwnn <- function(knowledge.base, query, sigma=0.5) {

	classId = ncol(knowledge.base)

	euclidean.dist =
	  apply(knowledge.base, 1, function(row) {
			sqrt(sum((row[1:(classId-1)] - query)^2)) })

  	w = weight(euclidean.dist, sigma)
	Y = knowledge.base[,classId]

	y = sum(w * Y) / sum(w)

	return (y)
}

dwnn.recursive <- function(dataset, time.delay, train.from=1, train.to=floor((nrow(dataset)*2)/3), sigma=0.5) {

	original.dataset = dataset
	ncol = ncol(dataset)

	for (to in (train.to+1):nrow(dataset)) {
		query = as.numeric(dataset[(to-time.delay),2:ncol])
		y = dwnn(dataset[train.from:(to-1),], query, sigma)
		dataset[to,] = c(query, y)
	}

	ret = list()
	ret$original.dataset = original.dataset
	ret$predicted.dataset = dataset

	return (ret)
}

concept.drift <- function(series, m, d, window.length=250, by=1) {

	dataset = embedd(series, m=m, d=d)
	divergence = c() #rep(NA, floor(window.length/by))

	for (window.start in seq(1, nrow(dataset)-2*window.length+1, by=by)) {
		cat("nrow: ", nrow(dataset), " Window start ", window.start, " predicting to ", (window.start+2*window.length-1),"\n")
		two.windows = dataset[window.start:(window.start+2*window.length-1),]
		result = dwnn.recursive(two.windows, time.delay=d, train.from=1, train.to=window.length)
		divergence = c(divergence, sum((result$original.dataset[,m] - result$predicted.dataset[,m])^2))
	}

	return (divergence)
}

#### TESTING ####
require(tseriesChaos)
test.sin <- function(sigma=0.5) {
	series = sin(2*pi*seq(0,9,len=1000))
	dataset = embedd(series, m=3, d=10)
	result = dwnn.recursive(dataset, time.delay=10, sigma=sigma)

	plot(result$original.dataset[,3])
	lines(result$predicted.dataset[,3], col=2)
}

#### DATASETS ####
experiment1 <- function(sigma=0.2104335, m=3, d=10, window.length=250, by=1) {

	series = c(sin(2*pi*seq(0,9,len=1000)), sin(3*pi*seq(0,9,len=1000)), 1.5*sin(3*pi*seq(0,9,len=1000)))

	div = concept.drift(series, m=m, d=d, window.length=window.length, by=by)
	div = c(rep(NA, floor(length(series)-length(div))/2), div, rep(NA, floor(length(series)-length(div))/2))

	pdf("experiment1.pdf")
	par(mfrow=c(2,1))
	plot(series, xlab="Time", ylab="Observation values", main="(a) Data stream")
	plot(div, xlab="Time", ylab="Squared-error values", main="(b) Prediction error")
	dev.off()

	ret = list()
	ret$series = series
	ret$div = div

	return (ret)
}

experiment2 <- function(sigma=0.00483608, m=2, d=1, window.length=250, by=1) {

	series = c()
	x = 0.5
	for (r in seq(2.5,4,len=2000)) {
		series = c(series, x)
		x = r*x*(1-x)
	}

	div = concept.drift(series, m=m, d=d, window.length=window.length, by=by)
	div = c(rep(NA, floor(length(series)-length(div))/2), div, rep(NA, floor(length(series)-length(div))/2))

	pdf("experiment2.pdf")
	par(mfrow=c(2,1))
	plot(series, xlab="Time", ylab="Observation values", main="(a) Data stream")
	plot(div, xlab="Time", ylab="Squared-error values", main="(b) Prediction error")
	dev.off()

	ret = list()
	ret$series = series
	ret$div = div

	return (ret)
}

experiment3 <- function(sigma=12.35516, m=3, d=10, window.length=250, by=1) {

	series = sunspot.month
	div = concept.drift(series, m=m, d=d, window.length=window.length, by=by)
	div = c(rep(NA, floor(length(series)-length(div))/2), div, rep(NA, floor(length(series)-length(div))/2))

	pdf("experiment3.pdf")
	par(mfrow=c(2,1))
	plot(series, xlab="Year", ylab="Observation values", main="(a) Data stream")
	plot(div, xlab="Time", ylab="Squared-error values", main="(b) Prediction error")
	dev.off()

	ret = list()
	ret$series = series
	ret$div = div

	return (ret)
}

experiment4 <- function(sigma=49.92655, m=3, d=1, window.length=250, by=1) {

	data = read.csv("SP500TR.csv")
	range = 4000:7566
	date = format(as.Date(data[range,1]), "%m-%Y")
	series  = data[range,6]

	div = concept.drift(series, m=m, d=d, window.length=window.length, by=by)
	div = c(rep(NA, floor(length(series)-length(div))/2), div, rep(NA, floor(length(series)-length(div))/2))

	pdf("experiment4.pdf")
	par(mfrow=c(2,1))
	seq = floor(seq(1, length(series), len = 8))
	plot(series, xlab="Month-Year", ylab="Observation values", main="(a) Data stream", xaxt="n")
	axis(1, at= seq, labels = date[seq])
	plot(div, xlab="Time", ylab="Squared-error values", main="(b) Prediction error")
	dev.off()

	ret = list()
	ret$series = series
	ret$div = div

	return (ret)
}

experiment5 <- function(sigma=0.1111036, m=3, d=1, window.length=250, by=1) {

	# http://berkeleyearth.lbl.gov/auto/Global/Land_and_Ocean_complete.txt
	data = read.table("Land_and_Ocean_complete.txt")
	tmpDate = data[,1:2]
	date = 0
	for (i in 1:nrow(tmpDate))
	  date[i] = sprintf("%d-%d", tmpDate[i, 2], tmpDate[i, 1])
	series  = data[,3]

	div = concept.drift(series, m=m, d=d, window.length=window.length, by=by)
	div = c(rep(NA, floor(length(series)-length(div))/2), div, rep(NA, floor(length(series)-length(div))/2))

	pdf("experiment5.pdf")
	par(mfrow=c(2,1))
	seq = floor(seq(1, length(series), len = 8))
	plot(series, xlab="Month-Year", ylab="Observation values", main="(a) Data stream", xaxt="n")
  axis(1, at=seq, labels = date[seq])
	plot(div, xlab="Time", ylab="Squared-error values", main="(b) Prediction error")
	dev.off()

	ret = list()
	ret$series = series
	ret$div = div

	return (ret)
}


#probability theory: A concise course by Y.A. Rozanov

#Chapter 1:

#1
1/factorial(4)

#2
# 1 cube with all sides painted cut into 1000 cubes. 10 * 10 * 10 = 1000,
# so each of the three axixs(axes?) is cut into ten pieces
# each cube can have 0,1,2,3 faces painted,
# 6 cubes have 3 painted faces - 6 corners
# 96 cubes have 2 painted faces - 3 axes * 8 cubes left on each edge after removing the corners * four sides of each face (faces are squares)
# 384 cubes have 1 painted face - 6 sides * 8^2  cubes left on each side after removing cubes with > 1 side painted
# 514 cubes have 0 painted faces - 1000 cubes - 384 - 96 - 6 (cubes with >=1 faces painted)
96/1000

#5
#pr(hit)
a <- 0.8
b <- 0.7
#pr(neither a nor b hit)
a2 <- 1-a
b2 <- 1-b
cat(b2*a2)
#ans
1-(b2*a2)

#7
# 4 threes, 4 sevens, 4 aces
# (a, b, c)

# total number of ways to choose 3 cards
N <- choose(52,3)
# number of ways to chose three seven and ace
n <- 4^3
# N(a)/N
n/N

#14
stirling <- function(n){
	return(sqrt(2*pi*n) * ((n^n) / exp(n)))
}
chooseWIthStirling <- function(n, k) {
	num <- stirling(n)
	den <- stirling(k) * stirling(n - k)
	return(num/den)
}
chooseWIthStirling(26,13)^2 / chooseWIthStirling(52,26)

# 15
n <- 2^50
N <- chooseWIthStirling(100,50)
n/N