# Binomial logistic regression with moderation simulation code

# Raymond Viviano
# rayviviano@gmail.com
# March 27th, 2020

# TODO: Implement checks to make sure that all models converge

library(ggplot2)

########################### User Definition Section ############################

# Specify Intercept and Beta Terms
B0 <- logit(0.1) # Intercept.
B1 <- .2         # Variable 1 Beta
B2 <- .1         # Variable 2 Beta
B3.Odds.Seq <- seq(1.05, 2.55, by=.1) # Loop through ORs for interaction term

# Ensure reproducible results
set.seed(10000)

# Define sample size
n <- 16000

# Define number of simulations per B3 Odds Ratio
nsims <- 100

######################## End of User Definition Section ########################

############################# Function Definitions #############################

#' Logit function
logit <- function(p){
    return(log(as.double(p)/(1.0-as.double(p))))
}

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

#' Coverage Probability, i.e., the probability that the confidence interval (ci)
#' for a parameter will contain the true value
#' Inputs:
#'          b       - Estimate
#'          se      - Standard Error of the Estimate
#'          true    - True value of parameter for data-generating process
#'          cl      - Confidence level
#'          dof     - Degrees of Freedom
#' Output:
#'          List containing coverage probability, vect
coverage.prob <- function(b, se, true, cl=.95, dof=Inf){
    # Compute quantile based on confidence level
    coverage.quantile <- cl + (1-cl)/2

    # Compute confidence interval upper and lower bounds
    ci.lower <- b - qt(coverage.quantile, df=dof)*se
    ci.upper <- b + qt(coverage.quantile, df=dof)*se

    # For each ci generated for each b/se pair, eval if true param is in ci
    ci.contain.true <- ifelse(true>=ci.lower & true<=ci.upper, 1, 0)

    # Calculate coverage probability
    cp <- mean(ci.contain.true)

    # Calculate Monte Carlo Error
    mc.err.lower <- cp - 1.96*sqrt((cp*(1-cp))/length(b))
    mc.err.upper <- cp + 1.96*sqrt((cp*(1-cp))/length(b))

    # Return coverage probability and error
    return(list(cp=cp, ci=cbind(mc.err.lower, mc.err.upper)))
}

#' Power to detect any effect at various alpha levels
#' Takes a vector of p-values and calculates the proportion of models where the
#' p-val for the effect of interest was < .5, .01, and .001.
power.detect.effect <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    prop.05 <- sum(less.than.05)/length(less.than.05)

    less.than.01 <- ifelse(p.val.vec < .01, 1, 0)
    prop.01 <- sum(less.than.01)/length(less.than.01)

    less.than.001 <- ifelse(p.val.vec < .001, 1, 0)
    prop.001 <- sum(less.than.001)/length(less.than.001)

    cat(paste0('Power to detect effect at .05: ', prop.05, '\n'))
    cat(paste0('Power to detect effect at .01: ', prop.01, '\n'))
    cat(paste0('Power to detect effect at .001: ', prop.001, '\n'))
}

#' Power to detect effect at .05 level based on simulations
power.at.05 <- function(p.val.vec){
    less.than.05 <- ifelse(p.val.vec < .05, 1, 0)
    return(sum(less.than.05)/length(less.than.05))
}

#' plotLines
#'
#' Lineplots comparing continuous variable scores across levels of another var
#'
#' Inputs:
#'     df:       Dataframe with vars of interest.
#'     title:    Title above chart
#'     outDir:   Directory to save plot to
plotLines <- function(df, title, outDir){
    # Create plot
    p <- ggplot(data=df, aes(x=B3.Odds.Seq, y=B3.Powr.Seq))

    # Add lines for each group
    p <- p + geom_line(stat='identity', size=.85, alpha=0.9)

    # Unique shape for each group placed at each data point
    p <- p + geom_point(size=2.5, alpha=.45)

    # Pad the distance between the x-axis and smallest plotted value slightly
    p <- p + scale_y_continuous(limits=c(0,1))

    # Pad/add extra space to the ends of the x-axis
    p <- p + scale_x_continuous(expand=c(0.05, 0.05))

    # Remove gray background, format x-axis text, format legend
    p <- p + theme(panel.grid.major=element_blank(),
                   panel.grid.minor=element_blank(),
                   panel.background=element_blank(),
                   axis.line=element_line(colour="black"),
                   axis.text.x=element_text(angle=0, size=14),
                   axis.text.y=element_text(angle=0, size=14),
                   legend.key=element_rect(color=NA, fill=NA),
                   legend.background=element_blank(),
                   legend.key.width=unit(3, "line"),
                   legend.justification=c(1, 1),
                   legend.position=c(.2, 1))

    # Add axis labels
    p <- p + labs(y='Proportion of Simulations with Significant Interaction Term at p < .05',
                  x='Odds Ratio of the Interaction')

    # Remove any components to the legend that could relate to alpha or size
    p <- p + scale_alpha(guide='none')
    p <- p + scale_size(guide='none')

    # Add a title to the plot
    p <- p + ggtitle(title)

    # Save Plots
    pngOut <- paste(outDir, "/moderatedLogitInteractionPower.png", sep="")
    svgOut <- paste(outDir, "/moderatedLogitInteractionPower.svg", sep="")

    ggsave(pngOut, p)
    ggsave(svgOut, p)
}

# Check power at varying values for B3 (Interaction Beta)
B3.Powr.Seq <- rep(0, length(B3.Odds.Seq)) # Hold power for ORs, init all to 0

for(j in 1:length(B3.Odds.Seq)){
    # Take the natural log of the expected odds ratio to get interaction beta
    B3.Odds.Ratio <- B3.Odds.Seq[j]
    B3 <- log(B3.Odds.Ratio)

    # Define matrix to hold simulation data (estimates, std.errors, and pvals)
    sim.prms <- matrix(NA, nrow=nsims, ncol=12)

    # Print statements to track script progress
    cat(paste0("Calculating power for B3 = ", round(B3,2), ", exp(", round(B3,2),
               ") = Odds Ratio of ", B3.Odds.Ratio, "\n\nIteration: "))

    # Loop through simulations
    for(i in 1:nsims){
        # Print statements to observe progress
        if ((i-1)%%10==0){
            cat(paste0(i,", "))
        }

        # Generate independant variable data, uniform random between -1 and 1
        x <- runif(n, -1, 1)

        # Generate normal dist data for the moderating variable
        m <- rnorm(n, 0, 1)

        # Element-wise multiply x and m for interaction
        xm <- x*m

        # Data-generation-process for Bernoulli trials
        y <- rbinom(n, 1, inv.logit(B0 + B1*x + B2*m + B3*xm))

        # Estimate logit model
        model <- glm(y ~ x + m + xm, family=binomial(link=logit))

        # TODO: Implement checks to make sure that models converge

        # Put model paramters in simulation matrix
        sim.prms[i, 1] <- model$coef[1]                       # Estimate for B0
        sim.prms[i, 2] <- model$coef[2]                       # Estimate for B1
        sim.prms[i, 3] <- model$coef[3]                       # Estimate for B2
        sim.prms[i, 4] <- model$coef[4]                       # Estimate for B3
        sim.prms[i, 5] <- summary(model)$coefficients[,2][1]  # StdError for B0
        sim.prms[i, 6] <- summary(model)$coefficients[,2][2]  # StdError for B1
        sim.prms[i, 7] <- summary(model)$coefficients[,2][3]  # StdError for B2
        sim.prms[i, 8] <- summary(model)$coefficients[,2][4]  # StdError for B3
        sim.prms[i, 9] <- summary(model)$coefficients[,4][1]  # P-Value for B0
        sim.prms[i,10] <- summary(model)$coefficients[,4][2]  # P-Value for B1
        sim.prms[i,11] <- summary(model)$coefficients[,4][3]  # P-Value for B2
        sim.prms[i,12] <- summary(model)$coefficients[,4][4]  # P-Value for B3

    }

    # Newline for prettier prints
    cat("\n")

    # Get Covarage probabilities for the interaction
    B3.coverage <- coverage.prob(sim.prms[,4], sim.prms[,8], B3, .95, n-model$rank)

    # Intercept coverage probabilities
    cat("Coverage Probability for B3 (Interaction Beta)\n")
    cat(paste0(B3.coverage$cp, " [", B3.coverage$ci[1,1], ",",
               B3.coverage$ci[1,2], "]\n"))

    # Power to detect moderation
    print("Power to detect interaction term:")
    power.detect.effect(sim.prms[,12])

    # Update B3.Powr.Seq
    B3.Powr.Seq[j] <- power.at.05(sim.prms[,12])

    # Newline for prettier prints
    cat("\n")
}

# Create dataframe for plotting power at various B3s
df.plot <- data.frame(B3.Odds.Seq, B3.Powr.Seq)

# Plot Power Analysis
plotLines(df.plot, 'Moderated Logistic Regression Power', './')


#######################
## Section 6, Part 2 ##
#######################

#install.packages("mlogit")
#install.packages("randtoolbox")

library(mlogit)
library(randtoolbox)
library(MASS)

setwd("C:\\dc_book\\Replication_Files_Element")

cb.data <- read.csv("cb_data.csv")

cb.data <- mlogit.data(cb.data, choice="choice", shape="long", chid.var="choiceid", alt.var="region", id.var="id")

###############
## Table 6.5 ##
###############

cb.data$n.travelcost <- cb.data$travelcost * -1

cosco.busan.mxl <- mlogit(choice ~ n.travelcost + bridge + marin + eastbay + bayshore + peninsula | 0, data=cb.data, rpar=c(n.travelcost="ln", bridge="n", marin="n", eastbay="n", bayshore="n", peninsula="n"), panel=TRUE, R=500, halton=NA)
cosco.busan.mxl.results <- cbind(cosco.busan.mxl$coefficients, sqrt(diag(vcov(cosco.busan.mxl))), confint.default(cosco.busan.mxl, level=0.95))
N <- length(unique(cb.data$id))
C <- length(unique(cb.data$choiceid))
A <- nrow(cb.data)
colnames(cosco.busan.mxl.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(cosco.busan.mxl.results, digits=3)))  # interpret negative standard deviations as if they were positive
print(N)
print(C)
print(A)

###############
## Table 6.6 ##
###############

coeffs <- cosco.busan.mxl$coefficients
covmat <- vcov(cosco.busan.mxl)
ndraws <- 1000

betadraw <- mvrnorm(ndraws, coeffs, covmat)
R <- 500
halton.seq <- qnorm(halton(R, dim=6))

## observed

observed.x <- with(cb.data, data.frame(
travelcost = travelcost,
bridge = bridge,
marin = marin,
eastbay = eastbay,
bayshore = bayshore,
peninsula = peninsula,
id = idx,
weights = wts
))

id.weights <- observed.x$weights[observed.x$id.alt==1]

shares <- matrix(0, ndraws, 15)

marin.o <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==1)))
eastbay.o <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==2)))
bayshore.o <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==3)))
peninsula.o <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==4)))
notrip.o <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==5)))
marin.c <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==1)))
eastbay.c <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==2)))
bayshore.c <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==3)))
peninsula.c <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==4)))
notrip.c <- matrix(0, ndraws, nrow(subset(observed.x, id.alt==5)))

for (i in 1:R) {

	travelcost <- -1 * exp(betadraw[,"n.travelcost"] + (halton.seq[i,1] * abs(betadraw[,"sd.n.travelcost"])))
	bridge <- betadraw[,"bridge"] + (halton.seq[i,2] * abs(betadraw[,"sd.bridge"]))
	marin <- betadraw[,"marin"] + (halton.seq[i,3] * abs(betadraw[,"sd.marin"]))
	eastbay <- betadraw[,"eastbay"] + (halton.seq[i,4] * abs(betadraw[,"sd.eastbay"]))
	bayshore <- betadraw[,"bayshore"] + (halton.seq[i,5] * abs(betadraw[,"sd.bayshore"]))
	peninsula <- betadraw[,"peninsula"] + (halton.seq[i,6] * abs(betadraw[,"sd.peninsula"]))

	beta.R <- cbind(travelcost, bridge, marin, eastbay, bayshore, peninsula)

	exb.region1.o <- exp(beta.R %*% t(subset(observed.x, id.alt==1, select=c(1:6))))
	exb.region2.o <- exp(beta.R %*% t(subset(observed.x, id.alt==2, select=c(1:6))))
	exb.region3.o <- exp(beta.R %*% t(subset(observed.x, id.alt==3, select=c(1:6))))
	exb.region4.o <- exp(beta.R %*% t(subset(observed.x, id.alt==4, select=c(1:6))))
	exb.region5.o <- exp(beta.R %*% t(subset(observed.x, id.alt==5, select=c(1:6))))
	exb.all.o <- exb.region1.o + exb.region2.o + exb.region3.o + exb.region4.o + exb.region5.o

	probs.region1.o <- exb.region1.o/exb.all.o
	probs.region2.o <- exb.region2.o/exb.all.o
	probs.region3.o <- exb.region3.o/exb.all.o
	probs.region4.o <- exb.region4.o/exb.all.o
	probs.region5.o <- exb.region5.o/exb.all.o

	marin.o <- marin.o + (probs.region1.o * (1/R))
	eastbay.o <- eastbay.o + (probs.region2.o * (1/R))
	bayshore.o <- bayshore.o + (probs.region3.o * (1/R))
	peninsula.o <- peninsula.o + (probs.region4.o * (1/R))
	notrip.o <- notrip.o + (probs.region5.o * (1/R))

	# counterfactual -- set alternative specific constant to drive probability of East Bay to zero

	beta.R.c <- beta.R
	beta.R.c[,"eastbay"] <- -25

	exb.region1.c <- exp(beta.R.c %*% t(subset(observed.x, id.alt==1, select=c(1:6))))
	exb.region2.c <- exp(beta.R.c %*% t(subset(observed.x, id.alt==2, select=c(1:6))))
	exb.region3.c <- exp(beta.R.c %*% t(subset(observed.x, id.alt==3, select=c(1:6))))
	exb.region4.c <- exp(beta.R.c %*% t(subset(observed.x, id.alt==4, select=c(1:6))))
	exb.region5.c <- exp(beta.R.c %*% t(subset(observed.x, id.alt==5, select=c(1:6))))
	exb.all.c <- exb.region1.c + exb.region2.c + exb.region3.c + exb.region4.c + exb.region5.c

	probs.region1.c <- exb.region1.c/exb.all.c
	probs.region2.c <- exb.region2.c/exb.all.c
	probs.region3.c <- exb.region3.c/exb.all.c
	probs.region4.c <- exb.region4.c/exb.all.c
	probs.region5.c <- exb.region5.c/exb.all.c

	marin.c <- marin.c + (probs.region1.c * (1/R))
	eastbay.c <- eastbay.c + (probs.region2.c * (1/R))
	bayshore.c <- bayshore.c + (probs.region3.c * (1/R))
	peninsula.c <- peninsula.c + (probs.region4.c * (1/R))
	notrip.c <- notrip.c + (probs.region5.c * (1/R))

}

# apply sample enumeration

marin.so <- (colSums(apply(marin.o, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
eastbay.so <- (colSums(apply(eastbay.o, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
bayshore.so <- (colSums(apply(bayshore.o, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
peninsula.so <- (colSums(apply(peninsula.o, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
notrip.so <- (colSums(apply(notrip.o, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100

marin.sc <- (colSums(apply(marin.c, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
eastbay.sc <- (colSums(apply(eastbay.c, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
bayshore.sc <- (colSums(apply(bayshore.c, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
peninsula.sc <- (colSums(apply(peninsula.c, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100
notrip.sc <- (colSums(apply(notrip.c, 1, function(x) {x * id.weights}))/sum(id.weights)) * 100

marin.s.diff <- marin.sc - marin.so
eastbay.s.diff <- eastbay.sc - eastbay.so
bayshore.s.diff <- bayshore.sc - bayshore.so
peninsula.s.diff <- peninsula.sc - peninsula.so
notrip.s.diff <- notrip.sc - notrip.so

shares[,1] <- marin.so
shares[,2] <- eastbay.so
shares[,3] <- bayshore.so
shares[,4] <- peninsula.so
shares[,5] <- notrip.so
shares[,6] <- marin.sc
shares[,7] <- eastbay.sc
shares[,8] <- bayshore.sc
shares[,9] <- peninsula.sc
shares[,10] <- notrip.sc
shares[,11] <- marin.s.diff
shares[,12] <- eastbay.s.diff
shares[,13] <- bayshore.s.diff
shares[,14] <- peninsula.s.diff
shares[,15] <- notrip.s.diff

quantiles <- apply(shares, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(shares, 2, sd)
first.differences <- cbind(t(quantiles), sds)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("Baseline: Marin", "Baseline: East Bay", "Baseline: Bayshore", "Baseline: Peninsula", "Baseline: No Trip", "Counterfactual: Marin", "Counterfactual: East Bay", "Counterfactual: Bayshore", "Counterfactual: Peninsula", "Counterfactual: No Trip", "Difference: Marin", "Difference: East Bay", "Difference: Bayshore", "Difference: Peninsula", "Difference: No Trip")
print(round(first.differences, digits=3))

###############
## Table 6.7 ##
###############

coeffs <- cosco.busan.mxl$coefficients
covmat <- vcov(cosco.busan.mxl)
ndraws <- 1000

betadraw <- mvrnorm(ndraws, coeffs, covmat)
R <- 500
halton.seq <- qnorm(halton(R, dim=6))

## observed

observed.x <- with(cb.data, data.frame(
travelcost = travelcost,
bridge = bridge,
marin = marin,
eastbay = eastbay,
bayshore = bayshore,
peninsula = peninsula,
id = idx,
weights = wts
))

id.weights <- observed.x$weights[observed.x$id.alt==1]

me.MEM.travelcost <- matrix(0, nrow(betadraw), 1)
cme.MEM.travelcost21 <- matrix(0, nrow(betadraw), 1)
cme.MEM.travelcost23 <- matrix(0, nrow(betadraw), 1)
cme.MEM.travelcost24 <- matrix(0, nrow(betadraw), 1)
cme.MEM.travelcost25 <- matrix(0, nrow(betadraw), 1)

me.AME.travelcost.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==4,]))
cme.AME.travelcost21.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==1,]))
cme.AME.travelcost23.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==2,]))
cme.AME.travelcost24.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==3,]))
cme.AME.travelcost25.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==5,]))

probs.region1.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==1,]))
probs.region2.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==2,]))
probs.region3.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==3,]))
probs.region4.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==4,]))
probs.region5.all <- matrix(0, nrow(betadraw), nrow(observed.x[observed.x$id.alt==5,]))

probs.region1.all.m <- matrix(0, nrow(betadraw), 1)
probs.region2.all.m <- matrix(0, nrow(betadraw), 1)
probs.region3.all.m <- matrix(0, nrow(betadraw), 1)
probs.region4.all.m <- matrix(0, nrow(betadraw), 1)
probs.region5.all.m <- matrix(0, nrow(betadraw), 1)

for (i in 1:R) {

	travelcost <- -1 * exp(betadraw[,"n.travelcost"] + (halton.seq[i,1] * abs(betadraw[,"sd.n.travelcost"])))
	bridge <- betadraw[,"bridge"] + (halton.seq[i,2] * abs(betadraw[,"sd.bridge"]))
	marin <- betadraw[,"marin"] + (halton.seq[i,3] * abs(betadraw[,"sd.marin"]))
	eastbay <- betadraw[,"eastbay"] + (halton.seq[i,4] * abs(betadraw[,"sd.eastbay"]))
	bayshore <- betadraw[,"bayshore"] + (halton.seq[i,5] * abs(betadraw[,"sd.bayshore"]))
	peninsula <- betadraw[,"peninsula"] + (halton.seq[i,6] * abs(betadraw[,"sd.peninsula"]))

	beta.R <- cbind(travelcost, bridge, marin, eastbay, bayshore, peninsula)

	# MEM

	exb.region1.m <- exp(beta.R %*% colMeans(subset(observed.x, id.alt==1, select=c(1:6))))
	exb.region2.m <- exp(beta.R %*% colMeans(subset(observed.x, id.alt==2, select=c(1:6))))
	exb.region3.m <- exp(beta.R %*% colMeans(subset(observed.x, id.alt==3, select=c(1:6))))
	exb.region4.m <- exp(beta.R %*% colMeans(subset(observed.x, id.alt==4, select=c(1:6))))
	exb.region5.m <- exp(beta.R %*% colMeans(subset(observed.x, id.alt==5, select=c(1:6))))
	exb.all.m <- exb.region1.m + exb.region2.m + exb.region3.m + exb.region4.m + exb.region5.m

	probs.region1.m <- exb.region1.m/exb.all.m
	probs.region2.m <- exb.region2.m/exb.all.m
	probs.region3.m <- exb.region3.m/exb.all.m
	probs.region4.m <- exb.region4.m/exb.all.m
	probs.region5.m <- exb.region5.m/exb.all.m

	probs.region1.all.m <- probs.region1.all.m + (probs.region1.m * (1/R))
	probs.region2.all.m <- probs.region2.all.m + (probs.region2.m * (1/R))
	probs.region3.all.m <- probs.region3.all.m + (probs.region3.m * (1/R))
	probs.region4.all.m <- probs.region4.all.m + (probs.region4.m * (1/R))
	probs.region5.all.m <- probs.region5.all.m + (probs.region5.m * (1/R))

	## marginal effects for East Bay
	me.MEM.travelcost <- me.MEM.travelcost + (travelcost * (probs.region2.m * (1 - probs.region2.m)) * (1/R))

	## cross-marginal effects
	cme.MEM.travelcost21 <- cme.MEM.travelcost21 + ((-1 * travelcost * (probs.region1.m * probs.region2.m)) * (1/R))
	cme.MEM.travelcost23 <- cme.MEM.travelcost23 + ((-1 * travelcost * (probs.region3.m * probs.region2.m)) * (1/R))
	cme.MEM.travelcost24 <- cme.MEM.travelcost24 + ((-1 * travelcost * (probs.region4.m * probs.region2.m)) * (1/R))
	cme.MEM.travelcost25 <- cme.MEM.travelcost25 + ((-1 * travelcost * (probs.region5.m * probs.region2.m)) * (1/R))

	# AME

	exb.region1 <- exp(beta.R %*% t(subset(observed.x, id.alt==1, select=c(1:6))))
	exb.region2 <- exp(beta.R %*% t(subset(observed.x, id.alt==2, select=c(1:6))))
	exb.region3 <- exp(beta.R %*% t(subset(observed.x, id.alt==3, select=c(1:6))))
	exb.region4 <- exp(beta.R %*% t(subset(observed.x, id.alt==4, select=c(1:6))))
	exb.region5 <- exp(beta.R %*% t(subset(observed.x, id.alt==5, select=c(1:6))))
	exb.all <- exb.region1 + exb.region2 + exb.region3 + exb.region4 + exb.region5

	probs.region1 <- exb.region1/exb.all
	probs.region2 <- exb.region2/exb.all
	probs.region3 <- exb.region3/exb.all
	probs.region4 <- exb.region4/exb.all
	probs.region5 <- exb.region5/exb.all

	probs.region1.all <- probs.region1.all + (probs.region1 * (1/R))
	probs.region2.all <- probs.region2.all + (probs.region2 * (1/R))
	probs.region3.all <- probs.region3.all + (probs.region3 * (1/R))
	probs.region4.all <- probs.region4.all + (probs.region4 * (1/R))
	probs.region5.all <- probs.region5.all + (probs.region5 * (1/R))

	## marginal effects for Bayshore
	me.AME.travelcost.all <- me.AME.travelcost.all + ((travelcost * (probs.region2 * (1 - probs.region2))) * (1/R))

	## cross-marginal effects
	cme.AME.travelcost21.all <- cme.AME.travelcost21.all + ((-1 * travelcost * (probs.region1 * probs.region2)) * (1/R))
	cme.AME.travelcost23.all <- cme.AME.travelcost23.all + ((-1 * travelcost * (probs.region3 * probs.region2)) * (1/R))
	cme.AME.travelcost24.all <- cme.AME.travelcost24.all + ((-1 * travelcost * (probs.region4 * probs.region2)) * (1/R))
	cme.AME.travelcost25.all <- cme.AME.travelcost25.all + ((-1 * travelcost * (probs.region5 * probs.region2)) * (1/R))

}

me.AME.travelcost <- colSums(apply(me.AME.travelcost.all, 1, function(x) {x * id.weights}))/sum(id.weights)
cme.AME.travelcost21 <- colSums(apply(cme.AME.travelcost21.all, 1, function(x) {x * id.weights}))/sum(id.weights)
cme.AME.travelcost23 <- colSums(apply(cme.AME.travelcost23.all, 1, function(x) {x * id.weights}))/sum(id.weights)
cme.AME.travelcost24 <- colSums(apply(cme.AME.travelcost24.all, 1, function(x) {x * id.weights}))/sum(id.weights)
cme.AME.travelcost25 <- colSums(apply(cme.AME.travelcost25.all, 1, function(x) {x * id.weights}))/sum(id.weights)

## Elasticities

travelcost.2 <- observed.x[observed.x$id.alt==2, grep("travelcost", colnames(observed.x))]
travelcost.2.m <- mean(observed.x[observed.x$id.alt==2, grep("travelcost", colnames(observed.x))])

## elasticities for East Bay -- MEM
e.MEM.travelcost <- me.MEM.travelcost * (travelcost.2.m / probs.region2.all.m)

## elasticities for East Bay -- AME
e.travelcost <- me.AME.travelcost.all * t(travelcost.2 / t(probs.region2.all))
e.AME.travelcost <- colSums(apply(e.travelcost, 1, function(x) {x * id.weights}))/sum(id.weights)

## cross-elasticities -- MEM
ce.MEM.travelcost21 <- cme.MEM.travelcost21 * (travelcost.2.m/probs.region1.all.m)
ce.MEM.travelcost23 <- cme.MEM.travelcost23 * (travelcost.2.m/probs.region3.all.m)
ce.MEM.travelcost24 <- cme.MEM.travelcost24 * (travelcost.2.m/probs.region4.all.m)
ce.MEM.travelcost25 <- cme.MEM.travelcost25 * (travelcost.2.m/probs.region5.all.m)

## cross-elasticities -- AME
ce.travelcost21 <- cme.AME.travelcost21.all * t(apply(probs.region1.all, 1, function(x){travelcost.2/x}))
ce.travelcost23 <- cme.AME.travelcost23.all * t(apply(probs.region3.all, 1, function(x){travelcost.2/x}))
ce.travelcost24 <- cme.AME.travelcost24.all * t(apply(probs.region4.all, 1, function(x){travelcost.2/x}))
ce.travelcost25 <- cme.AME.travelcost25.all * t(apply(probs.region5.all, 1, function(x){travelcost.2/x}))

ce.AME.travelcost21 <- colSums(apply(ce.travelcost21, 1, function(x) {x * id.weights}))/sum(id.weights)
ce.AME.travelcost23 <- colSums(apply(ce.travelcost23, 1, function(x) {x * id.weights}))/sum(id.weights)
ce.AME.travelcost24 <- colSums(apply(ce.travelcost24, 1, function(x) {x * id.weights}))/sum(id.weights)
ce.AME.travelcost25 <- colSums(apply(ce.travelcost25, 1, function(x) {x * id.weights}))/sum(id.weights)

# note marginal effects are multiplied by 100 for ease of interpretation
margins <- cbind(
me.AME.travelcost, me.MEM.travelcost,
cme.AME.travelcost21, cme.AME.travelcost23, cme.AME.travelcost24, cme.AME.travelcost25,
cme.MEM.travelcost21, cme.MEM.travelcost23, cme.MEM.travelcost24, cme.MEM.travelcost25
) * 100

elasticities <- cbind(
e.AME.travelcost, e.MEM.travelcost,
ce.AME.travelcost21, ce.AME.travelcost23, ce.AME.travelcost24, ce.AME.travelcost25,
ce.MEM.travelcost21, ce.MEM.travelcost23, ce.MEM.travelcost24, ce.MEM.travelcost25
)

all.results <- cbind(margins, elasticities)

quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
marginal.effects <- cbind(t(quantiles), sds)
colnames(marginal.effects) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(marginal.effects) <- c("East Bay: AME", "East Bay: MEM", "Marin: Average CME", "Bayshore: Average CME", "Peninsula: Average CME", "No Trip: Average CME", "Marin: CME at Mean", "Bayshore: CME at Mean", "Peninsula: CME at Mean", "No Trip: CME at Mean", "East Bay: Average Elasticity", "East Bay: Elasticity at the Mean", "Marin: Average CE", "Bayshore: Average CE", "Peninsula: Average CE", "No Trip: Average CE", "Marin: CE at Mean", "Bayshore: CE at Mean", "Peninsula: CE at Mean", "No Trip: CE at Mean")
print(round(marginal.effects, digits=3))

## WTP calculation ##

wtp.summary <- matrix(NA, ndraws, 2)

for (i in 1:ndraws) {

	travelcost <- -1 * exp(betadraw[i,"n.travelcost"] + (halton.seq[,1] * abs(betadraw[i,"sd.n.travelcost"])))
	bridge <- betadraw[i,"bridge"] + (halton.seq[,2] * abs(betadraw[i,"sd.bridge"]))

	all.bridge <- expand.grid(bridge, travelcost)
	wtp.bridge <- all.bridge[,1]/(-1 * all.bridge[,2])
	wtp.summary[i,1] <- median(wtp.bridge)
	wtp.summary[i,2] <- mean(wtp.bridge)

}

quantiles <- apply(wtp.summary, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(wtp.summary, 2, sd)
wtp.all <- cbind(t(quantiles), sds)
colnames(wtp.all ) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(wtp.all ) <- c("Median WTP", "Mean WTP")
print(round(wtp.all , digits=3))

###############
## Table 6.8 ##
###############

coeffs <- cosco.busan.mxl$coefficients
covmat <- vcov(cosco.busan.mxl)
ndraws <- 1000

betadraw <- mvrnorm(ndraws, coeffs, covmat)
intdraws <- 500
halton.seq <- qnorm(halton(intdraws, dim=6))

## observed

observed.x <- with(cb.data, data.frame(
travelcost = travelcost,
bridge = bridge,
marin = marin,
eastbay = eastbay,
bayshore = bayshore,
peninsula = peninsula,
id = idx,
weights = wts
))

p.01 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.02 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.03 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.04 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.05 <- matrix(0, nrow(betadraw), nrow(observed.x))

p.tr1 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.tr2 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.tr3 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.tr4 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.tr5 <- matrix(0, nrow(betadraw), nrow(observed.x))

p.b1 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.b2 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.b3 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.b4 <- matrix(0, nrow(betadraw), nrow(observed.x))
p.b5 <- matrix(0, nrow(betadraw), nrow(observed.x))

# travelcost
observed.x.tr <- observed.x
observed.x.tr[,"travelcost"][observed.x.tr[,"id.alt"] != 5] <- observed.x.tr[,"travelcost"][observed.x.tr[,"id.alt"] != 5] + 1

# bridge
observed.x.b <- observed.x
observed.x.b[,"bridge"][observed.x.b["id.alt"] != 5] <- observed.x.b["bridge"][observed.x.b["id.alt"] != 5]  + 1

for (i in 1:ndraws){

	travelcost <- -1 * exp(betadraw[i,"n.travelcost"] + (halton.seq[,1] * abs(betadraw[i,"sd.n.travelcost"])))
	bridge <- betadraw[i,"bridge"] + (halton.seq[,2] * abs(betadraw[i,"sd.bridge"]))
	marin <- betadraw[i,"marin"] + (halton.seq[,3] * abs(betadraw[i,"sd.marin"]))
	eastbay <- betadraw[i,"eastbay"] + (halton.seq[,4] * abs(betadraw[i,"sd.eastbay"]))
	bayshore <- betadraw[i,"bayshore"] + (halton.seq[,5] * abs(betadraw[i,"sd.bayshore"]))
	peninsula <- betadraw[i,"peninsula"] + (halton.seq[,6] * abs(betadraw[i,"sd.peninsula"]))

	beta.R <- cbind(travelcost, bridge, marin, eastbay, bayshore, peninsula)

	exb.region1.0 <- exp(beta.R %*% t(subset(observed.x, id.alt==1, select=c(1:6))))
	exb.region2.0 <- exp(beta.R %*% t(subset(observed.x, id.alt==2, select=c(1:6))))
	exb.region3.0 <- exp(beta.R %*% t(subset(observed.x, id.alt==3, select=c(1:6))))
	exb.region4.0 <- exp(beta.R %*% t(subset(observed.x, id.alt==4, select=c(1:6))))
	exb.region5.0 <- exp(beta.R %*% t(subset(observed.x, id.alt==5, select=c(1:6))))
	exb.all.0 <- exb.region1.0 + exb.region2.0 + exb.region3.0 + exb.region4.0 + exb.region5.0

	p.01[i,] <- colMeans(exb.region1.0/exb.all.0)
	p.02[i,] <- colMeans(exb.region2.0/exb.all.0)
	p.03[i,] <- colMeans(exb.region3.0/exb.all.0)
	p.04[i,] <- colMeans(exb.region4.0/exb.all.0)
	p.05[i,] <- colMeans(exb.region5.0/exb.all.0)

	exb.region1.tr <- exp(beta.R %*% t(subset(observed.x.tr, id.alt==1, select=c(1:6))))
	exb.region2.tr <- exp(beta.R %*% t(subset(observed.x.tr, id.alt==2, select=c(1:6))))
	exb.region3.tr <- exp(beta.R %*% t(subset(observed.x.tr, id.alt==3, select=c(1:6))))
	exb.region4.tr <- exp(beta.R %*% t(subset(observed.x.tr, id.alt==4, select=c(1:6))))
	exb.region5.tr <- exp(beta.R %*% t(subset(observed.x.tr, id.alt==5, select=c(1:6))))
	exb.all.tr <- exb.region1.tr + exb.region2.tr + exb.region3.tr + exb.region4.tr + exb.region5.tr

	p.tr1[i,] <- colMeans(exb.region1.tr/exb.all.tr)
	p.tr2[i,] <- colMeans(exb.region2.tr/exb.all.tr)
	p.tr3[i,] <- colMeans(exb.region3.tr/exb.all.tr)
	p.tr4[i,] <- colMeans(exb.region4.tr/exb.all.tr)
	p.tr5[i,] <- colMeans(exb.region5.tr/exb.all.tr)

	exb.region1.b <- exp(beta.R %*% t(subset(observed.x.b, id.alt==1, select=c(1:6))))
	exb.region2.b <- exp(beta.R %*% t(subset(observed.x.b, id.alt==2, select=c(1:6))))
	exb.region3.b <- exp(beta.R %*% t(subset(observed.x.b, id.alt==3, select=c(1:6))))
	exb.region4.b <- exp(beta.R %*% t(subset(observed.x.b, id.alt==4, select=c(1:6))))
	exb.region5.b <- exp(beta.R %*% t(subset(observed.x.b, id.alt==5, select=c(1:6))))
	exb.all.b <- exb.region1.b + exb.region2.b + exb.region3.b + exb.region4.b + exb.region5.b

	p.b1[i,] <- colMeans(exb.region1.b/exb.all.b)
	p.b2[i,] <- colMeans(exb.region2.b/exb.all.b)
	p.b3[i,] <- colMeans(exb.region3.b/exb.all.b)
	p.b4[i,] <- colMeans(exb.region4.b/exb.all.b)
	p.b5[i,] <- colMeans(exb.region5.b/exb.all.b)

}

id.weights <- cb.data$wts

t1 <- (p.tr1 / p.tr5) / (p.01 / p.05)
t2 <- (p.tr2 / p.tr5) / (p.02 / p.05)
t3 <- (p.tr3 / p.tr5) / (p.03 / p.05)
t4 <- (p.tr4 / p.tr5) / (p.04 / p.05)

b1 <- (p.b1 / p.b5) / (p.01 / p.05)
b2 <- (p.b2 / p.b5) / (p.02 / p.05)
b3 <- (p.b3 / p.b5) / (p.03 / p.05)
b4 <- (p.b4 / p.b5) / (p.04 / p.05)

OR.tr.1.w <- colSums(apply(t1, 1, function(x) {x * id.weights}))/sum(id.weights)
OR.tr.2.w <- colSums(apply(t2, 1, function(x) {x * id.weights}))/sum(id.weights)
OR.tr.3.w <- colSums(apply(t3, 1, function(x) {x * id.weights}))/sum(id.weights)
OR.tr.4.w <- colSums(apply(t4, 1, function(x) {x * id.weights}))/sum(id.weights)

OR.b.1.w <- colSums(apply(b1, 1, function(x) {x * id.weights}))/sum(id.weights)
OR.b.2.w <- colSums(apply(b2, 1, function(x) {x * id.weights}))/sum(id.weights)
OR.b.3.w <- colSums(apply(b3, 1, function(x) {x * id.weights}))/sum(id.weights)
OR.b.4.w <- colSums(apply(b4, 1, function(x) {x * id.weights}))/sum(id.weights)

OR <- cbind(OR.tr.1.w, OR.tr.2.w, OR.tr.3.w, OR.tr.4.w, OR.b.1.w, OR.b.2.w, OR.b.3.w, OR.b.4.w)
quantiles <- apply(OR, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(OR, 2, sd)
pop.odds <- cbind(t(quantiles), sds)
colnames(pop.odds) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(pop.odds) <- c("Travel Cost: Marin", "Travel Cost: East Bay", "Travel Cost: Bayshore", "Travel Cost: Peninsula", "Bridge Crossing: Marin", "Bridge Crossing: East Bay", "Bridge Crossing: Bayshore", "Bridge Crossing: Peninsula")
print(round(pop.odds, digits=3))


library(pacman)

p_load(spatstat,
       sf,
       raster,
       dplyr,
       tmap,
       spData,
       maptools,
       ggplot2)

# Loading and cleaning shapefile of findings and borders
point_shp <- st_read("../data/anlaeg_all_25832.shp")
point_shp <- point_shp[!(!is.na(point_shp$anlaegsbet) & point_shp$anlaegsbet==""), ]
møntfund <- point_shp %>% filter(anlaegsbet == "Møntfund")
havne <- point_shp %>% filter(anlaegsbet == "Havn")

borders <- st_read("country_border/ne_10m_admin_0_countries.shp")
dk_shape <- borders %>% filter(NAME=="Denmark")

# Transform borders to owin window
dk_shape_utm <- sf::st_transform(dk_shape, crs = st_crs(møntfund)$proj4string)
dk_border_owin <- as.owin(sf::as_Spatial(dk_shape_utm))

# Change coins and harbour data to ppp object
møntfund_ppp <- as(as_Spatial(møntfund), "ppp")
havn_ppp <- as(as_Spatial(havne), "ppp")

# Planar point pattern
point_pattern_border <- ppp(møntfund_ppp$x, # "Planar point pattern" is jargon for a set of points in a region of a 2D plane
                            møntfund_ppp$y,
                            window = dk_border_owin,
                            unitname=c("metre","metres")) # window is the window of observation, an object of class "owin"

# Counting points in quadrats in point_pattern_border and performing quadrat test
test <- quadratcount(point_pattern_border, nx=25)
quadrat.test(test)

# Plotting with Bornholm
plot(intensity(test, image=TRUE), main=NULL, las=1)  # Plot density raster - The density values are reported as the number of points (stores) per square meters, per quadrat.
plot(havne, add=TRUE, col= "#33CAFF", cex=1)

# Plotting without Bornholm
no_bornholm <- møntfund %>% filter(kommunenav!="Bornholm")
no_bornholm_ppp <- as(as_Spatial(no_bornholm), "ppp")

point_pattern_border_no_bornholm <- ppp(no_bornholm_ppp$x, # "Planar point pattern" is jargon for a set of points in a region of a 2D plane
                                        no_bornholm_ppp$y,
                                        window = dk_border_owin,
                                        unitname=c("metre","metres")) # window is the window of observation, an object of class "owin"

test_no_bornholm <- quadratcount(point_pattern_border_no_bornholm, nx=25)
quadrat.test(test_no_bornholm)
plot(intensity(test_no_bornholm))
intensity(test_no_bornholm, image=TRUE)
plot(intensity(test_no_bornholm, image=TRUE), main=NULL, las=1)  # Plot density raster - The density values are reported as the number of points (stores) per square meters, per quadrat.
plot(havne, add=TRUE, col= "#33CAFF", cex=1)


install.packages("AppliedPredictiveModeling")
library(AppliedPredictiveModeling)
data(schedulingData)
library(caret)

dim(schedulingData)

tail(schedulingData)

summary(schedulingData)

set.seed(1234)

inTrain <- createDataPartition(schedulingData$Class, p = .75,list = FALSE)

training <- schedulingData[ inTrain,]
testing <- schedulingData[-inTrain,]

dim(training)

dim(testing)

library(C50)
ClassTree <- C5.0(Class ~ ., data = training)
ClassTree

ClassTreePred <- predict(ClassTree, testing)
table(ClassTreePred)

addmargins(table(testing$Class,ClassTreePred))

ClassTreeProbs <- predict(ClassTree, testing, type ="prob")
head(ClassTreeProbs)

postResample(ClassTreePred, testing$Class)

C5imp(ClassTree)

schedulingData$NumPending <- schedulingData$NumPending + 1

# Cant have log(0)

set.seed(1234)

inTrain <- createDataPartition(schedulingData$Class, p = .75,list = FALSE)

training <- schedulingData[ inTrain,]
testing <- schedulingData[-inTrain,]

newformula <- as.formula(Class ~ Protocol + log10(Compounds) +
                      log10(InputFields)+ log10(Iterations) +
                      log10(NumPending) + Hour + Day)

ClassTree2 <- C5.0(newformula, data = training)
ClassTree2

C5imp(ClassTree2)

ClassTreePred2 <- predict(ClassTree2, testing)
table(ClassTreePred2)

postResample(ClassTreePred2, testing$Class)

C5.0Fit <- train(newformula, data = training,
 data = training,
 method = "C5.0")
 ## Center and scale the predictors for the training
 ## set and all future samples.
 ## preProc = c("center", "scale"))


require(datasets)
require(stats)
require(RCUrl)
require(ggplot2)
require(ggthemes)
require(scales)
require(tidyverse)
require(gridExtra)
require(rstudioapi)

rm(list = ls())
setwd(dirname(getActiveDocumentContext()$path ))
#print( getwd() )
source("./covid19_functions.r")

#select countries to plot, support only two countries
#countries <- c ("US", "Italy", "Germany", "Spain", "France", "China")
#countries <- c ("India", "Russia", "Brazil", "Canada", "Iran")
countries <- c("India", "Singapore", "Malaysia", "Japan", "Thailand")

#download the data file
d_sums <- build_dataframe("time_series_covid19_confirmed_global.csv", countries)

#Add dates
dates <- seq(c(as.Date("2020/3/1")), by = "day", length.out = ncol(d_sums))
d_sums <- rbind(date=as.Date(dates), d_sums[1:length(countries),])
d_sums <- data.frame(t(d_sums))

#Create a dataframe for rate of change
d_trend <- ma(d_sums[-1,-1]/d_sums[-nrow(d_sums),-1],6)[-1:-5,]
colnames(d_trend) <- colnames(d_sums)[-1]
d_trend <- data.frame(t(d_trend))
d_trend <- rbind(date=as.Date(tail(dates,-4)), d_trend[1:length(countries),])

#create a line plot
yMarker <- 10^ceiling(log10(max(d_sums[-1])))/20
p1 <- get_base_plot(d_sums, "Confirmed cases") +
  scale_y_continuous(breaks = round(seq(0, max(d_sums[-1]), by = yMarker),1)) +
  geom_line(size=0.5) +
  geom_point(size=0.75)

d_trend <- data.frame(t(d_trend))
#d_trend$Value <- replace_na(d_trend$Value, 1)
#d_trend$Value[is.infinite(d_trend$Value)] <- 1

#create a smoothen line plot for growth rate multiplier trend
p2 <- get_base_plot(d_trend, "(5 day moving average) growth multiplier") +
  geom_smooth(method="loess", formula = y ~ x, se = FALSE, size=0.6)

grid.arrange(p1, p2, nrow = 2, top = "COVID-19:Confirmed cases and growth rate (Data Source- Johns Hopkins JHU CCSE)")


# Master Thesis Project - Extreme Value Theory
# For each sample, ordering the data and comparing
# the ordered sample to the quantiles of the
# extreme law fitting the tail of the original
# sample

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("loadStockData_plain.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Loading the original data for the five stocks then
# getting the LVMH and the Total data
df_plain <- loadStockData_plain(CHOICE)

# Computing the 95 % - quantiles for each of the stocks
quantiles <- c(quantile(df_plain[[1]],0.95), quantile(df_plain[[2]],0.95), quantile(df_plain[[3]],0.975),
					quantile(df_plain[[4]],0.95), quantile(df_plain[[5]],0.95))

# Getting the data above the threshold
data_bnp <- df_plain[[1]]
data_bnp <- data_bnp[data_bnp > quantiles[1]]

data_carrefour <- df_plain[[2]]
data_carrefour <- data_carrefour[data_carrefour > quantiles[2]]

data_lvmh <- df_plain[[3]]
data_lvmh <- data_lvmh[data_lvmh > quantiles[3]]

data_sanofi <- df_plain[[4]]
data_sanofi <- data_sanofi[data_sanofi > quantiles[4]]

data_total <- df_plain[[5]]
data_total <- data_total[data_total > quantiles[5]]

str(gev.fit(data_total))
# Fitting the data, and getting the corresponding location, scale and
# shape parameters respectively, for each stock
bnp_fit <- (gev.fit(data_bnp))
carrefour_fit <- gev.fit(data_carrefour)
lvmh_fit <- gev.fit(data_lvmh)
sanofi_fit <- gev.fit(data_sanofi)
total_fit <- gev.fit(data_total)

params_bnp <- bnp_fit$mle
params_carrefour <- carrefour_fit$mle
params_lvmh <- lvmh_fit$mle
params_sanofi <- sanofi_fit$mle
params_total <- total_fit$mle

# Ordering the samples (increasing sort)
data_bnp <- sort(df_plain[[1]])
data_carrefour <- sort(df_plain[[2]])
data_lvmh <- sort(df_plain[[3]])
data_sanofi <- sort(df_plain[[4]])
data_total <- sort(df_plain[[5]])

# Vector of the quantiles we want to plot
q <- seq(0.99/800,0.99,0.99/800)

plot(data_bnp, col = 'grey', type = 'l')
gev_bnp <- qgev(q,params_bnp[3],params_bnp[1],params_bnp[2])
lines(gev_bnp, col = 'red')
print(bnp_fit$mle)
print(carrefour_fit$mle)
print(lvmh_fit$mle)
print(sanofi_fit$mle)
print(total_fit$mle)

quartz()
png(file = "DataVSQuantiles_BNP.png")
plot(data_bnp, col = 'green', type = 'l', main = "Sorted BNP Paribas stock prices and quantiles of the extreme law")
gev_bnp <- qgev(q,params_bnp[3],params_bnp[1],params_bnp[2])
lines(gev_bnp, col = 'black')
dev.off()
graphics.off()

quartz()
png(file = "DataVSQuantiles_Carrefour.png")
plot(data_carrefour, col = 'red', type = 'l', main = "Sorted Carrefour stock prices and quantiles of the extreme law")
gev_carrefour <- qgev(q,params_carrefour[3],params_carrefour[1],params_carrefour[2])
lines(gev_carrefour, col = 'black')
dev.off()
graphics.off()

quartz()
png(file = "DataVSQuantiles_LVMH.png")
plot(data_lvmh, col = 'yellow', type = 'l', main = "Sorted LVMH stock prices and quantiles of the extreme law")
gev_lvmh <- qgev(q,params_lvmh[3],params_lvmh[1],params_lvmh[2])
lines(gev_lvmh, col = 'black')
dev.off()
graphics.off()

quartz()
png(file = "DataVSQuantiles_Sanofi.png")
plot(data_sanofi, col = 'grey', type = 'l', main = "Sorted Sanofi stock prices and quantiles of the extreme law")
gev_sanofi <- qgev(q,params_sanofi[3],params_sanofi[1],params_sanofi[2])
lines(gev_sanofi, col = 'black')
dev.off()
graphics.off()

quartz()
png(file = "DataVSQuantiles_Total.png")
plot(data_total, col = 'blue', type = 'l', main = "Sorted Total stock prices and quantiles of the extreme law")
gev_total <- qgev(q,params_total[3],params_total[1],params_total[2])
lines(gev_total, col = 'black')
dev.off()
graphics.off()


Forward <- function(Obs, Ini, A, E){
  # Takes a sequence of observations, calculate forward probability matrix
  #
  # Args:
  #   Obs: a numeric vector
  #   Ini: q_start to q_1 prob distribution
  #   A: Trans matrix
  #   E: Emission matrix, e_q\sigma
  #
  # Output: Forward matrix: F_qi, row is state, column is time index
  nQ <- dim(A)[1]
  n <- length(Obs)
  a <- matrix(Ini * E[, Obs[1]], nQ, 1)
  for (i in 2:n){
    temp <- a[, i-1] * A * (rep(1, nQ) %*% t(E[, Obs[i]]))
    a <- cbind(a, colSums(temp))
  }
  return(a)
}

Backward <- function(Obs, A, E){
  # Takes a sequence of observations, calculate backward probability matrix
  #
  # Args:
  #   Obs: a numeric vector
  #   A: Trans matrix
  #   E: Emission matrix, e_q\sigma
  #
  # Output: Backward matrix: F_qi, row is state, column is time index
  nQ <- dim(A)[1]
  n <- length(Obs)
  b <- matrix(rep(1, nQ), nQ, 1)
  for (i in (n - 1):1){
    temp <- A * (rep(1, nQ) %*% t(E[, Obs[i + 1]])) * (rep(1, nQ) %*% t(b[, 1]))
    b <- cbind(rowSums(temp), b)
  }
  return(b)
}

SoftCoding <- function(Obs, Ini, A, E){
  # Takes a sequence of observations, calculate posterior distribution
  #
  # Args:
  #   Obs: a numeric vector
  #   Ini: q_start to q_1 prob distribution
  #   A: Trans matrix
  #   E: Emission matrix, e_q\sigma
  #
  # Output:
  #   Probability matrix of posterior distribution at each index(time)
  #
  b <- Backward(Obs, A, E)
  f <- Forward(Obs, Ini, A, E)
  fb <- f * b
  output <- apply(fb, 2, function(x) x / sum(x))
  return(t(output))
}

BW <- function(nQ, nS, Obs, Ini = NULL, epsilon = 1e-09, maxIter = 100, IniA = NULL, IniE = NULL){
  # Take a list of observations, return HMM parameters
  #
  # Args:
  #   nQ: number of states
  #   nS: number of alphabet
  #
  # Output:
  #   Ini: q_start to q_1 distribution
  #   A: transition matrix
  #   E: emission matrix
  #
  # Initialization
  n <- length(Obs)
  if(is.null(IniA)){
    A <- matrix(abs(runif(nQ * nQ)), nQ, nQ)
    A <- t(apply(A, 1, function(x) x / sum(x)))
  } else {
    A <- IniA
  }
  if(is.null(IniE)){
    E <- matrix(abs(runif(nQ * nS)), nQ, nS)
    E <- t(apply(E, 1, function(x) x / sum(x)))
  } else {
    E <- IniE
  }

  if(is.null(Ini)){
    Ini <- abs(runif(nQ))
    Ini <- Ini / sum(Ini)
  }
  iter <- 1
  diff <- 1
  # EM algorithm
  while (diff > epsilon && iter <= maxIter){
    alpha <- Forward(Obs, Ini, A, E)
    beta <- Backward(Obs, A, E)
    alphabeta <- alpha * beta
    gamma <- apply(alphabeta, 2, function(x) x / sum(x))
    A.nu <- 0
    for (i in 1:(n - 1)){
      A.nu <- A.nu + alpha[, i] * A * (rep(1, nQ) %*% t(E[, Obs[i+1]])) * (rep(1, nQ) %*% t(beta[, i+1]))
    }
    newA <- t(apply(A.nu, 1, function(x) x / sum(x)))
    E.nu <- NULL
    for (i in 1:nS){
      E.nu <- cbind(E.nu, rowSums(alphabeta[, which(Obs == i)]))
    }
    newE <- t(apply(E.nu, 1, function(x) x / sum(x)))
    diff <- sqrt(sum((newA - A) ^ 2)) + sqrt(sum((newE - E) ^ 2))
    A <- newA
    E <- newE
    Ini <- gamma[, 1]
    iter <- iter + 1
  }
  if(iter == maxIter) print("Maximum iteration reached, algorithm didn't converge.")
  output <- list(Ini = Ini, A = A, E = E, Difference = diff)
  return(output)
}

library(HMM)

Obstest <- c("1", "2", "1", "1", "2", "3", "2", "3", "3", "3")
IniA <- matrix(c(.75, .25, .25, .75), 2, 2)
IniE <- matrix(rep(1/3, 6), 2, 3)
Ini <- rep(1/2, 2)
Obs <- as.numeric(Obstest)
hmm <- initHMM(c("1", "2"), c("1", "2", "3"))

library(microbenchmark)
microbenchmark(BW(2, 3, Obs, Ini, IniA = IniA, IniE = IniE), baumWelch(hmm, Obstest))


#' unlogit
#'
#' This function allows you to unlogit (back transform)
#' @param logit numeric value
#' @return y unlogit value
#' @keywords logit
#' @export
#' @examples
#' un_logit(1)

un_logit <- function(logit){
  y = exp(logit)/(1 + exp(logit))
  return(y)
}


rm(list=ls())

library('radolc')

#--- testing ADOLC's jacobian

fr <- function(x) {
  x1 <- x[[1]]
  x2 <- x[[2]]
  #Use create list to create adouble objects
  y<-adolc_createList(2,2.0)
  #y <- c(0.0,0.0)
  y[[1]] <- 100 * (x2 - x1 * x1)* (x2 - x1 * x1) + (1 - x1)*(1 - x1)
  y[[2]] <- 100 * (x2 - x1 * x1)+ (x2 - x1 * x1) * (1 - x1)*(1 - x1)
  y}

trace_on(1)
x <- adolc_createList(2,2.0)
badouble_declareIndependent(x)
y <- fr(x)
badouble_declareDependent(y)
trace_off()

xx <- c(1.0,2.0)
yy <- matrix(rep(0.0,4), nrow = 2, ncol = 2)
jacobian(1,2,2,xx,yy);
#jacobian(tag,m,n,x,J)
# tag: integer, tape identification
# m  : integer, number of dependent variables
# n  : integer, number of independent variables n
# x[n]: independent vector x
#J[m][n]; // resulting Jacobian F(x)
print(yy)

#Always detach the package
detach(package:radolc, unload=TRUE)


# ......................................................................................
# ..............................Cvičení 4 - Náhodný vektor..............................
# ..................Martina Litschmannová, Adéla Vrtková, Michal Béreš..................
# ......................................................................................

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

#  Příklad ze sbírky ####
# Náhodný vektor $Z =(Y;X)^T$ má pravděpodobnostní funkci zadanou tabulkou
# Obrázek viz sbírka úloh.
# * a) Určete chybějící hodnotu sdružené pravděpodobnostní funkce, ####

data = c(0.01, 0.04, 0.12,
         0.02, 0.16, 0.07,
         0.03, 0,    0.06,
         0.25, 0.05, 0.01)
P = matrix(data , nrow=3, ncol=4) #případně byrow = ...
X = c(3, 5, 7)
Y = c(1, 2, 3, 4)
dimnames(P) = list(X,Y)
P

sum(P)

# nespoštějte tuto buňku 2krát, jinak si hodnotu zase nastavíte na 0,
# víte proč?
p_5_3 = 1 - sum(P)
P["5","3"] = p_5_3
P

# * b) Určete distribuční funkci ####
# **Pozor! Vektor Z je $(Y,X)^T$ tedy první parametr je hodnota Y a druhý hodnota X.**

# F(2.8; 7.1)
# = P(Y<2.8,X<7.1)
P[X<7.1, Y<2.8]
sum(P[X<7.1, Y<2.8])

F = matrix(rep(0,4*5), nrow=4, ncol=5)
dimnames(F) = list(c('(-inf,3>', '(3,5>', '(5,7>', '(7,inf)'),
                   c('(-inf,1>', '(1,2>', '(2,3>', '(3,4>', '(4,inf)'))
F

# projdeme řádky a sloupce, vždy si vezmeme jednu hodnotu
# z příslušného řádku nebo sloupce
x_vals = c(3,5,7,8)
y_vals = c(1,2,3,4,5)
for(i in 1:4){
    for(j in 1:5){
        x = x_vals[i]
        y = y_vals[j]
        F[i,j] = sum(P[X<x, Y<y])
    }
}
F

# * c) Určete marginální rozdělení ####

P_x = rowSums(P)
P_x

F_x = c(0, cumsum(P_x))
F_x

P_y = colSums(P)
P_y

F_y = c(0, cumsum(P_y))
F_y

# * d) Podmíněné pravděpodobnosti a podmíněné pravděpodobnostní funkce $P(x|y), P(y|x)$ ####

# P(Y > 2.1 | X < 5.3)
#  = P(Y > 2.1 ∧ X < 5.3) / P(X < 5.3)
sum(P[X<5.3, Y>2.1])
sum(P[X<5.3,])
sum(P[X<5.3, Y>2.1])/sum(P[X<5.3,])

# P(X = 5|Y = 1)
# = P(X = 5 ∧ Y = 1) / P(Y = 1)
P['5','1']/sum(P[,'1'])
P['5','1']/sum(P_y['1'])

# **$P(x|y)=\frac{P(X=x,Y=y)}{P_Y(y)}$**

P_xy = P # má to stejnou velikost, tak si ukradneme formátování
X_lab = c('3', '5', '7')
Y_lab = c('1', '2', '3', '4')
for(x in X_lab){
    for(y in Y_lab){
        P_xy[x, y] = P[x, y]/P_y[y]
    }
}
P_xy
colSums(P_xy)

# **$P(y|x)$**

P_yx = P # má to stejnou velikost, tak si ukradneme formátování
for(x in X_lab){
    for(y in Y_lab){
        P_yx[x, y] = P[x, y]/P_x[x]
    }
}
P_yx
rowSums(P_yx)

# * e) zákládní charakteristiky náhodných veličin X a Y ####

E_X = sum(X*P_x)
E_X
E_XX = sum(X*X*P_x)
D_X = E_XX - E_X^2
D_X

E_Y = sum(Y*P_y)
E_Y
E_YY = sum(Y*Y*P_y)
D_Y = E_YY - E_Y^2
D_Y

# * f) podmíněná střední hodnota  E(X|Y = 2) ####

# P(x|Y=2)
P_xy[,'2']
E_X_Y2 = sum(X*P_xy[,'2'])
E_X_Y2

# * g) kovariance a korelace ####

X_Y = P # matice kde v každé kolonce je hodnota x*y
for(x in X){
    for(y in Y){
        X_Y[x==X, y==Y] = x*y
    }
}
X_Y

# střední hodnota E(X*Y)
E_XY = sum(X_Y*P)
E_XY

# kovariance
cov_XY = E_XY-E_X*E_Y
cov_XY

# korelace
cov_XY/sqrt(D_X*D_Y)


# utils.R - collection of function to help cluster users and movies
#           by similarity.
# Authors: Eran Amar & Tomer Levy

source("utils.R")
source("data_loader.R")
library(glmnet)
library(gplots)

calc.cosine.sym <- function(X){
  # Calculate cosine similarity, accounting to rows with zero standard deviation.
  X <- as.matrix(X)
  X[is.na(X)] <- 0

  X.ss <-X %*% t(X)
  X.ss.sqrt <- sqrt(diag(X.ss))
  X.ss.sqrt[X.ss.sqrt == 0] <- 1
  X.cosine <- X.ss / (X.ss.sqrt%*% t(X.ss.sqrt))
  return(X.cosine)
}

calc.cosine.sym.centered <- function(train.ratings){
  # Centeromg tje data, then calculate cosine similarity.
  train.ratings.centered <- as.matrix(center_rating_per_person(train.ratings))
  return(calc.cosine.sym(t(train.ratings.centered)))
}

cluster.users <- function(train.ratings, k, center=T){
  # Cluster users into k clusters using cosine symmilarity.

  if (center){
    sym <- calc.cosine.sym(train.ratings-3.5)
  } else {
    sym <- calc.cosine.sym(train.ratings)
  }

  h <- hclust(as.dist(1/sym), method = "ward.D2")
  # Plotting the cluster
  plot(h)
  rect.hclust(h, k=k, border="red")
  # Splitting into groups
  groups <- cutree(h, k=k)
  return(groups)
}

by.group.train <- function(FUN, X, y, groups, ...){
  # Trains predictor to each group  in cluster seperately

  X.groups <- split.data.frame(X, groups)
  y.groups <- split(y, groups)
  models <- list()
  for (g in min(groups):max(groups)){
    models[[g]] <-FUN(X.groups[[g]], y.groups[[g]], ...)
  }
  return(models)
}

by.group.predict <- function(model, X, groups){
  # Predict by seperate predictor to each group in cluster

  X.groups <- split.data.frame(X, groups)
  preds <- list()
  for (g in min(groups):max(groups)){
    preds[[g]] <- predict(model[[g]], X.groups[[g]])
  }
  return(unsplit(preds, groups))
}


# Function 'NormMax'
# Killian Martin--Horgassan
# 19-02-2015

# Generates the list of maxima [M_1, ..., M_n] of the list of
# i.i.d random variables [X_1,...,X_n]. Plots the M_i against
# the i.

# Arguments :
# - N     : number of r.v. X_i
# - DIST  : a vector of N pseudo-random numbers from a certain
#			distribution.
#           (by default it is a Gaussian of size 10000)
# RETURNS the list of maxima

NormMax2 <- function(N = 10000, DIST = rnorm(10000,0,1), DIST_name = "gaussian") {
 	ListX   <- DIST
 	ListMax <- rep(0,N)

 	print(DIST_name)

 	# Computes the list of the M_i
 	for (i in 1:length(ListMax)) {
 		ListMax[i] <- max(ListX[1:i])
 	}

 	# Plots the 1-D scatter plot of the M_i
 	title_1 <- "1-D scatter plot of the maxima"
 	xlabel_1 <- expression(M[i])
 	stripchart(ListMax, xlab = xlabel_1, main = title_1)

 	# Opens a new graphic window
 	quartz()

 	# Plots the M_i against the i
 	title_2 <- "Maxima as a function of the time steps"
 	xlabel_2 <- "Time step"
 	ylabel_2 <- "Maximum"
 	plot(ListMax, xlab = xlabel_2, ylab = ylabel_2, main =
 			title_2)

 	# Opens a new graphic windows
 	quartz()

 	# Plot the 1-D scatter plot of the M_i and the M_i against the
 	# i together in a grid.
 	par(mfrow = c(1,2))

 	stripchart(ListMax, xlab = xlabel_1, main = title_1)
    plot(ListMax, xlab = xlabel_2, ylab = ylabel_2, main =
 			title_2, pch = 4)
 	points(1:N,sqrt(2*log(1:N)),col="cyan", pch = 3)
 	legend(x="bottomright",y=NULL,c("Maxima",
 		expression("sqrt(log(n))")), col = c("black","cyan"),
 		bty="o", pch = c(4,3))

 	# Exports the plots to a PDF file
 	pdf(file = "graphIntroTask2.pdf", width = 10, height = 8)
	par(mfrow = c(1,2))
 	stripchart(ListMax, xlab = xlabel_1, main = title_1)
    plot(ListMax, xlab = xlabel_2, ylab = ylabel_2, main =
 			title_2, pch = 4)
 	points(1:N,sqrt(2*log(1:N)),col="cyan", pch = 3)
 	legend(x="bottomright",y=NULL,c("Maxima",
 		expression("sqrt(log(n))")), col = c("black","cyan"),
 		bty="o", pch = c(4,3))
 	#dev.off()

 	# Exports the plots to jpeg files for use in the LaTex report

 	if (DIST_name == "gaussian") {
 		fileName1 <- "gaussianScatterMaxima2.jpeg"
 		fileName2 <- "gaussianMaximaAgainstSteps2.jpeg"
 	} else if (DIST_name == "exponential") {
 		fileName1 <- "exponentialScatterMaxima2.jpeg"
 		fileName2 <- "exponentialMaximaAgainstSteps2.jpeg"
 	} else {
 		fileName1 <- "cauchyScatterMaxima2.jpeg"
 		fileName2 <- "cauchyMaximaAgainstSteps2.jpeg"
 	}

 	jpeg(file = fileName1)
 	stripchart(ListMax, xlab = xlabel_1, main = title_1)

 	jpeg(file = fileName2)
 	plot(ListMax, xlab = xlabel_2, ylab = ylabel_2, main =
 			title_2)

 	dev.off()

 	return(ListMax)
 }


college = read.csv("../../../data/College.csv")

head(college)

rownames(college) = college[,1]
head(college[, 1:5])

college = college[,-1]
head(college[, 1:5])

summary(college)

pairs(college[,1:10])

plot(college$Private, college$Outstate,
     xlab = "Private University", ylab = "Out of State tuition in USD", main = "Outstate Tuition Plot")

Elite = rep("No", nrow(college))
Elite[college$Top10perc > 50] = "Yes"
Elite = as.factor(Elite)
college = data.frame(college, Elite)

summary(college$Elite)

plot(college$Elite, college$Outstate,
     xlab = "Elite University", ylab ="Out of State tuition in USD", main = "Outstate Tuition Plot")

par(mfrow = c(2,2))
hist(college$Books, col = 2, xlab = "Books", ylab = "Count")
hist(college$PhD, col = 3, xlab = "PhD", ylab = "Count")
hist(college$Grad.Rate, col = 4, xlab = "Grad Rate", ylab = "Count")
hist(college$perc.alumni, col = 6, xlab = "% alumni", ylab = "Count")

summary(college$PhD)

weird.phd = college[college$PhD == 103, ]
nrow(weird.phd)

rownames(weird.phd)

par(mfrow=c(1,1))
plot(college$Outstate, college$Grad.Rate)

plot(college$Accept / college$Apps, college$S.F.Ratio)

plot(college$Top10perc, college$Grad.Rate)

Auto = read.csv("../../../data/Auto.csv", header=T, na.strings="?")
Auto = na.omit(Auto)

str(Auto)

summary(Auto)

sapply(Auto[, 1:7], range)

sapply(Auto[, 1:7], mean)

sapply(Auto[, 1:7], sd)

subsetAuto = Auto[-(10:85),]
sapply(subsetAuto[, 1:7], range)

sapply(subsetAuto[, 1:7], mean)

sapply(subsetAuto[, 1:7], sd)

pairs(Auto)

plot(Auto$mpg, Auto$weight)

plot(Auto$mpg, Auto$cylinders)

plot(Auto$mpg, Auto$year)

pairs(Auto)

cor(Auto$weight, Auto$horsepower)

cor(Auto$weight, Auto$displacement)

cor(Auto$displacement, Auto$horsepower)

library(MASS)

Boston

?Boston

dim(Boston)

pairs(Boston)

par(mfrow = c(2, 2))
plot(Boston$nox, Boston$crim)
plot(Boston$rm, Boston$crim)
plot(Boston$age, Boston$crim)
plot(Boston$dis, Boston$crim)

hist(Boston$crim, breaks = 50)

pairs(Boston[Boston$crim < 20, ])

par(mfrow = c(3, 2))
plot(Boston$age, Boston$crim, main = "Older homes, more crime")
plot(Boston$dis, Boston$crim, main = "Closer to work-area, more crime")
plot(Boston$rad, Boston$crim, main = "Higher index of accessibility to radial highways, more crime")
plot(Boston$tax, Boston$crim, main = "Higher tax rate, more crime")
plot(Boston$ptratio, Boston$crim, main = "Higher pupil:teacher ratio, more crime")

par(mfrow=c(1,3))
hist(Boston$crim[Boston$crim > 1], breaks=25)
hist(Boston$tax, breaks=25)
hist(Boston$ptratio, breaks=25)

nrow(Boston[Boston$chas == 1, ])

median(Boston$ptratio)

t(subset(Boston, medv == min(Boston$medv)))

summary(Boston)

nrow(Boston[Boston$rm > 7, ])

nrow(Boston[Boston$rm > 8, ])

summary(subset(Boston, rm > 8))

summary(subset(Boston, rm > 8))

notebooks/R/2 Statistical Learning/2.4 Exercises.r


y1bar=38.48
s1=16.37
n1=40
y2bar=26.93
s2=9.88
n2=40
# test statistic
F=s1^2/s2^2
print(F)
#critical value
alpha=0.05
f.alpha=qf(1-alpha/2,39,39)
# we reject H0 if F>=f.alpha


# Master Thesis Project - Extreme Value Theory
# We assume that the stock prices follow a geometric
# Brownian motion (Black-Scholes model). We plot the
# empirical stock price data as well as the simulated
# geometric Brownian motions associated to them.
# HERE WE WILL RUN A LARGE NUMBER OF SIMULATIONS
# AND TAKE THE AVERAGE (for instance 100 simulations)
# Killian Martin--Horgassan
# 02-06-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Sourcing the auxiliary files
source("logGrossReturns.r")
source("loadStockData.r")
source("loadStockData_plain.r")
source("meanAndVarianceDF.r")

# Remark : the csv uses the metastock data format
#          7 columns : - Ticker (identifier of the stock
#                       and stockmarket on which it is listed)
#					   - Date (yyyymmdd)
#					   - Open
#					   - High
#					   - Low
#					   - Close
#					   - Volume
# By default, the highest price is used i.e. column 3.
CHOICE <- 3

# Number of simulations
nb_sim <- 100

# Loading the original data for the five stocks
df_plain <- loadStockData_plain(CHOICE)

# Loading the log-gross returns for the five stocks
df <- loadStockData(CHOICE)

# Computing the mean and Variances of the stock
meanAndVarDF <- meanAndVarianceDF(df)

# Building the Geometric Brownian motion
	N = dim(df)[1]
	M = dim(df)[2]
	c <- rep(0,N)
	geomBMs <- data.frame(c,c,c,c,c)

	means <- meanAndVarDF[1]
	vars <- meanAndVarDF[2]

	# Time component
	timeSteps = 0:(N-1)

for (j in 1:nb_sim)	 {
	# Brownian motion component
    dis = rnorm(N,0,1)
    dis = cumsum(dis)

	for (i in 1:M) {
		coeff1 = (means[[1]])[i] - 0.5*(vars[[1]])[i]
		geomBMs[i] <- geomBMs[i] + (df_plain[[i]])[1]*exp(coeff1*timeSteps + sqrt((vars[[1]])[i])*dis)
	}
}

for (i in 1:M) {
	geomBMs[i] <- geomBMs[i]/nb_sim
}

# Plotting the actual stock prices and the corresponding simulations
x_label <- "Weekly measurements"
y_label <- "Prices and simulation"
title1 <- "BNP Stock"
title2 <- "Carrefour Stock"
title3 <- "LVMH Stock"
title4 <- "Sanofi Stock"
title5 <- "Total Stock"

quartz()
png(file = "actualAndSimulated-Averaged.png")
par(mfrow = c(3,2))
plot(df_plain[[1]], pch = 1, col = "black", type = 'l', xlab = x_label, ylab = y_label, main = title1)
lines(geomBMs[[1]], col = 'yellow')
plot(df_plain[[2]], pch = 1, col = "blue", type = 'l', xlab = x_label, ylab = y_label, main = title2)
lines(geomBMs[[2]], col = "yellow")
plot(df_plain[[3]], pch = 1, col = "green", type = 'l', xlab = x_label, ylab = y_label, main = title3)
lines(geomBMs[[3]], col = "yellow")
plot(df_plain[[4]], pch = 1, col = "purple", type = 'l', xlab = x_label, ylab = y_label, main = title4)
lines(geomBMs[[4]], col = "yellow")
plot(df_plain[[5]], pch = 1, col = "red", type = 'l', xlab = x_label, ylab = y_label, main = title5)
lines(geomBMs[[5]], col = "yellow")
dev.off()
graphics.off()


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

gaussKernel <- function(dist, h) exp(sqrt(h / pi * 0.5) * -0.5 * (dist * h) ^ 2)

parzen <- function(dset, labels, point, h, kernel, dist = euclidean) {
  dsetLength <- length(dset[,1])

  uLabels <- unique(labels)
  classScores <- array(0L, dim = c(length(uLabels)))
  names(classScores) = uLabels;
  # classScores["undefined"] <- 0.000001 # not needed for gaussian kernel

  for (i in 1:dsetLength) {
    classScores[paste(labels[i])] <- classScores[paste(labels[i])] + kernel(dist(point, dset[i,]), h)
  }

  return(classScores)
}

computeMargins <- function(dset, labels) {
  dsetLen <- dim(dset)[1]
  margins <- array(0L, dim = dsetLen)
  for (i in 1:dsetLen) {
    cat("\rProcessing", i, "of", dsetLen)
    classScores <- parzen(dset[-i,], labels[-i], dset[i,], 1.6, gaussKernel)

    margins[i] <- classScores[labels[i]] - max(classScores[-as.integer(labels[i])])
  }
  cat("\n")

  return (margins)
}

removeNoise <- function(dset, margins) { # returns indices of entries that we should get rid of
  negativeMarginIndices <- which(margins < 0)
  negativeMargins <- margins[negativeMarginIndices]
  negativeMargins <- sort(negativeMargins)

  dsetLen <- length(margins)
  diff <- abs(negativeMargins[1:(dsetLen - 1)] - negativeMargins[2:dsetLen])

  boundary <- negativeMargins[which.max(diff) + 1]

  return (which(margins < boundary))
}

stolp <- function(dset, labels, maxErrors, reduceNoise = TRUE) {
  margins <- computeMargins(dset, labels)

  # selecting one element with max margin from each class
  result <- data.frame()
  resultLabels <- c()
  indexesToExclude <- c()
  if (reduceNoise) {
    indexesToExclude <- removeNoise(dset, margins)
  }
  for (label in unique(labels)) {
    margins <- computeMargins(dset, labels)
    currentBest <- -1
    for (i in 1:length(margins)) {
      if (labels[i] == label && (currentBest == -1 || margins[currentBest] < margins[i])) {
        currentBest <- i
      }
    }

    result <- rbind(result, dset[currentBest,])
    resultLabels <- c(resultLabels, paste(labels[currentBest]))
    indexesToExclude <- c(indexesToExclude, currentBest)
  }

  n = length(labels)
  # iteratively reducing the error rate
  while (TRUE) {
    minIndex <- 1
    minValue <- 0
    negativeCount <- 0
    for (i in 1:n) {
      scores <- parzen(result, resultLabels, dset[i,], 1.6, gaussKernel)

      margin <- scores[paste(labels[i])] - max(scores[names(scores) != paste(labels[i])])
      if (margin < 0) {
        negativeCount <- negativeCount + 1
      }
      if (!(i %in% indexesToExclude) && margin < minValue) {
        minValue <- margin
        minIndex <- i
      }
    }

    cat("Errors: ", negativeCount, "\n")

    if (negativeCount <= maxErrors) break

    indexesToExclude <- c(indexesToExclude, minIndex)
    result <- rbind(result, dset[minIndex,])
    resultLabels <- c(resultLabels, paste(labels[minIndex]))
  }

  return (list("dataset" = result, "labels" = resultLabels))
}

drawPlots <- function() {
  colors <- c("setosa" = "blue", "virginica" = "red", "versicolor" = "green", "undefined" = "grey")
  opd <- stolp(iris[3:4], iris$Species, 6)

  png(sprintf("stolp.png"), width = 1024, height = 700, unit = "px", pointsize = 20)

  plot(iris[3:4], col = colors[paste(iris$Species)])
  points(opd[['dataset']], pch = 21, bg = colors[opd[['labels']]], col = colors[opd[['labels']]])

  dev.off()

  xs <- seq(from = 0.5, to = 7.5, by = 0.1)
  ys <- seq(from = -1, to = 3.5, by = 0.1)

  kernel <- gaussKernel
  png(sprintf("stolp-map.png"), width = 1024, height = 700, unit = "px", pointsize = 20)
  plot(iris[, 3:4], col = colors[paste(iris$Species)], pch=10, asp=1)
  points(opd[['dataset']], pch = 16, col = colors[opd[['labels']]])

  all <- length(xs) * length(ys)
  progress = 1
  for (i in xs) {
    for (j in ys) {
      cat("\rProcessing point", progress, "of", all)
      progress <- progress + 1
      result <- parzen(opd[['dataset']], opd[['labels']], c(i, j), 1.6, kernel)
      result <- names(result)[which.max(result)]
      points(i, j, col = colors[result], pch = 21)
    }
  }
  cat("\rDone.                      \n")
  dev.off()
}

timeMeasurements <- function () {
  opd <- stolp(iris[3:4], iris$Species, 6)
  startTime <- Sys.time()
  n <- dim(iris)[1]
  for (i in 1:n) {
    parzen(opd[['dataset']], opd[['labels']], iris[i, 3:4], 1.6, gaussKernel)
  }
  finishTime <- Sys.time()
  print(paste("Source dataset time: ", finishTime - startTime))
}

# num <- 56
# tt <- parzen(iris[-num,3:4], iris$Species[-num], iris[num,3:4], 1.6, gaussKernel)

# print(tt)
# print(iris$Species[num])
# opd <- stolp(iris[3:4], iris$Species, 5)

# plot(iris[3:4], col = colors[paste(iris$Species)])
# points(opd[['dataset']], pch = 21, bg = colors[opd[['labels']]], col = colors[opd[['labels']]])

# drawPlots()
# timeMeasurements()

4 - Selection of reference objects/stolp.r


###FOR CI's log-log transformation_Chourdhury (2002) Non-parametric confidence interval estimation for competing risks analysis: application to contraceptive data
#Run this code first
######CIF ESTIMATES############################################################################################################

###Heisey and Patterson CIF estimator
"cause.survival" = function(table, p)
{
	assign("p", p)

	# create tables to hold the results of GKM survival estimates for all events and for cause specific event
	temp.all <- summary(survfit(Surv(enter, exit, event) ~ 1, conf.type="log-log",data = table))
	temp.s <- summary(survfit(Surv(enter, exit, cause == p) ~ 1, conf.type="log-log",data = table))

	#combine the two tables so survival of all events can be combined with those of the cause specific events
	s.df <- data.frame(time = temp.s$time, n.event = temp.s$n.event, n.risk = temp.s$n.risk, survival = temp.s$surv)
	all.df <- data.frame(time = temp.all$time, n.event = temp.all$n.event, n.risk = temp.all$n.risk, survival = temp.all$surv)
	all.s.df <- merge(all.df, s.df, by.x = "time", by.y = "time", all.x = T, suffixes = c(".all", ".s"))
	assign("n", all.s.df)
	x <- length(n[,1])

	#create temporary placeholders for the calculation of the mortality rate and the cause-specific cumulative incidence func.
	tmp.string <- numeric(x)
	tmp.string2 <- numeric(x)
	t <- 1

	#cycle through the records of the table, including all events to calculate mortality rate and CIF
	while(t <= x) {
		tmp.string[1] <- n$n.event.s[1]/n$n.risk.s[1]
		if (t == 1) tmp.string[t] <- NA else tmp.string[t] <- (n$survival.all[t-1] * n$n.event.s[t])/n$n.risk.s[t]
		if(is.na(tmp.string[t])) tmp.string2[t] <- NA else tmp.string2[t] <- sum(tmp.string[1:t], na.rm = T)
		t = t + 1
	}

	MORT <- data.frame(mort.rate = tmp.string)
	CIF2 <- data.frame(CIF = tmp.string2)
	CIF.s.all <- cbind(all.s.df, MORT, CIF2)

# Calculate the variance, standard error and the Confidence Intervals around CIF

SE <- numeric(x)
totvar.t <- numeric(x)

#Reset all temporary variables
t <- 1
j <- 1
Ij <- 0
cumvar.p1 <- 0
cumvar.p2 <- 0
cumvar.p3 <- 0

#loop for the total number of records
while (t <= x)
{
   It <- CIF.s.all$CIF[t]
   if(is.na(It)) {
		CIF.s.all$cumvar[t] <- "NA"
		CIF.s.all$StdErr[t] <- "NA"
		CIF.s.all$CI.l[t] <- "NA"
		CIF.s.all$CI.u[t] <- "NA"

		t = t + 1
	}
   else
	{
		while (j < t)
		{
		if(is.na(CIF.s.all$CIF[j]))
			Ij <- Ij
	     else
			Ij <- CIF.s.all$CIF[j]
       cumvar.p1 <- cumvar.p1 + (It - Ij)^2 * (CIF.s.all$n.event.all[j]/(CIF.s.all$n.risk.all[j] * (CIF.s.all$n.risk.all[j] - CIF.s.all$n.event.all[j])))

		if(!is.na(CIF.s.all$CIF[j]))
		{
			if(j == 1)
				Sj3 <- 1
			else
			Sj3 <- CIF.s.all$survival.all[j-1]
			Ijc <- CIF.s.all$CIF[j]
			cumvar.p3 <- cumvar.p3 + (It - Ijc)*(Sj3)*(CIF.s.all$n.event.all[j] / (CIF.s.all$n.risk.all[j])^2)
		}
		j <- j + 1
   		}

		if (t == 1)
			Sj2 <- 1
		else
			Sj2 <- CIF.s.all$survival.all[t-1]

  		cumvar.p2 <- (Sj2)^2 * (((CIF.s.all$n.event.all[t])*(CIF.s.all$n.risk.all[t] - CIF.s.all$n.event.all[t]))/(CIF.s.all$n.risk.all[t])^3) + cumvar.p2

		#total all three components of the variance equation to get the final variance,  generate std. err and confidence intervals using log-log transformation
		#Assign all results to the output table
		totvar.t[t] <- cumvar.p1 + cumvar.p2 - (2 * cumvar.p3)
		CIF.s.all$cumvar[t] <- totvar.t[t]
		SE[t] <- sqrt(totvar.t[t])
		CIF.s.all$StdErr[t] <- SE[t]
		CIF.s.all$CI.l[t] <- CIF.s.all$CIF[t]^(exp((-1.96 * SE[t])/(CIF.s.all$CIF[t]*log(CIF.s.all$CIF[t]))))
		CIF.s.all$CI.u[t] <- CIF.s.all$CIF[t]^(exp((1.96 * SE[t])/(CIF.s.all$CIF[t]*log(CIF.s.all$CIF[t]))))

		t = t + 1
		j <- 1
   }

cumvar.p1 <- 0
cumvar.p3 <- 0
Ij <- 0
It <- 0
}

#Variance calculations end here ----------

	return(CIF.s.all)
}
#####End of Heisey and Patterson estimator


R0_calculateR <- function(estpar, fix_pars){
  alpha= fix_pars["alpha"]
  beta_1 = fix_pars["beta_1"]
  delta_1 = fix_pars["delta_1"]
  lambda = fix_pars["lambda"]
  mu = fix_pars["mu"]
  mu_c = fix_pars["mu_c"]
  De = fix_pars["De"]
  Dr = fix_pars["Dr"]
  N = fix_pars["N"]

  n_period = length(estpar)/2
  R0 = rep(0, n_period)

  for(i in 1:n_period){
    b = estpar[i]                 # values of beta for i_th period
    r = estpar[n_period + i]      # values of r for i_th period

    R0[i] = (0.5*b / (mu * De + 1)) * (alpha* (1 - r) / (1 / (beta_1 * Dr) + delta_1 * mu_c + mu)  +
                                   r / (1 / Dr + mu_c + mu))
  }
  return(R0)
}


 DGGLSE Example Program Results

 Constrained least squares solution
      0.4890     0.9975     0.4890     0.9975

 Square root of the residual sum of squares
      2.51E-02


cluster <- function(features, k){
    wss <- (nrow(features)-1)*sum(apply(features,2,var))
    for (i in 2:25){
      wss[i] <- sum(kmeans(features, i)$withinss)
    }
    plot(1:25, wss, type="b", xlab="Number of Clusters", ylab="Within groups sum of squares")
    fit <- kmeans(features, k)
    z <- fit$cluster

    # relabel cluster by size (to keep color consistency between executions)
    k.order <- order(table(z), decreasing=TRUE)
    z.temp <- z
    for(i in 1:max(z)){
      z.temp[z==k.order[i]] <- i
    }
    z <- z.temp

    return(z)
}

# Complementary
#library(mclust)
#BIC <-  mclustBIC(df.scaled)
#plot(BIC)
#fit2 <-Mclust(df.scaled)
#summary(fit2, parameters=TRUE)

plot.clusters <- function(features, clusters, sizes, colors){
  par(mfrow=c(1,1))
  pca <- princomp(features)

  # Colored PCA (base graphics)
  ######################################
  plot(pca$scores[,1], pca$scores[,2],
       col  = colors,
       cex  = sizes,
       pch  = 19,
       xlab = "Dimension 1", ylab = "Dimension 2")
  text(pca$scores[,1], pca$scores[,2],
       labels = rownames(features),
       cex    = 0.7)
  title("Individual factor map (PCA)")
  dev.copy(png, paste0('2016-01-15-PCA.png'), width = 800, height = 800)
  dev.off()

  # Colored PCA (another library)
  ################################
  p1 <- ggbiplot(pca,
                 obs.scale = 1,
                 var.scale    = 1,
                 groups       = factor(z),
                 ellipse      = TRUE,
                 circle       = TRUE,
                 #labels       = rownames(features),
                 labels.size  = 3.5,
                 varname.size = 4)
  p1 <- p1 + scale_color_manual(values = alpha(cluster.colors,0.75))
  p1 <- p1 + theme_bw() +
        theme(text            = element_text(size = 15),
              aspect.ratio    = 1,
              legend.position = "none") +
        ggtitle("Individual factor map (PCA)")
  print(p1)
  dev.copy(png, paste0('2016-01-15-PCA2.png'), width=800, height=800)
  dev.off()

  # Boxplots
  #########################
  # Clusters profile
  points <- as.data.frame(features)
  points$cluster <- factor(z)
  points <- melt(points, id='cluster')
  p <- ggplot(points, aes(x=variable, y=value)) +
    scale_fill_manual(values = cluster.colors) +
    geom_boxplot(aes(fill = cluster), position = position_dodge(width = 0.75))
  p <- p + theme_bw() +
    theme(text = element_text(size = 15),
          legend.key = element_blank()) +
    ggtitle("Clusters means and variances")
  print(p)
  dev.copy(png, paste0('2016-01-15-whiskers.png'), width=800)
  dev.off()

  # Colored scatter matrix
  #df.features$colors <- cluster.colors[z]
  #p1 <- ggpairs(data    = df.features,
  #              columns = 1:8,
  #              upper   = list(continuous = "points"),
  #              lower   = list(continuous = "points"),
  #              diag    = list(continuous = "density"),
  #              colour  = 'colors')
  #print(p1)

}


setwd("C:/Users/nhy577/Documents/_toma/TEACHING/MozillaStudyGroupAberdeen_2019")

library(lattice)
library(nlme)

# load the rats data
rats<- read.delim("rats.txt")
# treat rat ID as factor
rats$ID2<- factor(rats$ratID, labels= "ID_")
# slight variation (redundant)
rats$ID<- factor(rats$ratID)

plot(rats$weight~rats$day, col= 1:7, pch= 1:5) # particularly ugly

# panel plot by rat using lattice, to show individual trajectories
pdf("RATS_trajectories_IDpanel.pdf", 12, 7)
xyplot(weight~day|ID2, data= rats, type= "b")
dev.off()
# individual trajectories in separate panels
pdf("RATS_trajectories.pdf", 6, 5)
xyplot(weight~day, groups= ID2, data= rats, type= "b")
dev.off()

model1<- lm(weight ~ day, data= rats)
summary(model1)

pdf("RATS_model1_diagnostics.pdf", 6, 5)
par(mfrow= c(2, 2), mar= c(5.1, 4.1, 1.3, 1.1))
plot(model1)
dev.off()

# predict average rat size for each day from 5 to 40 days
model1.pred<- predict(model1, newdata= list(day= 5:40), se= T)

# plot fitted values (predicted mean growth for all rats)
pdf("RATS_weight~day_by_ratID.pdf", 5, 5)
xyplot(weight~day, groups= ID, data= rats, cex= 1.3, panel= function(...){
	panel.xyplot(...)
	panel.xyplot(5:40, model1.pred$fit + 1.96*model1.pred$se.fit, lwd= 3, lty= 2, type= "l", col= 1)
	panel.xyplot(5:40, model1.pred$fit - 1.96*model1.pred$se.fit, lwd= 3, lty= 2, type= "l", col= 1)
	panel.xyplot(5:40, model1.pred$fit, lwd= 3, lty= 1, type= "l", col= 1)
	})
dev.off()

# extract residuals
rats$resid1<- residuals(model1)
# sort rats by mean of residuals
sortedID<- names(sort(tapply(rats$resid1, rats$ID, mean)))
# boxplot of residuals by individual, sorted by increasing mean
pdf("RATS_resid1~ratID.pdf", 10, 6)
par(mfrow= c(1, 1), mar= c(5.1, 5.1, 1.3, 1.1))
plot(rats$resid1~factor(rats$ratID, levels= sortedID), xlab= "rat ID", ylab= "residuals(model1)", cex.lab= 1.8, cex.axis= 0.8, border= 1, lwd= 1.6, lty= 1)
abline(h= 0, lty= 2, lwd= 1.4)
dev.off()

pdf("RATS_weight~day_by_ratID_grid_SimpleRegression.pdf", 12, 5.5)
xyplot(weight~day|ID2, groups= ratID2, data= rats, cex= 1, layout= c(10, 3),
	panel= function(...){
		panel.xyplot(...)
		panel.abline(lm(rats$weight~rats$day), lwd= 2)
	})
dev.off()

############### fixed ratID effect ###############
# rats$ID<- factor(rats$ratID)
model2<- lm(weight ~ day + ID, data= rats)
summary(model2)

anova(model1)
anova(model2)

pdf("RATS_model2_diagnostics.pdf", 6, 5)
par(mfrow= c(2, 2), mar= c(5.1, 4.1, 1.3, 1.1))
plot(model2)
dev.off()

rats$resid2<- residuals(model2)
sortedID<- names(sort(tapply(rats$resid2, rats$ratID, mean)))

pdf("RATS_resid2~ratID.pdf", 10, 6)
par(mfrow= c(1, 1), mar= c(5.1, 5.1, 1.3, 1.1))
plot(rats$resid2~factor(rats$ratID, levels= sortedID), xlab= "ratID", ylab= "residuals(model2)", cex.lab= 1.8, cex.axis= 0.8, border= 1, lwd= 1.6, lty= 1)
abline(h= 0, lty= 2, lwd= 1.4)
dev.off()

# plot model predictions for all days from 5 to 40 days old
pdf("RATS_weight~day_by_ratID_model2.pdf", 5, 5)
xyplot(weight~day, groups= ID, data= rats, cex= 1.3, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, cex= 2)
	for(k in unique(rats$ID)){
		panel.xyplot(5:40, predict(model2, newdata= data.frame(day= 5:40, ID= k)), col= grey(0.7), type= "l")
    }
})
dev.off()

########## distribution of intercepts for individual rats: plot the histogram
# extract model coefficients
model2.coef<- model2
model2.coef # same coefficients as given by summary(model2)
model2.coef[1] # intercept for individual 1
model2.coef[2] # slope for all individuals
model2.coef[3:31] # difference in intercepts between individuals 2 to 30 and individual 1
model2.coef[1] + model2.coef[3:31] # intercepts for individuals 2 to 30
All.inter.M2<- c(model2.coef[1], model2.coef[1] + model2.coef[3:31]) # intercepts for all individuals

# a quicker way to get this is to re-fit the model without a general intercept
model2.coef.alt<- coef(lm(weight ~ day + ID - 1, data= rats))
model2.coef.alt
All.inter.M2<- model2.coef.alt[-1] # remove the slope

# histogram of intercepts for all individuals
pdf("RATS_model2_coefs_histogram.pdf", 5, 5)
hist(All.inter.M2, nclass= 20, xlab= "individual intercept estimate", main= "model2")
dev.off()

###################### Analysis with Mixed Effects models ######################
###################### (also called random effects models) ######################

############### model with random ratID intercept ###############
model3<- lme(weight ~ day, random= ~1|ID, data= rats)
summary(model3)
anova(model2)
anova(model3)

# conventional plots similar to plot.lm
pdf("RATS_model3_diagnostics.pdf", 6, 5)
par(mfrow= c(2, 2), mar= c(5.1, 4.1, 1.3, 1.1))
plot(residuals(model3)~fitted(model3)); abline(h= 0, lty= 2)
qqnorm(residuals(model3)); qqline(residuals(model3))
hist(residuals(model3))
dev.off()

# Also need to check the assumption of normality of the random intercepts
pdf("RATS_model3_normality_of_random_effects.pdf", 5, 4)
par(mfrow= c(1, 1), mar= c(5.1, 5.1, 1.3, 1.1))
model3.ranef<- ranef(model3)
qqnorm(unlist(model3.ranef))
qqline(unlist(model3.ranef), col= "red")
dev.off()

# boxplot of residuals by individual
rats$resid3<- residuals(model3, level= 1)
sortedID<- names(tapply(rats$resid3, rats$ratID, mean))
pdf("RATS_resid3~ratID.pdf", 10, 6)
par(mfrow= c(1, 1), mar= c(5.1, 5.1, 1.3, 1.1))
plot(rats$resid3~factor(rats$ratID, levels= sortedID), xlab= "ratID", ylab= "residuals(model3, level= 1)", cex.lab= 1.8, cex.axis= 0.8, border= 1, lwd= 1.6, lty= 1)
abline(h= 0, lty= 2, lwd= 1.4)
dev.off()

### plot predictions of models at population and individual levels
# a trick to get standard errors on predicted values (predict.lme doesn't give this)
library(mgcv)
model3.pred<- predict(gamm(weight ~ day, random= list(ID= ~1), data= rats)$gam, newdata= data.frame(day= 5:40, ID= "1"), se= T)

pdf("RATS_weight~day_by_ratID_model3.pdf", 5, 5)
xyplot(weight~day, groups= ID, data= rats, cex= 1.3, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, col= 1, cex= 2)
	for(k in unique(rats$ID)){
		panel.xyplot(5:40, predict(model3, newdata= data.frame(day= 5:40, ID= k), level= 1), col= grey(0.7), type= "l")}
	panel.xyplot(5:40, model3.pred$fit, lwd= 3, lty= 1, type= "l", col= 1)
	panel.xyplot(5:40, model3.pred$fit + 1.96*model3.pred$se.fit, lwd= 3, lty= 2, type= "l", col= 1)
	panel.xyplot(5:40, model3.pred$fit - 1.96*model3.pred$se.fit, lwd= 3, lty= 2, type= "l", col= 1)
	})
dev.off()

# illustrating level-1 and level-0 residuals
pdf("RATS_resid3~ratID~level.pdf", 10, 10)
par(mfrow= c(2, 1), mar= c(4.3, 5.1, 0.2, 1.1))
plot(residuals(model3, level= 1)~rats$ID, xlab= "", ylab= "residuals(model3, level= 1)", cex.lab= 1.8, cex.axis= 0.8, border= 1, lwd= 1.6, lty= 1)
abline(h= 0, lty= 2, lwd= 1.4)
plot(residuals(model3, level= 0)~rats$ID, xlab= "ratID", ylab= "residuals(model3, level= 0)", cex.lab= 1.8, cex.axis= 0.8, border= 1, lwd= 1.6, lty= 1)
abline(h= 0, lty= 2, lwd= 1.4)
dev.off()

#### model selection
model0.ML<- lme(weight ~ 1, random= ~1|ID, data= rats, method= "ML")
model3.ML<- update(model3, method= "ML")
anova(model3.ML, model0.ML)

model1.REML<- gls(weight ~ day, data= rats, method= "REML")
anova(model1.REML, model3)

### repeating model 3 after centering the 'day' variable

# centering the day variable around its mean (mean is 22)
rats$day.ct<- rats$day - mean(rats$day) # mean of day.ct is now 0

rats<- groupedData(weight~day.ct|ID, data= rats)
model3ct<- lme(weight ~ day.ct, random= ~1|ID, data= rats)
summary(model3ct)
plot(rats)
plot(augPred(model3ct))

model3ct.ranef<- ranef(model3ct)
qqnorm(unlist(model3ct.ranef))
qqline(unlist(model3ct.ranef), col= "red")

intervals(model3ct)

##################### what if both the slope and the intercept vary among individuals?
############### fixed day*ratID effect ###############
rats$day.ct<- rats$day - mean(rats$day) # mean is 22
model3<- lm(weight ~ day.ct * ID - 1, data= rats)
anova(model2)
anova(model3)

pdf("RATS_model3_diagnostics.pdf", 6, 5)
par(mfrow= c(2, 2), mar= c(5.1, 4.1, 1.3, 1.1))
plot(model3)
dev.off()

plot(rats$day.ct, rats$weight, col= trecols30[rats$ratID])
for(i in unique(rats$ID)){
	lines(5:40-22, predict(model3, newdata= data.frame(day.ct= 5:40-22, ID= i)), col= trecols30[as.numeric(i)])
}

pdf("RATS_weight~day_by_ratID_model3.pdf", 5, 5)
xyplot(weight~day.ct, groups= ID, data= rats, cex= 1.3, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, col= trecols30[groups[subscripts]], cex= 2)
	for(i in unique(rats$ID)){
		panel.xyplot(5:40-22, predict(model3, newdata= data.frame(day.ct= 5:40-22, ID= i)), col= trecols30[as.numeric(i)], type= "l")}
	})
dev.off()

rats$resid3<- residuals(model3)
sortedID<- names(sort(tapply(rats$resid3, rats$ratID, mean)))

pdf("RATS_resid3~ratID.pdf", 10, 6)
par(mfrow= c(1, 1), mar= c(5.1, 5.1, 1.3, 1.1))
plot(rats$resid3~factor(rats$ratID, levels= sortedID), xlab= "ratID", ylab= "residuals(model3)", cex.lab= 1.8, cex.axis= 0.8, border= rep(trellis.par.get()$superpose.symbol$col, l= 30)[as.numeric(sortedID)], lwd= 1.6, lty= 1)
abline(h= 0, lty= 2, lwd= 1.4)
dev.off()

################################# shrinkage effect ####################################
################# RATS data ###################
rats<- groupedData(weight~day.ct|ID, data= rats)
summary(lmList(rats))
rats.RI.fix<- coef(lm(weight~day.ct+ID-1, data= rats))[-1]
rats.RI.rnd<- unlist(ranef(lme(weight~day.ct, random= ~1|ID, data= rats))+fixef(lme(weight~day.ct, random= ~1|ID, data= rats))[1])
pdf("RATS_RI_shrinkage.pdf", 4, 4.5)
plot(rats.RI.fix, rats.RI.rnd, asp= 1, xlab= "RATS fixed intercept", ylab= "RATS random intercept", main= "RATS data")
abline(0,1)
abline(v= mean(rats.RI.fix), h= mean(rats.RI.rnd), lty= 2)
dev.off()

### random intercept AND slope
rats.RIS<- lme(weight~day.ct, random= ~day.ct|ID, data= rats)
rats.RIS.fix<- coef(lmList(rats))
rats.RIS.rnd<- t(t(ranef(rats.RIS))+fixef(rats.RIS))
VarCorr(rats.RIS)
# ID = pdLogChol(day.ct)
#             Variance    StdDev     Corr
# (Intercept) 203.1651463 14.2536012 (Intr)
# day.ct        0.2606718  0.5105603 0.668
# Residual     36.1754121  6.0145999

pdf("RATS_RIS_shrinkage.pdf", 4, 4.5)
plot(rats.RIS.fix[, 1], rats.RIS.fix[, 2], col= grey(0.7), main= "RATS data", xlab= "(Intercept)", ylab= "day.ct coefficient")
abline(h= fixef(rats.RIS)[2], v= fixef(rats.RIS)[1], lty= 2)
segments(x0= rats.RIS.fix[, 1], y0= rats.RIS.fix[, 2], x1= rats.RIS.rnd[, 1], y1= rats.RIS.rnd[, 2])
points(rats.RIS.fix, pch= 16, cex= 1.2, col= 2)
points(rats.RIS.rnd, pch= 16, cex= 1.2, col= 3)
points(rats.RIS.fix, pch= 1, cex= 1.2, col= 1)
points(rats.RIS.rnd, pch= 1, cex= 1.2, col= 1)
legend(0.2, 0.4, c("fixed effect", "random effect"), pch= 16, col= c(2, 3), bty= "n")
dev.off()

################# SHRINKAGE - RATS data - MISSING OBSERVATIONS ###################
# selectively remove some data from the rats data set
subs1<- rats$ID %in% c(2, 9, 3) & rats$day < 16
subs2<- rats$ID %in% c(24, 15) & rats$day > 25
rats2<- rats[!(subs1 | subs2), ]
rats2<- groupedData(weight~day.ct|ID, data= rats2, order.group= F)
plot(rats2)

rats.RIS.2<- lme(weight~day.ct, random= ~day.ct|ID, data= rats2)
rats.RIS.2.fix<- coef(lmList(rats2))
rats.RIS.2.rnd<- t(t(ranef(rats.RIS.2))+fixef(rats.RIS.2))

pdf("RATS_RIS_shrinkage_unbalanced.pdf", 8, 4.5)
par(mfrow= c(1, 2))
plot(rats.RIS.fix[, 1], rats.RIS.fix[, 2], col= grey(0.7), main= "RATS data", xlab= "(Intercept)", ylab= "day.ct", ylim= c(4.5, 7.5), xlim= c(210, 290))
abline(h= fixef(rats.RIS)[2], v= fixef(rats.RIS)[1], lty= 2)
segments(x0= rats.RIS.fix[, 1], y0= rats.RIS.fix[, 2], x1= rats.RIS.rnd[, 1], y1= rats.RIS.rnd[, 2])
points(rats.RIS.fix, pch= 16, cex= 1.2, col= 2)
points(rats.RIS.rnd, pch= 16, cex= 1.2, col= 3)
points(rats.RIS.fix, pch= 1, cex= 1.2, col= 1)
points(rats.RIS.rnd, pch= 1, cex= 1.2, col= 1)
points(rats.RIS.fix[c("2", "9", "3", "24", "15"), ], pch= 1, cex= 2.5, col= 1)
points(rats.RIS.rnd[c("2", "9", "3", "24", "15"), ], pch= 1, cex= 2.5, col= 1)
legend(0.2, 0.4, c("fixed effect", "random effect"), pch= 16, col= c(2, 3), bty= "n")
plot(rats.RIS.2.fix[, 1], rats.RIS.2.fix[, 2], col= grey(0.7), main= "RATS data\nwith missing observations", xlab= "(Intercept)", ylab= "day.ct", ylim= c(4.5, 7.5), xlim= c(210, 290))
abline(h= fixef(rats.RIS.2)[2], v= fixef(rats.RIS.2)[1], lty= 2)
segments(x0= rats.RIS.2.fix[, 1], y0= rats.RIS.2.fix[, 2], x1= rats.RIS.2.rnd[, 1], y1= rats.RIS.2.rnd[, 2])
points(rats.RIS.2.fix, pch= 16, cex= 1.2, col= 2)
points(rats.RIS.2.rnd, pch= 16, cex= 1.2, col= 3)
points(rats.RIS.2.fix, pch= 1, cex= 1.2, col= 1)
points(rats.RIS.2.rnd, pch= 1, cex= 1.2, col= 1)
points(rats.RIS.2.fix[c("2", "9", "3", "24", "15"), ], pch= 1, cex= 2.5, col= 1)
points(rats.RIS.2.rnd[c("2", "9", "3", "24", "15"), ], pch= 1, cex= 2.5, col= 1)
legend(0.2, 0.4, c("fixed effect", "random effect"), pch= 16, col= c(2, 3), bty= "n")
dev.off()

################# SHRINKAGE - RIKZ data ###################
###################### analysis of RIKZ data with random intercepts #######################
rikz<- read.delim("RIKZRichness.txt")
rikz$logR<- log(rikz$R+1)
rikz$Fbeach<- factor(rikz$Beach)
plot(logR ~ Fbeach, data= rikz)
rikz<- groupedData(logR~NAP|Fbeach, data= rikz)

summary(lmList(rikz))
rikz.RI.fix<- coef(lm(logR~NAP+Fbeach-1, data= rikz))[-1]
rikz.RI.fix.missingvals<- coef(lm(logR~NAP+Fbeach-1, data= rikz2))[-1]
rikz.RI.rnd<- unlist(ranef(lme(logR~NAP, random= ~1|Fbeach, data= rikz))+fixef(lme(logR~NAP, random= ~1|Fbeach, data= rikz))[1])
rikz.RI.rnd.missingvals<- unlist(ranef(lme(logR~NAP, random= ~1|Fbeach, data= rikz2))+fixef(lme(logR~NAP, random= ~1|Fbeach, data= rikz2))[1])
pdf("RIKZ_RI_shrinkage.pdf", 4, 4.5)
plot(rikz.RI.fix, rikz.RI.rnd, asp= 1, xlab= "RIKZ fixed intercept", ylab= "RIKZ random intercept", main= "RIKZ data")
abline(0,1)
abline(v= mean(rikz.RI.fix), h= mean(rikz.RI.rnd), lty= 2)
dev.off()

###################### analysis of RIKZ data with random intercepts and slopes #######################
rikz.RIS<- lme(logR~NAP, random= ~NAP|Fbeach, data= rikz)
rikz.RIS.fix<- coef(lmList(rikz))
rikz.RIS.rnd<- t(t(ranef(rikz.RIS))+fixef(rikz.RIS))
VarCorr(rikz.RIS)
# Fbeach = pdLogChol(NAP)
#             Variance   StdDev    Corr
# (Intercept) 0.18101478 0.4254583 (Intr)
# NAP         0.06461363 0.2541921 -0.066
# Residual    0.10945315 0.3308370

NAP.seq<- seq(-1.3, 2.3, l= 20)
model.rikz.RIS.pred<-predict(rikz.RIS, newdata= data.frame(NAP= NAP.seq, Fbeach= 1), level= 0)

cb.colors2<- c("#000000", "#009E73", "#e79f00", "#9ad0f3", "#0072B2", "#D55E00",
    "#CC79A7", "#F0E442", "#555555")
pdf("RIKZrichness~NAP_by_Beach_rikzRIS.pdf", 5, 5)
xyplot(logR~NAP, groups= Fbeach, data= rikz, cex= 1.3, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, col= cb.colors2[groups[subscripts]], cex= 2)
	for(k in unique(rikz$Fbeach)){
		panel.xyplot(NAP.seq, predict(rikz.RIS, newdata= data.frame(NAP= NAP.seq, Fbeach= k), level= 1), col= cb.colors2[as.numeric(k)], type= "l")}
	panel.xyplot(NAP.seq, model.rikz.RIS.pred, lwd= 3, lty= 1, type= "l", col= 1)
	})
dev.off()

par(mfrow= c(1, 2))
hist(ranef(rikz.RIS)$'(Intercept)', nclass= 20, main= "random intercept", xlab= "")
abline(v= 0, lwd= 3, col= 1, lty= 2)
hist(ranef(rikz.RIS)$NAP, nclass= 20, main= "random slope", xlab= "")
abline(v= 0, lwd= 3, col= 1, lty= 2)

plot(ranef(rikz.RIS)$'(Intercept)', ranef(rikz.RIS)$NAP)

pdf("RIKZ_RIS_shrinkage2.pdf", 4, 4.5)
plot(rikz.RIS.fix[, 1], rikz.RIS.fix[, 2], col= grey(0.7), main= "RIKZ data", xlab= "(Intercept)", ylab= "NAP coefficient")
abline(h= fixef(rikz.RIS)[2], v= fixef(rikz.RIS)[1], lty= 2)
segments(x0= rikz.RIS.fix[, 1], y0= rikz.RIS.fix[, 2], x1= rikz.RIS.rnd[, 1], y1= rikz.RIS.rnd[, 2])
points(rikz.RIS.fix, pch= 16, cex= 1.2, col= 2)
points(rikz.RIS.rnd, pch= 16, cex= 1.2, col= 3)
points(rikz.RIS.fix, pch= 1, cex= 1.2, col= 1)
points(rikz.RIS.rnd, pch= 1, cex= 1.2, col= 1)
legend(0.2, 0.4, c("fixed effect", "random effect"), pch= 16, col= c(2, 3), bty= "n")
dev.off()

#######################################################
################# random slopes models ################
#######################################################
rats<- groupedData(weight ~ day.ct|ID, data= rats)
model10.lm<- lmList(rats)
summary(model10.lm)
plot(model10.lm)

rats$day.ct2<- rats$day.ct^2

model10.lme<- lme(weight ~ day.ct, random= ~ day.ct|ID, data= rats)
summary(model10.lme)

plot(augPred(model10.lme), aspect="xy", grid=T)

model10.lme.pred<-predict(model10.lme, newdata= data.frame(day.ct= 5:40-22, ID= "1"), level= 0)

pdf("RATS_weight~day_by_ratID_model10lme.pdf", 5, 5)
xyplot(weight~day, groups= ID, data= rats, cex= 1.3, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, col= trecols30[groups[subscripts]], cex= 2)
	for(k in unique(rats$ID)){
		panel.xyplot(5:40, predict(model10.lme, newdata= data.frame(day.ct= 5:40-22, ID= k), level= 1), col= trecols30[as.numeric(k)], type= "l")}
	panel.xyplot(5:40, model10.lme.pred, lwd= 3, lty= 1, type= "l", col= 1)
	})
dev.off()

par(mfrow= c(1, 2))
hist(ranef(model10.lme)$'(Intercept)', nclass= 20, main= "random intercept", xlab= "")
abline(v= 0, lwd= 3, col= 1, lty= 2)
hist(ranef(model10.lme)$day.ct, nclass= 20, main= "random slope", xlab= "")
abline(v= 0, lwd= 3, col= 1, lty= 2)

plot(ranef(model10.lme)$'(Intercept)', ranef(model10.lme)$day.ct)

model11<- lme(weight ~ day.ct + day.ct2, random= ~ day.ct + day.ct2|ID, data= rats)
summary(model11)

plot(augPred(model11), aspect="xy", grid=T)
plot(model11)

################### Fixed slopes models - RIKZ and RATS ########################
pdf("RATS_RIKZ_FIS.pdf", 7, 4)
par(mfrow= c(1, 2))
model3<- lm(weight ~ day.ct * ID - 1, data= rats)
plot(rats$day.ct, rats$weight, col= trecols30[rats$ratID], xlab= "day.ct", ylab= "weight")
for(i in unique(rats$ID)){
	lines(5:40-22, predict(model3, newdata= data.frame(day.ct= 5:40-22, ID= i)), col= trecols30[as.numeric(i)])
}

modelrikz3<- lm(logR ~ NAP * Fbeach - 1, data= rikz)
plot(rikz$NAP, rikz$logR, col= cb.colors2[rats$ratID], xlab= "NAP", ylab= "logR")
for(i in unique(rikz$Fbeach)){
	lines(NAP.seq, predict(modelrikz3, newdata= data.frame(NAP= NAP.seq, Fbeach= i)), col= cb.colors2[as.numeric(i)])
}
dev.off()

################### Random slopes models - RIKZ and RATS ########################
pdf("RATS_RIKZ_RIS.pdf", 8, 4)
plot1<- xyplot(weight~day, groups= ID, data= rats, cex= 1, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, col= trecols30[groups[subscripts]], cex= 1)
	for(k in unique(rats$ID)){
		panel.xyplot(5:40, predict(model10.lme, newdata= data.frame(day.ct= 5:40-22, ID= k), level= 1), col= trecols30[as.numeric(k)], type= "l")}
	panel.xyplot(5:40, model10.lme.pred, lwd= 3, lty= 1, type= "l", col= 1)
	})
plot2<- xyplot(logR~NAP, groups= Fbeach, data= rikz, cex= 1, panel= function(x,y,groups,subscripts){
	panel.xyplot(x,y, col= cb.colors2[groups[subscripts]], cex= 1)
	for(k in unique(rikz$Fbeach)){
		panel.xyplot(NAP.seq, predict(rikz.RIS, newdata= data.frame(NAP= NAP.seq, Fbeach= k), level= 1), col= cb.colors2[as.numeric(k)], type= "l")}
	panel.xyplot(NAP.seq, model.rikz.RIS.pred, lwd= 3, lty= 1, type= "l", col= 1)
	})
print(plot1, split = c(1, 1, 2, 1), more = TRUE)
print(plot2, split = c(2, 1, 2, 1), more = FALSE)
dev.off()

############### marginal model version with gls ###############
model4<- gls(weight ~ day, correlation= corCompSymm(form= ~1|ID), data= rats)
summary(model4)


# Group members (Name, Student ID, E-Mail):
# 1. Baldomero Valdez,  Valenzuela, 2905175, baldmer.w@gmail.com
# 2. Omar Trinidad Gutierrez Mendez, 2850441, omar.vpa@gmail.com
# 3. Shinho Kang, 2890169, wis.shinho.kang@gmail.com

# size for testing: default 150
size = 150

# -----------------------------------------------------------------------------
# assignment a
# Implemented in two ways - using dist(), and using self-created function
# RESULT: results of both ways are exactly same.

# function for calculating Euclidean Distance
euclidean_distance <- function(p, q) {
    ed = 0
    for (i in 1:4) {
        ed <- ed + (p[,i] - q[,i]) ^ 2
    }
    ed <- sqrt(ed)
    return(ed)
}

data(iris) #load iris data
iris2 <- iris[-5] # delete column 5 with string
# compute distances using dist() function
distances <- as.matrix(dist(head(iris2, size)))
# print(distances)

# compute distances using self-created function
distances2 <- matrix(nrow=size, ncol=size)
for (p in 1:size) {
  for (q in 1:size) {
    row_p = iris2[p,]
    row_q = iris2[q,]
    distances2[p, q] <- euclidean_distance(row_p, row_q)
  }
}
# print(distances2)

# -----------------------------------------------------------------------------
# assignment b
# data frame

Flower = c()
Species = c()
Nearest.neighbor = c()
NN.species = c()

for (i in 1:size) {
    Flower[i] <- i
    Species[i] <- levels(iris$Species)[iris[i, 5]] # convert the factor to string

    # find the nearest neighbor using sort
    line = distances2[i,]
    index_nn = order(line[-i])[1]
    print (order(line))
    # nn = sort(line)[2] # first one is itself, so choose 2
    # index_nn = which(line == nn)
    Nearest.neighbor[i] <- index_nn
    NN.species[i] <- levels(iris$Species)[iris[index_nn, 5]]
}

data_frame = data.frame(Flower, Species, Nearest.neighbor, NN.species)
#print(data_frame)
write.csv(data_frame, file = "EX_B_distance.csv")

# -----------------------------------------------------------------------------
# assignment c
percent.matrix.x <- table(data_frame$Species, data_frame$NN.species)

cc = table ( data_frame$Species, data_frame$NN.species ) [,]
write.csv(cc, file = "EX_C_distance_3x3.csv")

# -----------------------------------------------------------------------------
# assignment d
# print (cc)
par(mfrow=c())
barplot(cc, main="Number of Nearest Neighbors", xlab="Species", ylab="Numbers", col=c("darkblue", "red", "gray"), legend = rownames(cc), beside=TRUE)

# -----------------------------------------------------------------------------
# assignment e. histograms

par(mfrow=c(3, 4))

# setosa

setosa <- iris[iris$Species == 'setosa',]

hist(setosa$Sepal.Length, col="Tomato", main="Setosa Sepal.Length", xlab="Sepal Length")
hist(setosa$Sepal.Width, col="Tomato", main="Setosa Sepal.Width", xlab="Sepal Width")
hist(setosa$Petal.Length, col="Tomato", main="Setosa Petal.Length", xlab="Petal Length")
hist(setosa$Petal.Width, col="Tomato", main="Setosa Petal.Width", xlab="Petal Width")

# versicolor

versicolor <- iris[iris$Species == 'versicolor',]

hist(versicolor$Sepal.Length, col="Violet", main="Versicolor Sepal.Length", xlab="Sepal Length")
hist(versicolor$Sepal.Width, col="Violet", main="Versicolor Sepal.Width", xlab="Sepal Width")
hist(versicolor$Petal.Length, col="Violet", main="Versicolor Petal.Length", xlab="Petal Length")
hist(versicolor$Petal.Width, col="Violet", main="Versicolor Petal.Width", xlab="Petal Width")

# virginica

virginica <- iris[iris$Species == 'virginica',]

hist(virginica$Sepal.Length, col="Turquoise", main="Virginica Sepal.Length", xlab="Sepal Length")
hist(virginica$Sepal.Width, col="Turquoise", main="Virginica Sepal.Width", xlab="Sepal Width")
hist(virginica$Petal.Length, col="Turquoise", main="Virginica Petal.Length", xlab="Petal Length")
hist(virginica$Petal.Width, col="Turquoise", main="Virginica Petal.Width", xlab="Petal Width")

# -----------------------------------------------------------------------------
# assignment f.

# A histogram visualizes a distribution of numerical data. The y-axis shows how
# frequently the values on the x-axis occur in the data, the bars represent
# ranges of values on the x-axis.
#
# ---
#
#   Figures description
#
# ---
#
#   Setosa Sepal.Length
#
# It is observed that the higher frequencies are defined between the range of 4.5 - 5.5,
# having a maximum frequency approximately of 15 units.
#
#   Versicolor Sepal.Length
#
# This figure shows a maximum frequency of approximately 20 units for Sepal lengths between
# the range 5.5. and 6.0.
#
#   Virginica Sepal.Length
#
# Higher frequencies are defined between the range of 6.0 - 6.5, with a frequency of approximately
# of 20 units. There is an evenly distribution for values between the range of 7.0 - 8.0,
# furthermore there are no Sepals with lengths in a range of 5.0 - 5.5.
#
# ---
#
#   Setosa Sepal.Width
#
# The frequency reach its maximum of approximately 25 units for values defined between the range 3.0 - 3.5
# and its minimum between 2.0 - 2.5.
#
#   Versicolor Sepal.Width
#
# Increasing distribution of frequencies is observed between the range 2.0 - 3.0, reaching a maximum
# of approximately 15 units between the range 2.8 - 3.0.
#
#   Virginica Sepal.Width
#
# This figure shows a maximum frequencies of approximately 15 units for widths between 2.5 and 3.0.
#
# ----
#
#   Setosa Petal.Length
#
# An evenly minimal distribution of frequencies is observed for lengths between the range 1.0 - 1.2
# and greater than 1.8, the frequencies reach its maximum at a length of around
# 1.4 with approximately 15 units.
#
#   Versicolor Petal.Length
#
# It is observed that the maximum frequency is reached between the range of 4.0 - 4.5 with a frequency
# of a approximately 20 units, whereas the minimum length is between 5.0 - 5.5 with a a frequency of 1 unit.
#
#   Virginica Petal.Length
#
# One can observe that the maximum frequency is evenly distributed for ranges 5.0 - 5.5 and 5.5 - 6.0 with
# a maximum frequency of approximately 15 units.
#
# ---
#
#   Setosa Petal.Width
#
# Most of the values of petal width are defined at its very minimum between the range 0.1 - 0.2 with
# a frequency of approximately 35 units, the minimum is defined between the range 0.4 - 0.6.
#
#   Versicolor Petal.Width
#
# The minimum frequency is defined between the range 1.6 - 1.8, whereas the maximum is defined
# for widths of 1.2 or 1.3 with a frequency of approximately 15 units.
#
#   Virginica Petal.Width
#
# Most of the frequencies are almost evenly distributed between the range 1.6 - 2.4, reaching their
# maximum between the range 1.6 - 1.8.
#
# ---
#
#   General Comparison
#
# Among the three groups of species, Virginica has the higher Sepal lengths frequency for values
# between 6.0 ??? 6.5 and Satosa has the maximum Sepal widths for values between 3.0 and 3.5.
#
# On the other side, Setosa specie presents the minimum Petal lengths with values between 1.0 - 1.8,
# on the contrary, Virginica has the maximum petal lengths between the range 5.0 -  6.0. It is clear
# to notice that species of type Setosa have the minimum widths of Petals.


i <- 1024L
while(i > 0)
{
   print(i)
   i <- i %/% 2
}