# 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))


# 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)
}


# ......................................................................................
# ..............................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)


# 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)
 }


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


# 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.


#' Principal Components Analysis
#'
#' @param data.mat Input data matrix
#'
#' @return Object of class tomPCA with rotation and x data
#' @export
#'
#' @examples
#' test.matrix = matrix(
#'    c(2, 4, 3, 1, 5, 7),
#'    nrow=3,
#'    ncol=2)
#'
#' pca.obj = PCA(test.matrix)
PCA = function(data.mat)
{
  # Scale data
  scaled.mat = scale(data.mat, scale = FALSE)

  # Run SVD on scaled data
  sm.svd = base::svd(scaled.mat)

  # Get x mat
  x.mat = sm.svd$u %*% diag(sm.svd$d)
  rot.mat = sm.svd$v

  # Return rotation and x
  return(structure(list(rotation = rot.mat, x = x.mat), class = "tomPCA"))
}


n<-100
w<-1; a1<-runif(n, min = w*0.5, max = w*1.5)
w<-2; a2<-runif(n, min = w*0.5, max = w*1.5)
w<-3; a3<-runif(n, min = w*0.5, max = w*1.5)

if (T) {
  sd2<-0.2
  w<-1; a1<-rnorm(n, mean = w, sd =sd2)
  w<-2; a2<-rnorm(n, mean = w, sd = sd2)
  w<-3; a3<-rnorm(n, mean = w, sd = sd2)
}

ww<-c(a1,a2,a3)
a<-1.2
b<-0.66
h<-data.frame(w=rep(1:3,each=n),wobs=ww,cons=a*ww^b)
cleanup()
plot(x=h$w,y=h$cons)
lines(x=h$wobs,y=h$cons,type='p',col='red')

plot(x=log(h$wobs),y=log(h$cons))

aa<-lm(log(cons)~log(wobs),data=h)

h$predict<-predict(aa)
plot(x=log(h$wobs),y=log(h$cons))
lines(x=log(h$w),y=log(h$cons),col='red',type='p')
abline(aa)

plot(x=h$wobs,y=(h$cons))

co<-coef(aa)
h$pred2<-exp(co[1])*h$wobs^co[2]
lines(x=h$wobs,y=h$pred2,col='red',type='p')
summary(aa)
cat("a:",a," b:",b,"\n")
cat("estimated a:",exp(co[1])," b:",co[2],"\n")


# this is the modelfile for separate meta-analysis
# for humerus and femur data
# the two meta-analyses are run in the same file to allow easy
# construction of results
#

model {

#### Humerus data
    for(k1 in 1:K.hum) {

        # observational part of the model
        x.down.1dot[k1] ~ dbin(p.down.1dot[k1], N.down.hum[k1])
        x.nodown.1dot[k1] ~ dbin(p.nodown.1dot[k1], N.nodown.hum[k1])

        p.down.1dot[k1] <- ilogit(eta.xi.hum[k1, 1])
        p.nodown.1dot[k1] <- ilogit(eta.xi.hum[k1, 2])

        # structural part of the model
        eta.xi.hum[k1, 1:2] ~dmnorm(Eta.Xi.hum[1:2], Omega.hum)

    }

    # prior for mean -- independent vague priors suffice
    #                -- otherwise, mvnormal with vague Wishart
    Eta.Xi.hum[1] ~ dnorm(mu0.hum[1], prec.mu0.hum[1])
    Eta.Xi.hum[2] ~ dnorm(mu0.hum[2], prec.mu0.hum[2])

    # S.hum is a diagonal matrix of sd's
    S.hum[1,1] ~ dunif(s.lower.hum[1], s.upper.hum[1])  # or use inverse gamma
    S.hum[2,2] ~ dunif(s.lower.hum[2], s.upper.hum[2])
    S.hum[1,2] <- 0
    S.hum[2,1] <- S.hum[1,2]

    # R.hum is a correlation matrix
    R.hum[1,1] <- 1
    R.hum[2,2] <- 1
    R.hum[1,2] ~ dunif(r.lower.hum[1], r.upper.hum[1])  # or use atanh
    R.hum[2,1] <- R.hum[1,2]

    # Factorize
    Tau.hum <- S.hum %*% R.hum %*% S.hum
    Omega.hum <- inverse(Tau.hum)

#### Femur data
    for(k2 in 1:K.fem) {

        # observational part of the model
        x.down.dot1[k2] ~ dbin(p.down.dot1[k2], N.down.fem[k2])
        x.nodown.dot1[k2] ~ dbin(p.nodown.dot1[k2], N.nodown.fem[k2])

        p.down.dot1[k2] <- ilogit(eta.xi.fem[k2, 1])
        p.nodown.dot1[k2] <- ilogit(eta.xi.fem[k2, 2])

        # structural part of the model
        eta.xi.fem[k2, 1:2] ~dmnorm(Eta.Xi.fem[1:2], Omega.fem)

    }

    # prior for mean -- independent vague priors suffice
    #                -- otherwise, mvnormal with vague Wishart
    Eta.Xi.fem[1] ~ dnorm(mu0.fem[1], prec.mu0.fem[1])
    Eta.Xi.fem[2] ~ dnorm(mu0.fem[2], prec.mu0.fem[2])

    # S.fem is a diagonal matrix of sd's
    S.fem[1,1] ~ dunif(s.lower.fem[1], s.upper.fem[1])  # or use inverse gamma
    S.fem[2,2] ~ dunif(s.lower.fem[2], s.upper.fem[2])
    S.fem[1,2] <- 0
    S.fem[2,1] <- S.fem[1,2]

    # R.fem is a correlation matrix
    R.fem[1,1] <- 1
    R.fem[2,2] <- 1
    R.fem[1,2] ~ dunif(r.lower.fem[1], r.upper.fem[1])  # or use atanh
    R.fem[2,1] <- R.fem[1,2]

    # Factorize
    Tau.fem <- S.fem %*% R.fem %*% S.fem
    Omega.fem <- inverse(Tau.fem)

    # Data to report
    tpr.hum <- ilogit(Eta.Xi.hum[1])
    fpr.hum <- ilogit(Eta.Xi.hum[2])

    tpr.fem <- ilogit(Eta.Xi.fem[1])
    fpr.fem <- ilogit(Eta.Xi.fem[2])

    diff.tpr <- tpr.hum - tpr.fem
    diff.fpr <- fpr.hum - fpr.fem

    or.tpr <- exp(Eta.Xi.hum[1]-Eta.Xi.fem[1])
    or.fpr <- exp(Eta.Xi.hum[2]-Eta.Xi.fem[2])

    diff.eta <- Eta.Xi.hum[1]-Eta.Xi.fem[1]
    diff.xi <- Eta.Xi.hum[2]-Eta.Xi.fem[2]

}


#'@title calcAbt
#'
#'@description Estimate transverse bulb area (\code{Abt}) (m^2) using method in
#'Rakke (2016).
#'
#'@param Cm Midship area coefficient (dimensionless) (see \code{\link{calcCm}})
#'@param breadth Moulded breadth (m)
#'@param actualDraft Actual draft (m)
#'
#'@details
#'Transverse sectional area of the bulb at the position where the still-water
#'surface intersects the stem (m^2) using actual draft. Actual draft is
#'typically obtained from sources such as AIS messages or ship records.
#'
#'@return \code{Abt} (vector of numericals, m^2)
#'
#'@references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29. p. 166-170
#'
#'\href{http://hdl.handle.net/11250/2410741}{Rakke, S. G. 2016. "Ship
#'Emissions Calculation from AIS." NTNU}
#'
#'@seealso \code{\link{calcCm}}
#'
#'@examples
#'calcAbt(0.98, 32, 10)
#'calcAbt(c(0.98,0.99), c(32,45.5), c(10,15.5))
#'
#'@export

calcAbt <-function(Cm, breadth, actualDraft){

  Abt<-0.08*Cm*breadth*actualDraft

  return(Abt)
}


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

## simulation for PE exercise
## Values are from Harte (2017)
n.years <- 12
periods.per.year <- 4
dtime <- 1/periods.per.year
times <- seq(dtime, n.years, by=dtime)
mgmt.fee <- 0.02
invest.time.end <- max(times)
capital0 <- 100
fees <- capital0*mgmt.fee*dtime
investment0 <- capital0 - fees

rf <- 0.05

## drift/OU reversion parameters
#pe.alpha <- 0.04
mu.mkt <- 0.11
mu.delta <- 0.41
mu.nu <- 0.08
theta.pi <- 0.16; kappa.pi <- 0.42
pi0 <- theta.pi

## covariance parameters; some correlations differ from Harte (2017)
pe.beta <- 1.3
vol.delta <- 0.21*sqrt(dtime); vol.nu <- 0.11*sqrt(dtime); vol.pi <- 0.16*sqrt(dtime)
vol.mkt.sys <- 0.15*sqrt(dtime); vol.mkt.idio <- 0.35*sqrt(dtime)
corr.delta <- -0.3; corr.nu <- 0.8; corr.pi <- -0.3

cov.delta <- corr.delta*vol.delta*vol.mkt.sys
cov.nu    <- corr.nu*vol.nu*vol.mkt.sys
cov.pi    <- corr.pi*vol.pi*vol.mkt.sys
cov.mtx <- matrix(c(vol.delta^2,        0,        0,     cov.delta,       0,
                    0,           vol.nu^2,        0,        cov.nu,       0,
                    0,                  0, vol.pi^2,        cov.pi,       0,
                    cov.delta,     cov.nu,   cov.pi, vol.mkt.sys^2,       0,
                    0,                  0,        0,             0, vol.mkt.idio^2),
                  nrow=5)

## generate random variates
B.rvs <- mvrnorm(mu=rep(0, 5), Sigma=cov.mtx, n=n.years*periods.per.year)
colnames(B.rvs) <- c("B.delta", "B.nu", "B.pi", "B.mkt", "B.epsilon")

delta <- pmin(pmax(mu.delta*dtime + B.rvs[,"B.delta"], 0), 1)
nu <- pmin(pmax(mu.nu*times + B.rvs[,"B.nu"], 0), 1)
pi.ou <- c(pi0)
for (i in 2:length(times)) {
    pi.ou[i] <- pi.ou[i-1] + kappa.pi*(theta.pi - pi.ou[i-1])*dtime + B.rvs[i-1,"B.pi"]
}
dmkt <- mu.mkt*dtime + pe.beta*B.rvs[,"B.mkt"] + B.rvs[,"B.epsilon"]

## simulate the cashflows and value
drawdowns <- c(delta[1]*investment0)
rcvd.distn <- c(0)
value <- c(0)
for (i in 2:length(times)) {
    d.drawdowns <- delta[i]*(investment0 - drawdowns[i-1])*(times[i] < invest.time.end)
    drawdowns[i] <- drawdowns[i-1] + d.drawdowns
    d.rcvd.distn <- nu[i]*value[i-1]
    if (i < length(times)) {
        rcvd.distn[i] <- rcvd.distn[i-1] + d.rcvd.distn
        dvalue <- value[i-1]*dmkt[i-1] + d.drawdowns - d.rcvd.distn
    } else {
        rcvd.distn[i] <- rcvd.distn[i-1] + value[i-1]
        dvalue <- -value[i-1]
    }
    value[i] <- value[i-1] + dvalue
}


# Harmonic Series

# How We Got From There To Here:
# A Story of Real Analysis
# rate of convergence: page 130 - 132,
# Harmonic Series also appears on pages 56 and 150.
n <- 10^9
a <- 0
for (i in 1:n) {
a <- (a + (1/i))
}

a

n2 <- 10^4
a2 <- 0
for( i in 1:n2)
{
	a2 <- (a2 + (1/i))
}

a2

n3 <- 10 ^ 7
a3 <- 0
for(i in 1:n3)
{
	a3 <- (a3 + (1/i))
}

a3

n4 <- 100
a4 <- 0
for(i in 1:n4)
{
	a4 <- (a4 + (1/i))
}

print(a4)


 DSYGV Example Program Results

 Eigenvalues
       -2.2254    -0.4548     0.1001     1.1270

 Eigenvectors
             1          2          3          4
 1      0.0690    -0.3080    -0.4469     0.5528
 2      0.5740    -0.5329    -0.0371     0.6766
 3      1.5428     0.3496     0.0505     0.9276
 4     -1.4004     0.6211     0.4743    -0.2510

 Estimate of reciprocal condition number for B
        5.8E-03

 Error estimates for the eigenvalues
        9.3E-14    2.5E-14    1.1E-14    5.1E-14

 Error estimates for the eigenvectors
        1.0E-13    2.1E-13    1.8E-13    1.4E-13


#Regresion lineal

#se cargan los datos colocando como parametros que los decimales seran separados por un ","
data <- read.table("muestra_estudiantes.txt",header=TRUE)
data
#Nombre de columnas a ignorar para este experimento, calclulo de ignora pues es la salida deseada
drops <- c("cant_mat","escuela","gestion_plantel","tipo_plantel","nivel_socioeco","nivel_estudios_padres","genero","opsu")
#se descarta Cant_cats por tener correlacion poco significativa
data <- data[ , !(names(data) %in% drops)]
data
pairs(data)
cor(data)

y <- data[,6]
y
x <- data[,1:5]
x

x11()
par(mfrow=c(1,2))
plot(y,x[,1])
plot(y,x[,2])
x11()
par(mfrow=c(1,2))
plot(y,x[,3])
plot(y,x[,4])
x11()
par(mfrow=c(1,1))
plot(y,x[,5])
#
mod1 <- lm(y ~ x[,1] + x[,2] + x[,3] + x[,4] + x[,5])
#Analsis de Modelo
summary(mod1)

# Other useful functions
coefficients(mod1) # model coefficients
confint(mod1, level=0.95) # CIs for model parameters
fitted(mod1) # predicted values
residuals(mod1) # residuals
anova(mod1) # anova table
vcov(mod1) # covariance matrix for model parameters
influence(mod1) # regression diagnostics

resi = residuals(mod1)

#para la prueba de No normalidad
shapiro.test(residuals(mod1))

#para la prueba de Homogenidad de los datos
#crear un factor
library(Rcmdr)
fac=NULL
for(i in 1:6){
fac=c(fac,rep(i,21))}
fac
levene.test(resi, fac)

#Prueba de Aletoridad de los datos
secu=c(seq(1,126))

x11()
plot(secu,resi,col="red",type="l")
abline(h = 0, v = 0, lty = 2, col = 4)
# diagnostic plots
layout(matrix(c(1,2,3,4),2,2)) # optional 4 graphs/page
plot(mod1)

ECM <- mean(resi^2)
ECM


cal.rate <- function(N.lim, r.lim) {
    rate <- function(N, r) {
        p <- (1 + r) ^ N
        0.5*(1+N)*r /(p*N*r / (p-1) - 1)
    }
    N <- seq(N.lim[1], N.lim[2])
    r <- seq(r.lim[1], r.lim[2], length.out=diff(N.lim)+1)
    z <- outer(N, r, rate)
    list(N=N, r=r, z=z)
}

plot.rate <- function(d, col="lightblue",
    theta=30, phi=20,
    r=50,
    expand=0.5,
    ltheta=90, lphi=180,
    shade=0.75,
    nticks=5) {

    # sub=expression(italic(f)~(bold(x))==frac(1,2~pi~sqrt(sigma[11]~
    # sigma[22]~(1-rho^2)))~phantom(0)^bold(.)~exp~bgroup("{",
    # list(-frac(1,2(1-rho^2)),
    # bgroup("[", frac((x[1]~-~mu[1])^2, sigma[11])~-~2~rho~frac(x[1]~-~mu[1],
    # sqrt(sigma[11]))~ frac(x[2]~-~mu[2],sqrt(sigma[22]))~+~
    # frac((x[2]~-~mu[2])^2, sigma[22]),"]")),"}"))

    persp(d$N, d$r, d$z,
    xlab="N", ylab="r", zlab="z",
    main="Plot the rate ",
    # sub=sub,
    col="lightblue",
    theta=theta, phi=phi,
    r=r,
    expand=expand,
    ltheta=ltheta, lphi=lphi,
    shade=shade,
    ticktype="detailed",
    nticks=nticks) # produces the 3-D plot

    # mtext(expression(list(mu[1]==0,mu[2]==0,sigma[11]==10,sigma[22]==10,sigma[12]==15,rho==0.5)), side=3) # adding a text line to the graph
}

if (FALSE) {
    source("./src/cal.rate.r")
    d <- cal.rate(N.lim=c(1,120), r.lim=c(0, 0.01))
    plot.rate(d=d)

}


## Plotting Sierpinski triangle. aev 4/1/17
## ord - order, fn - file name, ttl - plot title, clr - color
pSierpinskiT <- function(ord, fn="", ttl="", clr="navy") {
  m=640; abbr="STR"; dftt="Sierpinski triangle";
  n=2^ord; M <- matrix(c(0), ncol=n, nrow=n, byrow=TRUE);
  cat(" *** START", abbr, date(), "\n");
  if(fn=="") {pf=paste0(abbr,"o", ord)} else {pf=paste0(fn, ".png")};
  if(ttl!="") {dftt=ttl}; ttl=paste0(dftt,", order ", ord);
  cat(" *** Plot file:", pf,".png", "title:", ttl, "\n");
  for(y in 1:n) {
    for(x in 1:n) {
      if(bitwAnd(x, y)==0) {M[x,y]=1}
    ##if(bitwAnd(x, y)>0) {M[x,y]=1}   ## Try this for "reversed" ST
  }}
  plotmat(M, pf, clr, ttl);
  cat(" *** END", abbr, date(), "\n");
}
## Executing:
pSierpinskiT(6,,,"red");
pSierpinskiT(8);


# Dati
totale <- 12
monetevincenti <- 4
moneteperdenti <- 8

estratte <- 4

# Y = AX + B(C + DX)
A <- 2
B <- 1
C <- 4
D <- -1

# Domande

domanda1 <- 0
domanda2 <- 5
domanda3_a <- 8
domanda3_b <- 0

# Svolgimento
d_f <- dhyper(m = monetevincenti, n = moneteperdenti, k = estratte, x = c(0:estratte))
p_f <- phyper(m = monetevincenti, n = moneteperdenti, k = estratte, q = c(0:estratte))

prX <- function(k){
  n <- totale
  h <- monetevincenti
  r <- moneteperdenti

  if(k >= 0) {
    choose(h,k) * choose(n-h, r-k)/choose(n,r)
  }
  else {
    0
  }
}

primadomanda <- 1
if (domanda1 != 0) {
  for(i in 0:(domanda1 - 1)){
    primadomanda <- primadomanda - prX(i)
  }
}

y <- function(x) {
  (B*D+A)*x + B*C
}

y_invert <- function(y) {
  (y - B*C)/(A + B*D)
}

y_list <- sort(c(y(0:estratte)))
secondadomanda <- d_f[y_invert(y_list[domanda2])+1]

TRENTA <- 30

if(domanda3_a <= y_list[estratte+1]) {
  d3_primointervallo <- seq(y_invert(domanda3_a), TRENTA)
} else {
  d3_primointervallo <- seq(-TRENTA, y_invert(domanda3_a))
}

if(domanda3_b <= y_list[estratte+1]) {
  d3_secondointervallo <- seq(domanda3_b, TRENTA)
} else {
  d3_secondointervallo <- seq(-TRENTA, domanda3_b)
}

tmp <- intersect(d3_primointervallo, d3_secondointervallo)+1
tmp <- tmp[!is.na(tmp)]
if (length(tmp) > 1) {
  numeratore <- d_f[tmp]
  numeratore <- numeratore[!is.na(numeratore)]
  denominatore <- d_f[d3_secondointervallo+1]
  denominatore <- denominatore[!is.na(denominatore)]
  terzadomanda <- sum(numeratore)/sum(denominatore)
} else {
  terzadomanda <- p_f[tmp]/sum(d_f[d3_secondointervallo+1])
}

if(length(terzadomanda) == 0) {
  terzadomanda <- 0
}

# Output
print(primadomanda)
print(secondadomanda)
print(terzadomanda)


# Guía del fichero: https://rpubs.com/probestaunal/taller01

###################################################################################################
#                                  INTRODUCCIÓN A LA ESTADÍSTICA                                  #
###################################################################################################
#  1. Clasificar según su naturaleza (cualitativa, cuantitativa discreta, cuantitativa continua)  #
#     y establecer la escala de medición de las siguientes variables.                             #
###################################################################################################
# Estrato socio-económico.                                    # Cualitativa, ordinal.             #
# Sexo.                                                       # Cualitativa, nominal.             #
# Número de unidades defectuosas.                             # Cuantitativa discreta, razón.     #
# Calificación de un examen (valores: aprobado, no aprobado). # Cualitativa, nominal.             #
# Nivel educativo (valores: básica, pregrado, posgrado).      # Cualitativa, ordinal.             #
# Estatura (en metros).                                       # Cuantitativa continua, razón.     #
# Temperatura (en grados centigrados).                        # Cuantitativa continua, intervalo. #
# Edad (en años cumplidos).                                   # Cuantitativa discreta, razón.     #
# Opinión (valores: a favor, en contra, no sabe/no responde). # Cualitativa, nominal.             #
# Raza.                                                       # Cualitativa, nominal.             #
# Número de hermanos.                                         # Cuantitativa discreta, razón      #
# Utilidades anuales (en millones pesos).                     # Cuantitativa continua, razón.     #
# Tiempo requerido para ejecutar una tarea (en minutos).      # Cuantitativa continua, razón.     #
# Índice de masa corporal (en kg/m2).                         # Cuantitativa continua, razón.     #
# Concentración de dióxido de carbono (CO2, en ppm).          # Cuantitativa continua, razón.     #
# pH (valores: básico, neutro, ácido).                        # Cualitativa, ordinal.             #
# Resistencia eléctrica (en ohm).                             # Cuantitativa continua, razón.     #
# Presión (en pa).                                            # Cuantitativa continua, razón.     #
# Densidad (en kg/m3).                                        # Cuantitativa continua, razón.     #
# Latitud/longitud (en grados, minutos y segundos).           # Cuantitativa continua, intervalo. #
###################################################################################################


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

# https://cran.r-project.org/web/packages/GA/vignettes/GA.html#constrained-optimisation
func3d <- function(x)
{
  100*(x[1]^2-x[2]^2)+(1-x[1])^2
}

c1 <- function(x)
{
  x[1]*x[2] + x[1] - x[2] + 1.5
}

c2 <- function(x)
{
  10 - x[1]*x[2]
}

x1LBound <- 0
x1RBound <- 1
x2LBound <- 0
x2RBound <- 13

ngrid <- 250
x1 <- seq(x1LBound, x1RBound, length = ngrid)
x2 <- seq(x2LBound, x2RBound, length = ngrid)
x12 <- expand.grid(x1, x2)
col <- adjustcolor(bl2gr.colors(4)[2:3], alpha = 0.2)
plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
image(x1, x2, matrix(ifelse(apply(x12, 1, c2) <= 0, 0, NA), ngrid, ngrid), col = col[2], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = 21, add = TRUE)

fitness <- function(x)
{ r
  f <- -func3d(x)                    # we need to maximise -func3d(x)
  pen <- sqrt(.Machine$double.xmax)  # penalty term
  penalty1 <- max(c1(x),0)*pen       # penalisation for 1st inequality constraint
  penalty2 <- max(c2(x),0)*pen       # penalisation for 2nd inequality constraint
  f - penalty1 - penalty2            # fitness function value
}

GA <- ga("real-valued", fitness = fitness,
         lower = c(x1LBound, x2LBound), upper = c(x1RBound, x2RBound),
         # selection = GA:::gareal_lsSelection_R,
         maxiter = 1000, run = 200, seed = 123)
summary(GA)

fitness(GA@solution)
func3d(GA@solution)
c1(GA@solution)
c2(GA@solution)

plot(x1, x2, type = "n", xaxs = "i", yaxs = "i")
image(x1, x2, matrix(ifelse(apply(x12, 1, c1) <= 0, 0, NA), ngrid, ngrid), col = col[1], add = TRUE)
image(x1, x2, matrix(ifelse(apply(x12, 1, c2) <= 0, 0, NA), ngrid, ngrid), col = col[2], add = TRUE)
contour(x1, x2, matrix(apply(x12, 1, func3d), ngrid, ngrid), nlevels = 21, add = TRUE)
points(GA@solution[1], GA@solution[2], col = "dodgerblue3", pch = 3)  # GA solution


efficient_frontier = function(MRet,rangeMu)
{
  uM = dim(MRet)[1]
  pM = dim(MRet)[2]
  #compute the portfolio's expected returns
  expRet = colMeans(MRet)

  #use sample variance matrix (does not change anything compared to pop. so this one
  #is unbiased!)

  Omega = var(MRet)
  # expVar = t(weights)%*%Omega%*%weights

  #create a matrix of expected returns and constraints: t(E) and t(1) right and only one
  #cause its the returns of each and the weight of each that we scale to one
  unityVec = rep(1,pM)

  A = rbind(expRet,unityVec)
  print(A)

  # compute var in function of expected returns independently of the weights:
  n = length(rangeMu)
  myVar = rep(NA,n)
  myWeights = matrix(data=NA,nrow=n,ncol=pM)

  for(i in 1:n)
  {
    b = matrix(data=c(rangeMu[i],1),nrow=2)
    myVar[i] = t(b)%*%solve(A%*%solve(Omega)%*%t(A))%*%b
    myWeights[i,] = solve(Omega)%*%t(A)%*%solve(A%*%solve(Omega)%*%t(A))%*%b
  }

  # dev.new()
  mySd = myVar^0.5
  return(mySd)

  # plot(mySd,rangeMu,t='l')
  # Ones = matrix(data=c(1,1),nrow=2)
  # weightsMinVar = solve(Omega)%*%Ones%*%solve(t(Ones)%*%solve(Omega)%*%Ones)
  # muMinVar = t(weightsMinVar)%*%expRet
  #case where we want the sum of the weights to sum to one (less efficient and more risky
  #(we want to achieve a kind of zero investment portfolio.)
  # bMax = matrix(data=c(targetMu,1),nrow=2)
  # print(bMax)

  # bMax = rbind(targetMu,)
  # case where target weights sum to zero - better for us.
  # bMaxZero = matrix(data=c(targetMu,0),nrow=2)
  # bMaxZero = rbind(targetMu,0)
  # weightsMinVarTarget = solve(Omega)%*%t(A)%*%solve(A%*%solve(Omega)%*%t(A))%*%bMaxZero
}

efficient_frontier_single = function(MRet)
{
  rangeMu = seq(0.001,0.025,0.01)
  mySd = efficient_frontier(MRet,rangeMu)

  dev.new()
  plot(mySd*100,rangeMu*100,xlab="volatility (%)",ylab="expected return (%)")
}

efficient_frontier_simul = function(MRet)
{
  pM = dim(MRet)[2]
  rangeMu = seq(-0.01,0.05,0.001)
  mySd = efficient_frontier(MRet[,1:9],rangeMu)

  dev.new()
  plot(mySd*100,rangeMu*100,xlab="volatility (%)",ylab="expected return (%)",t='l',xlim=c(0,max(mySd*100)),ylim=c(-1,5))

  for(j in 10:pM)
  {
    mySd = efficient_frontier(MRet[,1:j],rangeMu)
    lines(mySd*100,rangeMu*100,col='red')
    # Sys.sleep(0.5)
  }
}


## calculate net and zernike fit wavefronts from any of psifit, fftfit, vortexfit

wf_net <- function(wf.raw, cp, options) {

  nr <- nrow(wf.raw)
  nc <- ncol(wf.raw)
  prt <- pupil.rhotheta(nr, nc, cp)
  rho <- prt$rho
  theta <- prt$theta
  if (options$sgs > 1) {
    subs <- matrix(FALSE, nr, nc)
    subs[seq(1, nr, by=options$sgs), seq(1, nc, by=options$sgs)] <- TRUE
    subs[is.na(rho)] <- FALSE
  } else {
    subs <- !is.na(rho)
  }
  wf.v <- wf.raw[subs]
  rho.v <- rho[subs]
  th.v <- theta[subs]
  rho.v <- rho.v[!is.na(wf.v)]
  th.v <- th.v[!is.na(wf.v)]
  wf.v <- wf.v[!is.na(wf.v)]
  fit <- fitzernikes(wf.v, rho.v, th.v,
                     eps=cp$obstruct,
                     maxorder=options$maxorder,
                     nthreads=options$nthreads,
                     uselm=options$uselm,
                     isoseq=options$isoseq)
  if (options$uselm) {
    cfit <- coef(fit)
  } else {
    cfit <- fit
  }
  if (options$isoseq) {
    ind.ptf <- c(1:3, 5)
    ind.sa4 <- 13
    ind.sa6 <- 25
    ind.astig <- c(6, 4)
    ind.coma <- 8:9
    zc.low <- numeric(28)
  } else {
    ind.ptf <- 1:4
    ind.sa4 <- 9
    ind.sa6 <- 16
    ind.astig <- 5:6
    ind.coma <- 7:8
    zc.low <- numeric(16)
  }
  if (sign(cfit[ind.sa4])*sign(options$satarget[1]) < 0) {
    cfit <- -cfit
    wf.raw <- -wf.raw
    if (!options$uselm) fit <- -fit
  }

  zc.low[ind.ptf] <- cfit[ind.ptf]
  zc.low[c(ind.sa4, ind.sa6)] <- zc.low[c(ind.sa4, ind.sa6)] + options$satarget
  zc.low[ind.astig] <- zc.low[ind.astig] + options$astig.bath
  if (is.element(6, options$zc0)) {
    zc.low[ind.coma] <- cfit[ind.coma]
  }
  wf.net <- wf.raw - pupil(zcoef=zc.low, maxorder=6, isoseq=options$isoseq,
                           nrow=nr, ncol=nc, cp=cp)
  if (options$plots) {
    if (tolower(.Platform$OS.type) == "windows") {
      windows(width=18, height=6)
    } else {
        x11(width=18, height=6)
    }
    split.screen(figs=c(1,3))
    screen(1)
    plot(wf.net, cp=cp, col=options$colors, addContours=FALSE)
    mtext(paste("RMS = ", format(pupilrms(wf.net),digits=3)))
  }
  zcoef.net <- cfit
  zcoef.net[1:length(zc.low)] <- zcoef.net[1:length(zc.low)] - zc.low
  wf.smooth <- pupil(zcoef=zcoef.net, maxorder=options$maxorder, isoseq=options$isoseq,
                     cp=cp, nrow=nr, ncol=nc)
  if (options$plots) {
    screen(2)
    plot(wf.smooth, cp=cp, col=options$colors)
    mtext(paste("RMS = ", format(pupilrms(wf.smooth),digits=3)))
  }
  wf.residual <- wf.net - wf.smooth
  if (options$plots) {
    screen(3)
    plot(wf.residual, cp=cp, col=grey256, addContours=FALSE)
    mtext(paste("RMS = ", format(pupilrms(wf.residual),digits=3)))
    close.screen(all.screens=TRUE)
  }
  list(wf.net=wf.net, wf.smooth=wf.smooth, wf.residual=wf.residual,
       fit=fit, zcoef.net=zcoef.net[-1])
}

#' Methods for class "wf_fitted"
#'
#' Summary, print, and plot methods for the returned list of values
#'  from [psifit()], [fftfit()], or [vortexfit()]
#'
#' @param wffit the return values from one of the fringe analysis routines
#' @param digits number of digits to display in print and summary methods
#' @param ... values passed to [plot.pupil()]
#' @return print method returns data frame with Zernike coefficients
summary.wf_fitted <- function(wffit, digits=3) {
  cat("Image size(s)     : ", nrow(wffit$wf.smooth), " x ", ncol(wffit$wf.smooth), "\n")
  cat("Unsmoothed RMS    : ", format(pupilrms(wffit$wf.net), digits=digits), "\n")
  cat("Zernike fit RMS   : ", format(sqrt(crossprod(wffit$zcoef.net)), digits=digits), "\n")
  cat("Zernike fit Strehl: ", format(strehlratio(sqrt(crossprod(wffit$zcoef.net))), digits=digits), "\n")
  cat("Zernike fit P-V   : ", format(pupilpv(wffit$wf.smooth), digits=digits), "\n")
  cat("PVr               : ", format(PVr(wffit$wf.smooth, wffit$wf.residual), digits=digits), "\n")
}

print.wf_fitted <- function(wffit, digits=3) {
  if (is.element("lm", class(wffit$fit))) {
    fit <- coef(wffit$fit)
  } else {
    fit <- wffit$fit
  }
  nz <- length(wffit$zcoef.net)
  znames <- paste("Z", 0:nz, sep="")
  df.zernikes <- data.frame(Z = znames, Zcoef.Raw = fit, Zcoef.net = c(0, wffit$zcoef.net))
  summary.wf_fitted(wffit, digits=digits)
  cat("\n")
  print(df.zernikes, digits=digits, row.names=FALSE)
  invisible(df.zernikes)
}

plot.wf_fitted <- function(wffit, wftype="smooth", ...) {
  wf <- get(paste("wf", wftype, sep="."), wffit)
  plot.pupil(wf, cp=wffit$cp, ...)
}


##' Estimate minimum specificity from population testing
##'
##' Produces an estimate of minimum specificty under the assumption that of the tests identified only negatives as positives
##' @param positive vector of numbers; the number of positive tests in each sample
##' @param total vector of numbres; the total number of tests (positive and negative) in each sample
##' @param cutoff the cutoff for the estimate, i.e. the confidence level desired
##' @param samples number of values of specificity to sample
##' @param min_specificity minimum specificity to test
##' @param max_specificity maximum specificity to test
##' @param prevalence background prevalence; if >0 then it is assumed that
##' sensitivity is 0, i.e. all positives are still false positives and some of
##' the negatives are false negatives
##' @return estimate of the lower bound of specificity at
##' the desired confidence level
##' @author Sebastian Funk
##' @export
estimate_min_specificity <- function(positive, total, cutoff = 0.95,
                                     samples = 1000,
                                     min_specificity = 0.997,
                                     max_specificity = 1,
                                     prevalence = 0) {

  true_negative <- round(pmax(positive, total * (1 - prevalence)))

  ## create data frame with false test positive and true test negative
  dta <- tibble(positive = positive, negative = true_negative - positive)
  spec <- dta %>%
    expand_grid(specificity =
                  seq(min_specificity, max_specificity,
                      length.out = samples)) %>%
    ## probability of seeing positives given specificty is at most x
    ## (where at the maximum all positives are false positives)
    mutate(p = pbeta(1 - specificity, positive + 1,
                     negative + 1, lower.tail = FALSE)) %>%
    group_by(specificity) %>%
    ## overall probability that specificity is at most x
    summarise(probability = 1 - prod(p), .groups = "drop") %>%
    ungroup()

  min_spec <- spec %>%
    ## get probability that specificity is at least x
    filter(probability > cutoff) %>%
    summarise(min_spec = max(specificity)) %>%
    .$min_spec

  return(min_spec)
}


runsum <- function(v) {
  rs <- c()
  for(i in 1:length(v)) {
    rs <- c(rs, sum(v[1:i]))
  }
  rs
}

grade <- function(v) {
  g <- vector("numeric", length(v))
  for(i in 1:length(v)) {
    g[v[i]] <- i-1
  }
  g
}

makespiral <- function(spirald) {
  series <- vector("numeric", spirald^2)
  series[] <- 1
  l <- spirald-1; p <- spirald+1
  s <- 1
  while(l > 0) {
    series[p:(p+l-1)] <- series[p:(p+l-1)] * spirald*s
    series[(p+l):(p+l*2-1)] <- -s*series[(p+l):(p+l*2-1)]
    p <- p + l*2
    l <- l - 1; s <- -s
  }
  matrix(grade(runsum(series)), spirald, spirald, byrow=TRUE)

}

print(makespiral(5))